mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 05:50:26 +02:00
Code Activity

Refactor aux definition fabrication in CSE pass

Browse source 
* module/language/cps/cse.scm (compute-equivalent-subexpressions):
  Define a little language for creating aux definitions.
This commit is contained in:
Andy Wingo 2017-11-27 16:18:40 +01:00
parent 7d71d9b945
commit bc1fdf73db
1 changed files with 52 additions and 81 deletions
Download patch file Download diff file Expand all files Collapse all files

133
module/language/cps/cse.scm
View file

@ -257,91 +257,62 @@ false. It could be that both true and false proofs are available."
(($ $prompt escape? tag handler) #f))) (($ $prompt escape? tag handler) #f)))
(define (add-auxiliary-definitions! label var-substs exp-key) (define (add-auxiliary-definitions! label var-substs exp-key)
(define (subst var) (let ((defs (and=> (intmap-ref defs label)
(subst-var var-substs var)) (lambda (defs) (subst-vars var-substs defs)))))
(let ((defs (intmap-ref defs label)))
(define (add-def! aux-key var) (define (add-def! aux-key var)
(let ((equiv (hash-ref equiv-set aux-key '()))) (let ((equiv (hash-ref equiv-set aux-key '())))
(hash-set! equiv-set aux-key (hash-set! equiv-set aux-key
(acons label (list var) equiv)))) (acons label (list var) equiv))))
(match exp-key (define-syntax add-definitions
(('primcall 'box #f val) (syntax-rules (<-)
(match defs ((add-definitions)
((box) #f)
(add-def! `(primcall box-ref #f ,(subst box)) val)))) ((add-definitions
(('primcall 'box-set! #f box val) ((def <- op arg ...) (aux <- op* arg* ...) ...)
(add-def! `(primcall box-ref #f ,box) val)) . clauses)
(('primcall 'cons #f car cdr) (match exp-key
(match defs (('primcall 'op arg ...)
((pair) (match defs
(add-def! `(primcall car #f ,(subst pair)) car) ((def) (add-def! (list 'primcall 'op* arg* ...) aux) ...)))
(add-def! `(primcall cdr #f ,(subst pair)) cdr)))) (_ (add-definitions . clauses))))
(('primcall 'set-car! #f pair car) ((add-definitions
(add-def! `(primcall car #f ,pair) car)) ((op arg ...) (aux <- op* arg* ...) ...)
(('primcall 'set-cdr! #f pair cdr) . clauses)
(add-def! `(primcall cdr #f ,pair) cdr)) (match exp-key
;; FIXME: how to propagate make-vector/immediate -> vector-length? (('primcall 'op arg ...)
(('primcall 'make-vector #f len fill) (add-def! (list 'primcall 'op* arg* ...) aux) ...)
(match defs (_ (add-definitions . clauses))))))
((vec) (add-definitions
(add-def! `(primcall vector-length #f ,(subst vec)) len)))) ((b <- box #f o) (o <- box-ref #f b))
(('primcall 'vector-set! #f vec idx val) ((box-set! #f b o) (o <- box-ref #f b))
(add-def! `(primcall vector-ref #f ,vec ,idx) val)) ((o <- cons #f x y) (x <- car #f o)
(('primcall 'vector-set!/immediate idx vec val) (y <- cdr #f o))
(add-def! `(primcall vector-ref/immediate ,idx ,vec) val)) ((set-car! #f o x) (x <- car #f o))
(('primcall 'allocate-struct #f vtable size) ((set-cdr! #f o y) (y <- cdr #f o))
(match defs ;; FIXME: how to propagate make-vector/immediate -> vector-length?
((struct) ((v <- make-vector #f n x) (n <- vector-length #f v))
(add-def! `(primcall struct-vtable #f ,(subst struct)) ((vector-set! #f v i x) (x <- vector-ref #f v i))
vtable)))) ((vector-set!/immediate i v x) (x <- vector-ref/immediate i v))
(('primcall 'allocate-struct/immediate size vtable) ((s <- allocate-struct #f v n) (v <- struct-vtable #f s))
(match defs ((s <- allocate-struct/immediate n v) (v <- struct-vtable #f s))
((struct) ((struct-set! #f s i x) (x <- struct-ref #f s i))
(add-def! `(primcall struct-vtable #f ,(subst struct)) ((struct-set!/immediate i s x) (x <- struct-ref/immediate i s))
vtable)))) ((u <- scm->f64 #f s) (s <- f64->scm #f u))
;; FIXME: Aren't we missing some "subst" calls here? ((s <- f64->scm #f u) (u <- scm->f64 #f s))
(('primcall 'struct-set! #f struct n val) ((u <- scm->u64 #f s) (s <- u64->scm #f u))
(add-def! `(primcall struct-ref #f ,struct ,n) val)) ((s <- u64->scm #f u) (u <- scm->u64 #f s)
(('primcall 'struct-set!/immediate n struct val) (u <- scm->u64/truncate #f s))
(add-def! `(primcall struct-ref/immediate ,n ,struct) val)) ((s <- u64->scm/unlikely #f u) (u <- scm->u64 #f s)
(('primcall 'scm->f64 #f scm) (u <- scm->u64/truncate #f s))
(match defs ((u <- scm->s64 #f s) (s <- s64->scm #f u))
((f64) ((s <- s64->scm #f u) (u <- scm->s64 #f s))
(add-def! `(primcall f64->scm #f ,f64) scm)))) ((s <- s64->scm/unlikely #f u) (u <- scm->s64 #f s))
(('primcall 'f64->scm #f f64) ((u <- untag-fixnum #f s) (s <- s64->scm #f u)
(match defs (s <- tag-fixnum #f u))
((scm) ;; NB: These definitions rely on U having top 2 bits equal to
(add-def! `(primcall scm->f64 #f ,scm) f64)))) ;; 3rd (sign) bit.
(('primcall 'scm->u64 #f scm) ((s <- tag-fixnum #f u) (u <- scm->s64 #f s)
(match defs (u <- untag-fixnum #f s)))))
((u64)
(add-def! `(primcall u64->scm #f ,u64) scm))))
(('primcall (or 'u64->scm 'u64->scm/unlikely) #f u64)
(match defs
((scm)
(add-def! `(primcall scm->u64 #f ,scm) u64)
(add-def! `(primcall scm->u64/truncate #f ,scm) u64))))
(('primcall 'scm->s64 #f scm)
(match defs
((s64)
(add-def! `(primcall s64->scm #f ,s64) scm))))
(('primcall (or 's64->scm 's64->scm/unlikely) #f s64)
(match defs
((scm)
(add-def! `(primcall scm->s64 #f ,scm) s64))))
(('primcall 'untag-fixnum #f scm)
(match defs
((s64)
(add-def! `(primcall s64->scm #f ,s64) scm)
(add-def! `(primcall tag-fixnum #f ,s64) scm))))
(('primcall 'tag-fixnum #f fx)
(match defs
((scm)
;; NB: These definitions rely on FX having top 2 bits
;; equal to 3rd (sign) bit.
(add-def! `(primcall scm->s64 #f ,scm) fx)
(add-def! `(primcall untag-fixnum #f ,scm) fx))))
(_ #t))))
(define (visit-label label equiv-labels var-substs) (define (visit-label label equiv-labels var-substs)
(match (intmap-ref conts label) (match (intmap-ref conts label)