mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-23 12:00:21 +02:00
Code Activity

CPS conversion renames incoming gensyms to small integers

Browse source 
* module/language/tree-il/compile-cps.scm (fold-formals)
  (unbound?, init-default-value, convert): Arrange to rename incoming
  gensyms as small integers.
  (canonicalize): Convert vector and abort here too.
This commit is contained in:
Andy Wingo 2014-03-28 21:30:55 +01:00
parent 699ed8ce29
commit e6cf744ab4
1 changed files with 151 additions and 119 deletions
Download patch file Download diff file Expand all files Collapse all files

270
module/language/tree-il/compile-cps.scm
View file

@ -149,13 +149,15 @@
(error "too many inits")) (error "too many inits"))
seed) seed)
(((key name var) . kw) (((key name var) . kw)
(unless (eq? var (car gensyms)) ;; Could be that var is not a gensym any more.
(error "unexpected keyword arg order")) (when (symbol? var)
(proc name var (car inits) (unless (eq? var (car gensyms))
(error "unexpected keyword arg order")))
(proc name (car gensyms) (car inits)
(fold-kw kw (cdr gensyms) (cdr inits) seed))))) (fold-kw kw (cdr gensyms) (cdr inits) seed)))))
(fold-req req gensyms seed))))) (fold-req req gensyms seed)))))
(define (unbound? src sym kt kf) (define (unbound? src var kt kf)
(define tc8-iflag 4) (define tc8-iflag 4)
(define unbound-val 9) (define unbound-val 9)
(define unbound-bits (logior (ash unbound-val 8) tc8-iflag)) (define unbound-bits (logior (ash unbound-val 8) tc8-iflag))
@ -165,11 +167,11 @@
(pointer->scm (make-pointer unbound-bits)))) (pointer->scm (make-pointer unbound-bits))))
($letk ((ktest ($kif kt kf))) ($letk ((ktest ($kif kt kf)))
($continue ktest src ($continue ktest src
($primcall 'eq? (sym unbound)))))))) ($primcall 'eq? (var unbound))))))))
(define (init-default-value name sym subst init body) (define (init-default-value name sym subst init body)
(match (assq-ref subst sym) (match (hashq-ref subst sym)
((subst-sym box?) ((orig-var subst-var box?)
(let ((src (tree-il-src init))) (let ((src (tree-il-src init)))
(define (maybe-box k make-body) (define (maybe-box k make-body)
(if box? (if box?
@ -181,19 +183,19 @@
(make-body k))) (make-body k)))
(let-fresh (knext kbound kunbound kreceive krest) (val rest) (let-fresh (knext kbound kunbound kreceive krest) (val rest)
(build-cps-term (build-cps-term
($letk ((knext ($kargs (name) (subst-sym) ,body))) ($letk ((knext ($kargs (name) (subst-var) ,body)))
,(maybe-box ,(maybe-box
knext knext
(lambda (k) (lambda (k)
(build-cps-term (build-cps-term
($letk ((kbound ($kargs () () ($continue k src ($letk ((kbound ($kargs () () ($continue k src
($values (sym))))) ($values (orig-var)))))
(krest ($kargs (name 'rest) (val rest) (krest ($kargs (name 'rest) (val rest)
($continue k src ($values (val))))) ($continue k src ($values (val)))))
(kreceive ($kreceive (list name) 'rest krest)) (kreceive ($kreceive (list name) 'rest krest))
(kunbound ($kargs () () (kunbound ($kargs () ()
,(convert init kreceive subst)))) ,(convert init kreceive subst))))
,(unbound? src sym kunbound kbound)))))))))))) ,(unbound? src orig-var kunbound kbound))))))))))))
;; exp k-name alist -> term ;; exp k-name alist -> term
(define (convert exp k subst) (define (convert exp k subst)
@ -201,14 +203,14 @@
(define (convert-arg exp k) (define (convert-arg exp k)
(match exp (match exp
(($ <lexical-ref> src name sym) (($ <lexical-ref> src name sym)
(match (assq-ref subst sym) (match (hashq-ref subst sym)
((box #t) ((orig-var box #t)
(let-fresh (kunboxed) (unboxed) (let-fresh (kunboxed) (unboxed)
(build-cps-term (build-cps-term
($letk ((kunboxed ($kargs ('unboxed) (unboxed) ,(k unboxed)))) ($letk ((kunboxed ($kargs ('unboxed) (unboxed) ,(k unboxed))))
($continue kunboxed src ($primcall 'box-ref (box))))))) ($continue kunboxed src ($primcall 'box-ref (box)))))))
((subst #f) (k subst)) ((orig-var subst-var #f) (k subst-var))
(#f (k sym)))) (var (k var))))
(else (else
(let-fresh (kreceive karg) (arg rest) (let-fresh (kreceive karg) (arg rest)
(build-cps-term (build-cps-term
@ -226,20 +228,24 @@
(lambda (names) (lambda (names)
(k (cons name names))))))))) (k (cons name names)))))))))
(define (box-bound-var name sym body) (define (box-bound-var name sym body)
(match (assq-ref subst sym) (match (hashq-ref subst sym)
((box #t) ((orig-var subst-var #t)
(let-fresh (k) () (let-fresh (k) ()
(build-cps-term (build-cps-term
($letk ((k ($kargs (name) (box) ,body))) ($letk ((k ($kargs (name) (subst-var) ,body)))
($continue k #f ($primcall 'box (sym))))))) ($continue k #f ($primcall 'box (orig-var)))))))
(else body))) (else body)))
(define (bound-var sym)
(match (hashq-ref subst sym)
((var . _) var)
((? exact-integer? var) var)))
(match exp (match exp
(($ <lexical-ref> src name sym) (($ <lexical-ref> src name sym)
(match (assq-ref subst sym) (rewrite-cps-term (hashq-ref subst sym)
((box #t) (build-cps-term ($continue k src ($primcall 'box-ref (box))))) ((orig-var box #t) ($continue k src ($primcall 'box-ref (box))))
((subst #f) (build-cps-term ($continue k src ($values (subst))))) ((orig-var subst-var #f) ($continue k src ($values (subst-var))))
(#f (build-cps-term ($continue k src ($values (sym))))))) (var ($continue k src ($values (var))))))
(($ <void> src) (($ <void> src)
(build-cps-term ($continue k src ($void)))) (build-cps-term ($continue k src ($void))))
@ -257,25 +263,30 @@
(#f '()) (#f '())
(($ <lambda-case> src req opt rest kw inits gensyms body alternate) (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
(let* ((arity (make-$arity req (or opt '()) rest (let* ((arity (make-$arity req (or opt '()) rest
(if kw (cdr kw) '()) (and kw (car kw)))) (map (match-lambda
((kw name sym)
(list kw name (bound-var sym))))
(if kw (cdr kw) '()))
(and kw (car kw))))
(names (fold-formals (lambda (name sym init names) (names (fold-formals (lambda (name sym init names)
(cons name names)) (cons name names))
'() '()
arity gensyms inits))) arity gensyms inits)))
(cons (cons
(let-fresh (kclause kargs) () (let ((bound-vars (map bound-var gensyms)))
(build-cps-cont (let-fresh (kclause kargs) ()
(kclause (build-cps-cont
($kclause ,arity (kclause
(kargs ($kclause ,arity
($kargs names gensyms (kargs
,(fold-formals ($kargs names bound-vars
(lambda (name sym init body) ,(fold-formals
(if init (lambda (name sym init body)
(init-default-value name sym subst init body) (if init
(box-bound-var name sym body))) (init-default-value name sym subst init body)
(convert body ktail subst) (box-bound-var name sym body)))
arity gensyms inits))))))) (convert body ktail subst)
arity gensyms inits))))))))
(convert-clauses alternate ktail)))))) (convert-clauses alternate ktail))))))
(if (current-topbox-scope) (if (current-topbox-scope)
(let-fresh (kentry ktail) (self) (let-fresh (kentry ktail) (self)
@ -338,48 +349,14 @@
(($ <primcall> src name args) (($ <primcall> src name args)
(cond (cond
((branching-primitive? name) ((branching-primitive? name)
(convert (make-conditional src exp (make-const #f #t) (convert-args args
(make-const #f #f)) (lambda (args)
k subst)) (let-fresh (kt kf kif) ()
((and (eq? name 'vector) (build-cps-term
(and-map (match-lambda ($letk ((kt ($kargs () () ($continue k src ($const #t))))
((or ($ <const>) (kf ($kargs () () ($continue k src ($const #f))))
($ <void>) (kif ($kif kt kf)))
($ <lambda>) ($continue kif src ($primcall name args))))))))
($ <lexical-ref>)) #t)
(_ #f))
args))
;; Some macros generate calls to "vector" with like 300
;; arguments. Since we eventually compile to make-vector and
;; vector-set!, it reduces live variable pressure to allocate the
;; vector first, then set values as they are produced, if we can
;; prove that no value can capture the continuation. (More on
;; that caveat here:
;; http://wingolog.org/archives/2013/11/02/scheme-quiz-time).
;;
;; Normally we would do this transformation in the compiler, but
;; it's quite tricky there and quite easy here, so hold your nose
;; while we drop some smelly code.
(convert (let ((len (length args)))
(let-fresh () (v)
(make-let src
(list 'v)
(list v)
(list (make-primcall src 'make-vector
(list (make-const #f len)
(make-const #f #f))))
(fold (lambda (arg n tail)
(make-seq
src
(make-primcall
src 'vector-set!
(list (make-lexical-ref src 'v v)
(make-const #f n)
arg))
tail))
(make-lexical-ref src 'v v)
(reverse args) (reverse (iota len))))))
k subst))
((and (eq? name 'list) ((and (eq? name 'list)
(and-map (match-lambda (and-map (match-lambda
((or ($ <const>) ((or ($ <const>)
@ -388,7 +365,8 @@
($ <lexical-ref>)) #t) ($ <lexical-ref>)) #t)
(_ #f)) (_ #f))
args)) args))
;; The same situation occurs with "list". ;; See note below in `canonicalize' about `vector'. The same
;; thing applies to `list'.
(let lp ((args args) (k k)) (let lp ((args args) (k k))
(match args (match args
(() (()
@ -427,11 +405,12 @@
;; Otherwise we do a no-inline call to body, continuing to krest. ;; Otherwise we do a no-inline call to body, continuing to krest.
(convert-arg tag (convert-arg tag
(lambda (tag) (lambda (tag)
(let ((hnames (append hreq (if hrest (list hrest) '())))) (let ((hnames (append hreq (if hrest (list hrest) '())))
(bound-vars (map bound-var hsyms)))
(let-fresh (khargs khbody kret kprim kpop krest kbody) (prim vals) (let-fresh (khargs khbody kret kprim kpop krest kbody) (prim vals)
(build-cps-term (build-cps-term
;; FIXME: Attach hsrc to $kreceive. ;; FIXME: Attach hsrc to $kreceive.
($letk* ((khbody ($kargs hnames hsyms ($letk* ((khbody ($kargs hnames bound-vars
,(fold box-bound-var ,(fold box-bound-var
(convert hbody k subst) (convert hbody k subst)
hnames hsyms))) hnames hsyms)))
@ -500,8 +479,8 @@
(($ <lexical-set> src name gensym exp) (($ <lexical-set> src name gensym exp)
(convert-arg exp (convert-arg exp
(lambda (exp) (lambda (exp)
(match (assq-ref subst gensym) (match (hashq-ref subst gensym)
((box #t) ((orig-var box #t)
(build-cps-term (build-cps-term
($continue k src ($primcall 'box-set! (box exp))))))))) ($continue k src ($primcall 'box-set! (box exp)))))))))
@ -520,7 +499,7 @@
(((name . names) (sym . syms) (val . vals)) (((name . names) (sym . syms) (val . vals))
(let-fresh (kreceive klet) (rest) (let-fresh (kreceive klet) (rest)
(build-cps-term (build-cps-term
($letk* ((klet ($kargs (name 'rest) (sym rest) ($letk* ((klet ($kargs (name 'rest) ((bound-var sym) rest)
,(box-bound-var name sym ,(box-bound-var name sym
(lp names syms vals)))) (lp names syms vals))))
(kreceive ($kreceive (list name) 'rest klet))) (kreceive ($kreceive (list name) 'rest klet)))
@ -532,7 +511,7 @@
(let-fresh () (self) (let-fresh () (self)
(build-cps-term (build-cps-term
($letrec names ($letrec names
gensyms (map bound-var gensyms)
(map (lambda (fun) (map (lambda (fun)
(match (convert fun k subst) (match (convert fun k subst)
(($ $continue _ _ (and fun ($ $fun))) (($ $continue _ _ (and fun ($ $fun)))
@ -548,10 +527,11 @@
(($ <let-values> src exp (($ <let-values> src exp
($ <lambda-case> lsrc req #f rest #f () syms body #f)) ($ <lambda-case> lsrc req #f rest #f () syms body #f))
(let ((names (append req (if rest (list rest) '())))) (let ((names (append req (if rest (list rest) '())))
(bound-vars (map bound-var syms)))
(let-fresh (kreceive kargs) () (let-fresh (kreceive kargs) ()
(build-cps-term (build-cps-term
($letk* ((kargs ($kargs names syms ($letk* ((kargs ($kargs names bound-vars
,(fold box-bound-var ,(fold box-bound-var
(convert body k subst) (convert body k subst)
names syms))) names syms)))
@ -559,37 +539,54 @@
,(convert exp kreceive subst)))))))) ,(convert exp kreceive subst))))))))
(define (build-subst exp) (define (build-subst exp)
"Compute a mapping from lexical gensyms to substituted gensyms. The "Compute a mapping from lexical gensyms to CPS variable indexes. CPS
usual reason to replace one variable by another is assignment uses small integers to identify variables, instead of gensyms.
conversion. Default argument values is the other reason.
Returns a list of (ORIG-SYM SUBST-SYM BOXED?). A true value for BOXED? This subst table serves an additional purpose of mapping variables to
indicates that the replacement variable is in a box." replacements. The usual reason to replace one variable by another is
(define (box-set-vars exp subst) assignment conversion. Default argument values is the other reason.
(match exp
(($ <lexical-set> src name sym exp) The result is a hash table mapping symbols to substitutions (in the case
(if (assq sym subst) that a variable is substituted) or to indexes. A substitution is a list
subst of the form:
(cons (list sym (gensym "b") #t) subst)))
(_ subst))) (ORIG-INDEX SUBST-INDEX BOXED?)
(define (default-args exp subst)
(match exp A true value for BOXED? indicates that the replacement variable is in a
(($ <lambda-case> src req opt rest kw inits gensyms body alternate) box. If a variable is not substituted, the mapped value is a small
(fold-formals (lambda (name sym init subst) integer."
(if init (let ((table (make-hash-table)))
(let ((box? (match (assq-ref subst sym) (define (down exp)
((box #t) #t) (match exp
(#f #f))) (($ <lexical-set> src name sym exp)
(subst-sym (gensym (symbol->string name)))) (match (hashq-ref table sym)
(cons (list sym subst-sym box?) subst)) ((orig subst #t) #t)
subst)) ((orig subst #f) (hashq-set! table sym (list orig subst #t)))
subst ((? number? idx) (hashq-set! table sym (list idx (fresh-var) #t)))))
(make-$arity req (or opt '()) rest (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
(if kw (cdr kw) '()) (and kw (car kw))) (fold-formals (lambda (name sym init seed)
gensyms (hashq-set! table sym
inits)) (if init
(_ subst))) (list (fresh-var) (fresh-var) #f)
(tree-il-fold box-set-vars default-args '() exp)) (fresh-var))))
#f
(make-$arity req (or opt '()) rest
(if kw (cdr kw) '()) (and kw (car kw)))
gensyms
inits))
(($ <let> src names gensyms vals body)
(for-each (lambda (sym)
(hashq-set! table sym (fresh-var)))
gensyms))
(($ <fix> src names gensyms vals body)
(for-each (lambda (sym)
(hashq-set! table sym (fresh-var)))
gensyms))
(_ #t))
(values))
(define (up exp) (values))
((make-tree-il-folder) exp down up)
table))
(define (cps-convert/thunk exp) (define (cps-convert/thunk exp)
(parameterize ((label-counter 0) (parameterize ((label-counter 0)
@ -628,10 +625,45 @@ indicates that the replacement variable is in a box."
(optimize x e opts)) (optimize x e opts))
(define (fix-prompts exp) (define (canonicalize exp)
(post-order (post-order
(lambda (exp) (lambda (exp)
(match exp (match exp
(($ <primcall> src 'vector
(and args
((or ($ <const>) ($ <void>) ($ <lambda>) ($ <lexical-ref>))
...)))
;; Some macros generate calls to "vector" with like 300
;; arguments. Since we eventually compile to make-vector and
;; vector-set!, it reduces live variable pressure to allocate the
;; vector first, then set values as they are produced, if we can
;; prove that no value can capture the continuation. (More on
;; that caveat here:
;; http://wingolog.org/archives/2013/11/02/scheme-quiz-time).
;;
;; Normally we would do this transformation in the compiler, but
;; it's quite tricky there and quite easy here, so hold your nose
;; while we drop some smelly code.
(let ((len (length args))
(v (gensym "v ")))
(make-let src
(list 'v)
(list v)
(list (make-primcall src 'make-vector
(list (make-const #f len)
(make-const #f #f))))
(fold (lambda (arg n tail)
(make-seq
src
(make-primcall
src 'vector-set!
(list (make-lexical-ref src 'v v)
(make-const #f n)
arg))
tail))
(make-lexical-ref src 'v v)
(reverse args) (reverse (iota len))))))
(($ <prompt> src escape-only? tag body (($ <prompt> src escape-only? tag body
($ <lambda> hsrc hmeta ($ <lambda> hsrc hmeta
($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f))) ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
@ -673,7 +705,7 @@ indicates that the replacement variable is in a box."
(define (compile-cps exp env opts) (define (compile-cps exp env opts)
(values (cps-convert/thunk (values (cps-convert/thunk
(fix-prompts (optimize-tree-il exp env opts))) (canonicalize (optimize-tree-il exp env opts)))
env env
env)) env))