[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/05: Refactor aux definition fabrication in CSE pass
From: |
Andy Wingo |
Subject: |
[Guile-commits] 01/05: Refactor aux definition fabrication in CSE pass |
Date: |
Tue, 28 Nov 2017 16:36:55 -0500 (EST) |
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)
- [Guile-commits] branch master updated (7d71d9b -> 16ed2ae), Andy Wingo, 2017/11/28
- [Guile-commits] 02/05: Add fabricated expressions for u64-s64 conversion, Andy Wingo, 2017/11/28
- [Guile-commits] 03/05: Fix arity of slsh/immediate inferrer, Andy Wingo, 2017/11/28
- [Guile-commits] 01/05: Refactor aux definition fabrication in CSE pass,
Andy Wingo <=
- [Guile-commits] 05/05: Enable lsh/immediate, rsh/immediate specialization, Andy Wingo, 2017/11/28
- [Guile-commits] 04/05: Tighten up untag-fixnum range, Andy Wingo, 2017/11/28