[Guile-commits] 01/05: Refactor aux definition fabrication in CSE pass

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit bc1fdf73dba30bb3b4d5884e8d721b8a2bb0c506
Author: Andy Wingo <address@hidden>
Date:   Mon Nov 27 16:18:40 2017 +0100

    Refactor aux definition fabrication in CSE pass
    
    * module/language/cps/cse.scm (compute-equivalent-subexpressions):
      Define a little language for creating aux definitions.
---
 module/language/cps/cse.scm | 133 +++++++++++++++++---------------------------
 1 file changed, 52 insertions(+), 81 deletions(-)

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