;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
#:use-module (language cps primitives)
#:use-module (language tree-il analyze)
#:use-module (language tree-il optimize)
- #:use-module ((language tree-il) #:hide (let-gensyms))
+ #:use-module (language tree-il)
#:export (compile-cps))
;;; Guile's semantics are that a toplevel lambda captures a reference on
;;; doesn't work for files auto-compiled for use with `load'.
;;;
(define current-topbox-scope (make-parameter #f))
+(define scope-counter (make-parameter #f))
+
+(define (fresh-scope-id)
+ (let ((scope-id (scope-counter)))
+ (scope-counter (1+ scope-id))
+ scope-id))
(define (toplevel-box src name bound? val-proc)
- (let-gensyms (name-sym bound?-sym kbox box)
+ (let-fresh (kbox) (name-sym bound?-sym box)
(build-cps-term
($letconst (('name name-sym name)
('bound? bound?-sym bound?))
($continue kbox src
($primcall 'resolve
(name-sym bound?-sym)))))
- (scope
- (let-gensyms (scope-sym)
+ (scope-id
+ (let-fresh () (scope-sym)
(build-cps-term
- ($letconst (('scope scope-sym scope))
+ ($letconst (('scope scope-sym scope-id))
($continue kbox src
($primcall 'cached-toplevel-box
(scope-sym name-sym bound?-sym)))))))))))))
(define (module-box src module name public? bound? val-proc)
- (let-gensyms (module-sym name-sym public?-sym bound?-sym kbox box)
+ (let-fresh (kbox) (module-sym name-sym public?-sym bound?-sym box)
(build-cps-term
($letconst (('module module-sym module)
('name name-sym name)
($primcall 'cached-module-box
(module-sym name-sym public?-sym bound?-sym))))))))
-(define (capture-toplevel-scope src scope k)
- (let-gensyms (module scope-sym kmodule)
+(define (capture-toplevel-scope src scope-id k)
+ (let-fresh (kmodule) (module scope-sym)
(build-cps-term
- ($letconst (('scope scope-sym scope))
+ ($letconst (('scope scope-sym scope-id))
($letk ((kmodule ($kargs ('module) (module)
($continue k src
($primcall 'cache-current-module!
(error "too many inits"))
seed)
(((key name var) . kw)
- (unless (eq? var (car gensyms))
- (error "unexpected keyword arg order"))
- (proc name var (car inits)
+ ;; Could be that var is not a gensym any more.
+ (when (symbol? var)
+ (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-req req gensyms seed)))))
-(define (unbound? src sym kt kf)
+(define (unbound? src var kt kf)
(define tc8-iflag 4)
(define unbound-val 9)
(define unbound-bits (logior (ash unbound-val 8) tc8-iflag))
- (let-gensyms (unbound ktest)
+ (let-fresh () (unbound)
(build-cps-term
- ($letconst (('unbound unbound (pointer->scm (make-pointer unbound-bits))))
- ($letk ((ktest ($kif kt kf)))
- ($continue ktest src
- ($primcall 'eq? (sym unbound))))))))
+ ($letconst (('unbound unbound
+ (pointer->scm (make-pointer unbound-bits))))
+ ($continue kf src
+ ($branch kt ($primcall 'eq? (var unbound))))))))
(define (init-default-value name sym subst init body)
- (match (assq-ref subst sym)
- ((subst-sym box?)
+ (match (hashq-ref subst sym)
+ ((orig-var subst-var box?)
(let ((src (tree-il-src init)))
(define (maybe-box k make-body)
(if box?
- (let-gensyms (kbox phi)
+ (let-fresh (kbox) (phi)
(build-cps-term
($letk ((kbox ($kargs (name) (phi)
($continue k src ($primcall 'box (phi))))))
,(make-body kbox))))
(make-body k)))
- (let-gensyms (knext kbound kunbound)
+ (let-fresh (knext kbound kunbound kreceive krest) (val rest)
(build-cps-term
- ($letk ((knext ($kargs (name) (subst-sym) ,body)))
+ ($letk ((knext ($kargs (name) (subst-var) ,body)))
,(maybe-box
knext
(lambda (k)
(build-cps-term
($letk ((kbound ($kargs () () ($continue k src
- ($values (sym)))))
- (kunbound ($kargs () () ,(convert init k subst))))
- ,(unbound? src sym kunbound kbound))))))))))))
+ ($values (orig-var)))))
+ (krest ($kargs (name 'rest) (val rest)
+ ($continue k src ($values (val)))))
+ (kreceive ($kreceive (list name) 'rest krest))
+ (kunbound ($kargs () ()
+ ,(convert init kreceive subst))))
+ ,(unbound? src orig-var kunbound kbound))))))))))))
;; exp k-name alist -> term
(define (convert exp k subst)
(define (convert-arg exp k)
(match exp
(($ <lexical-ref> src name sym)
- (match (assq-ref subst sym)
- ((box #t)
- (let-gensyms (kunboxed unboxed)
+ (match (hashq-ref subst sym)
+ ((orig-var box #t)
+ (let-fresh (kunboxed) (unboxed)
(build-cps-term
($letk ((kunboxed ($kargs ('unboxed) (unboxed) ,(k unboxed))))
($continue kunboxed src ($primcall 'box-ref (box)))))))
- ((subst #f) (k subst))
- (#f (k sym))))
+ ((orig-var subst-var #f) (k subst-var))
+ (var (k var))))
(else
- (let-gensyms (karg arg)
+ (let-fresh (kreceive karg) (arg rest)
(build-cps-term
- ($letk ((karg ($kargs ('arg) (arg) ,(k arg))))
- ,(convert exp karg subst)))))))
+ ($letk ((karg ($kargs ('arg 'rest) (arg rest) ,(k arg)))
+ (kreceive ($kreceive '(arg) 'rest karg)))
+ ,(convert exp kreceive subst)))))))
;; (exp ...) ((v-name ...) -> term) -> term
(define (convert-args exps k)
(match exps
(lambda (names)
(k (cons name names)))))))))
(define (box-bound-var name sym body)
- (match (assq-ref subst sym)
- ((box #t)
- (let-gensyms (k)
+ (match (hashq-ref subst sym)
+ ((orig-var subst-var #t)
+ (let-fresh (k) ()
(build-cps-term
- ($letk ((k ($kargs (name) (box) ,body)))
- ($continue k #f ($primcall 'box (sym)))))))
+ ($letk ((k ($kargs (name) (subst-var) ,body)))
+ ($continue k #f ($primcall 'box (orig-var)))))))
(else body)))
+ (define (bound-var sym)
+ (match (hashq-ref subst sym)
+ ((var . _) var)
+ ((? exact-integer? var) var)))
(match exp
(($ <lexical-ref> src name sym)
- (match (assq-ref subst sym)
- ((box #t) (build-cps-term ($continue k src ($primcall 'box-ref (box)))))
- ((subst #f) (build-cps-term ($continue k src ($values (subst)))))
- (#f (build-cps-term ($continue k src ($values (sym)))))))
+ (rewrite-cps-term (hashq-ref subst sym)
+ ((orig-var box #t) ($continue k src ($primcall 'box-ref (box))))
+ ((orig-var subst-var #f) ($continue k src ($values (subst-var))))
+ (var ($continue k src ($values (var))))))
(($ <void> src)
- (build-cps-term ($continue k src ($void))))
+ (build-cps-term ($continue k src ($const *unspecified*))))
(($ <const> src exp)
(build-cps-term ($continue k src ($const exp))))
(let ()
(define (convert-clauses body ktail)
(match body
- (#f '())
+ (#f #f)
(($ <lambda-case> src req opt rest kw inits gensyms body alternate)
(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)
(cons name names))
'()
arity gensyms inits)))
- (cons
- (let-gensyms (kclause kargs)
- (build-cps-cont
- (kclause
- ($kclause ,arity
- (kargs
- ($kargs names gensyms
- ,(fold-formals
- (lambda (name sym init body)
- (if init
- (init-default-value name sym subst init body)
- (box-bound-var name sym body)))
- (convert body ktail subst)
- arity gensyms inits)))))))
- (convert-clauses alternate ktail))))))
+ (let ((bound-vars (map bound-var gensyms)))
+ (let-fresh (kclause kargs) ()
+ (build-cps-cont
+ (kclause
+ ($kclause ,arity
+ (kargs
+ ($kargs names bound-vars
+ ,(fold-formals
+ (lambda (name sym init body)
+ (if init
+ (init-default-value name sym subst init body)
+ (box-bound-var name sym body)))
+ (convert body ktail subst)
+ arity gensyms inits)))
+ ,(convert-clauses alternate ktail))))))))))
(if (current-topbox-scope)
- (let-gensyms (kentry self ktail)
+ (let-fresh (kfun ktail) (self)
(build-cps-term
($continue k fun-src
- ($fun fun-src meta '()
- (kentry ($kentry self (ktail ($ktail))
- ,(convert-clauses body ktail)))))))
- (let-gensyms (scope kscope)
- (build-cps-term
- ($letk ((kscope ($kargs () ()
- ,(parameterize ((current-topbox-scope scope))
- (convert exp k subst)))))
- ,(capture-toplevel-scope fun-src scope kscope)))))))
+ ($fun '()
+ (kfun ($kfun fun-src meta self (ktail ($ktail))
+ ,(convert-clauses body ktail)))))))
+ (let ((scope-id (fresh-scope-id)))
+ (let-fresh (kscope) ()
+ (build-cps-term
+ ($letk ((kscope
+ ($kargs () ()
+ ,(parameterize ((current-topbox-scope scope-id))
+ (convert exp k subst)))))
+ ,(capture-toplevel-scope fun-src scope-id kscope))))))))
(($ <module-ref> src mod name public?)
(module-box
(($ <toplevel-define> src name exp)
(convert-arg exp
(lambda (val)
- (let-gensyms (kname name-sym)
+ (let-fresh (kname) (name-sym)
(build-cps-term
($letconst (('name name-sym name))
($continue k src ($primcall 'define! (name-sym val)))))))))
(($ <primcall> src name args)
(cond
((branching-primitive? name)
- (convert (make-conditional src exp (make-const #f #t)
- (make-const #f #f))
- k subst))
- ((and (eq? name 'vector)
- (and-map (match-lambda
- ((or ($ <const>)
- ($ <void>)
- ($ <lambda>)
- ($ <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-gensyms (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))
+ (convert-args args
+ (lambda (args)
+ (let-fresh (kt kf) ()
+ (build-cps-term
+ ($letk ((kt ($kargs () () ($continue k src ($const #t))))
+ (kf ($kargs () () ($continue k src ($const #f)))))
+ ($continue kf src
+ ($branch kt ($primcall name args)))))))))
+ ((and (eq? name 'not) (match args ((_) #t) (_ #f)))
+ (convert-args args
+ (lambda (args)
+ (let-fresh (kt kf) ()
+ (build-cps-term
+ ($letk ((kt ($kargs () () ($continue k src ($const #f))))
+ (kf ($kargs () () ($continue k src ($const #t)))))
+ ($continue kf src
+ ($branch kt ($values args)))))))))
((and (eq? name 'list)
(and-map (match-lambda
((or ($ <const>)
($ <lexical-ref>)) #t)
(_ #f))
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))
(match args
(()
(build-cps-term
($continue k src ($const '()))))
((arg . args)
- (let-gensyms (ktail tail)
+ (let-fresh (ktail) (tail)
(build-cps-term
($letk ((ktail ($kargs ('tail) (tail)
,(convert-arg arg
;; Otherwise we do a no-inline call to body, continuing to krest.
(convert-arg tag
(lambda (tag)
- (let ((hnames (append hreq (if hrest (list hrest) '()))))
- (let-gensyms (khargs khbody kret kprim prim kpop krest vals kbody)
+ (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)
(build-cps-term
- ;; FIXME: Attach hsrc to $ktrunc.
- ($letk* ((khbody ($kargs hnames hsyms
+ ;; FIXME: Attach hsrc to $kreceive.
+ ($letk* ((khbody ($kargs hnames bound-vars
,(fold box-bound-var
(convert hbody k subst)
hnames hsyms)))
- (khargs ($ktrunc hreq hrest khbody))
+ (khargs ($kreceive hreq hrest khbody))
(kpop ($kargs ('rest) (vals)
($letk ((kret
($kargs () ()
($prim 'values))))))
($continue kret src
($primcall 'unwind ())))))
- (krest ($ktrunc '() 'rest kpop)))
+ (krest ($kreceive '() 'rest kpop)))
,(if escape-only?
(build-cps-term
($letk ((kbody ($kargs () ()
,(convert body krest subst))))
- ($continue kbody src ($prompt #t tag khargs kpop))))
+ ($continue kbody src ($prompt #t tag khargs))))
(convert-arg body
(lambda (thunk)
(build-cps-term
($primcall 'call-thunk/no-inline
(thunk))))))
($continue kbody (tree-il-src body)
- ($prompt #f tag khargs kpop))))))))))))))
-
- ;; Eta-convert prompts without inline handlers.
- (($ <prompt> src escape-only? tag body handler)
- (let-gensyms (h args)
- (convert
- (make-let
- src (list 'h) (list h) (list handler)
- (make-seq
- src
- (make-conditional
- src
- (make-primcall src 'procedure? (list (make-lexical-ref #f 'h h)))
- (make-void src)
- (make-primcall
- src 'scm-error
- (list
- (make-const #f 'wrong-type-arg)
- (make-const #f "call-with-prompt")
- (make-const #f "Wrong type (expecting procedure): ~S")
- (make-primcall #f 'list (list (make-lexical-ref #f 'h h)))
- (make-primcall #f 'list (list (make-lexical-ref #f 'h h))))))
- (make-prompt
- src escape-only? tag body
- (make-lambda
- src '()
- (make-lambda-case
- src '() #f 'args #f '() (list args)
- (make-primcall
- src 'apply
- (list (make-lexical-ref #f 'h h)
- (make-lexical-ref #f 'args args)))
- #f)))))
- k
- subst)))
+ ($prompt #f tag khargs))))))))))))))
(($ <abort> src tag args ($ <const> _ ()))
(convert-args (cons tag args)
($continue k src ($primcall 'apply args*))))))
(($ <conditional> src test consequent alternate)
- (let-gensyms (kif kt kf)
+ (let-fresh (kt kf) ()
(build-cps-term
($letk* ((kt ($kargs () () ,(convert consequent k subst)))
- (kf ($kargs () () ,(convert alternate k subst)))
- (kif ($kif kt kf)))
+ (kf ($kargs () () ,(convert alternate k subst))))
,(match test
(($ <primcall> src (? branching-primitive? name) args)
(convert-args args
(lambda (args)
(build-cps-term
- ($continue kif src ($primcall name args))))))
+ ($continue kf src
+ ($branch kt ($primcall name args)))))))
(_ (convert-arg test
(lambda (test)
(build-cps-term
- ($continue kif src ($values (test))))))))))))
+ ($continue kf src
+ ($branch kt ($values (test)))))))))))))
(($ <lexical-set> src name gensym exp)
(convert-arg exp
(lambda (exp)
- (match (assq-ref subst gensym)
- ((box #t)
+ (match (hashq-ref subst gensym)
+ ((orig-var box #t)
(build-cps-term
($continue k src ($primcall 'box-set! (box exp)))))))))
(($ <seq> src head tail)
- (let-gensyms (ktrunc kseq)
+ (let-fresh (kreceive kseq) (vals)
(build-cps-term
- ($letk* ((kseq ($kargs () ()
+ ($letk* ((kseq ($kargs ('vals) (vals)
,(convert tail k subst)))
- (ktrunc ($ktrunc '() #f kseq)))
- ,(convert head ktrunc subst)))))
+ (kreceive ($kreceive '() 'vals kseq)))
+ ,(convert head kreceive subst)))))
(($ <let> src names syms vals body)
(let lp ((names names) (syms syms) (vals vals))
(match (list names syms vals)
((() () ()) (convert body k subst))
(((name . names) (sym . syms) (val . vals))
- (let-gensyms (klet)
+ (let-fresh (kreceive klet) (rest)
(build-cps-term
- ($letk ((klet ($kargs (name) (sym)
- ,(box-bound-var name sym
- (lp names syms vals)))))
- ,(convert val klet subst))))))))
+ ($letk* ((klet ($kargs (name 'rest) ((bound-var sym) rest)
+ ,(box-bound-var name sym
+ (lp names syms vals))))
+ (kreceive ($kreceive (list name) 'rest klet)))
+ ,(convert val kreceive subst))))))))
(($ <fix> src names gensyms funs body)
;; Some letrecs can be contified; that happens later.
(if (current-topbox-scope)
- (let-gensyms (self)
+ (let-fresh () (self)
(build-cps-term
($letrec names
- gensyms
+ (map bound-var gensyms)
(map (lambda (fun)
(match (convert fun k subst)
(($ $continue _ _ (and fun ($ $fun)))
fun)))
funs)
,(convert body k subst))))
- (let-gensyms (scope kscope)
- (build-cps-term
- ($letk ((kscope ($kargs () ()
- ,(parameterize ((current-topbox-scope scope))
- (convert exp k subst)))))
- ,(capture-toplevel-scope src scope kscope))))))
+ (let ((scope-id (fresh-scope-id)))
+ (let-fresh (kscope) ()
+ (build-cps-term
+ ($letk ((kscope
+ ($kargs () ()
+ ,(parameterize ((current-topbox-scope scope-id))
+ (convert exp k subst)))))
+ ,(capture-toplevel-scope src scope-id kscope)))))))
(($ <let-values> src exp
($ <lambda-case> lsrc req #f rest #f () syms body #f))
- (let ((names (append req (if rest (list rest) '()))))
- (let-gensyms (ktrunc kargs)
+ (let ((names (append req (if rest (list rest) '())))
+ (bound-vars (map bound-var syms)))
+ (let-fresh (kreceive kargs) ()
(build-cps-term
- ($letk* ((kargs ($kargs names syms
+ ($letk* ((kargs ($kargs names bound-vars
,(fold box-bound-var
(convert body k subst)
names syms)))
- (ktrunc ($ktrunc req rest kargs)))
- ,(convert exp ktrunc subst))))))))
+ (kreceive ($kreceive req rest kargs)))
+ ,(convert exp kreceive subst))))))))
(define (build-subst exp)
- "Compute a mapping from lexical gensyms to substituted gensyms. The
-usual reason to replace one variable by another is assignment
-conversion. Default argument values is the other reason.
-
-Returns a list of (ORIG-SYM SUBST-SYM BOXED?). A true value for BOXED?
-indicates that the replacement variable is in a box."
- (define (box-set-vars exp subst)
- (match exp
- (($ <lexical-set> src name sym exp)
- (if (assq sym subst)
- subst
- (cons (list sym (gensym "b") #t) subst)))
- (_ subst)))
- (define (default-args exp subst)
- (match exp
- (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
- (fold-formals (lambda (name sym init subst)
- (if init
- (let ((box? (match (assq-ref subst sym)
- ((box #t) #t)
- (#f #f)))
- (subst-sym (gensym (symbol->string name))))
- (cons (list sym subst-sym box?) subst))
- subst))
- subst
- (make-$arity req (or opt '()) rest
- (if kw (cdr kw) '()) (and kw (car kw)))
- gensyms
- inits))
- (_ subst)))
- (tree-il-fold box-set-vars default-args '() exp))
+ "Compute a mapping from lexical gensyms to CPS variable indexes. CPS
+uses small integers to identify variables, instead of gensyms.
+
+This subst table serves an additional purpose of mapping variables to
+replacements. The usual reason to replace one variable by another is
+assignment conversion. Default argument values is the other reason.
+
+The result is a hash table mapping symbols to substitutions (in the case
+that a variable is substituted) or to indexes. A substitution is a list
+of the form:
+
+ (ORIG-INDEX SUBST-INDEX BOXED?)
+
+A true value for BOXED? indicates that the replacement variable is in a
+box. If a variable is not substituted, the mapped value is a small
+integer."
+ (let ((table (make-hash-table)))
+ (define (down exp)
+ (match exp
+ (($ <lexical-set> src name sym exp)
+ (match (hashq-ref table sym)
+ ((orig subst #t) #t)
+ ((orig subst #f) (hashq-set! table sym (list orig subst #t)))
+ ((? number? idx) (hashq-set! table sym (list idx (fresh-var) #t)))))
+ (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
+ (fold-formals (lambda (name sym init seed)
+ (hashq-set! table sym
+ (if init
+ (list (fresh-var) (fresh-var) #f)
+ (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)
- (let ((src (tree-il-src exp)))
- (let-gensyms (kinit init ktail kclause kbody)
- (build-cps-exp
- ($fun src '() '()
- (kinit ($kentry init
- (ktail ($ktail))
- ((kclause
- ($kclause ('() '() #f '() #f)
- (kbody ($kargs () ()
- ,(convert exp ktail
- (build-subst exp))))))))))))))
+ (parameterize ((label-counter 0)
+ (var-counter 0)
+ (scope-counter 0))
+ (let ((src (tree-il-src exp)))
+ (let-fresh (kinit ktail kclause kbody) (init)
+ (build-cps-cont
+ (kinit ($kfun src '() init (ktail ($ktail))
+ (kclause
+ ($kclause ('() '() #f '() #f)
+ (kbody ($kargs () ()
+ ,(convert exp ktail
+ (build-subst exp))))
+ ,#f)))))))))
(define *comp-module* (make-fluid))
(optimize x e opts))
+(define (canonicalize exp)
+ (post-order
+ (lambda (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))))))
+
+ (($ <primcall> src 'struct-set! (struct index value))
+ ;; Unhappily, and undocumentedly, struct-set! returns the value
+ ;; that was set. There is code that relies on this. Hackety
+ ;; hack...
+ (let ((v (gensym "v ")))
+ (make-let src
+ (list 'v)
+ (list v)
+ (list value)
+ (make-seq src
+ (make-primcall src 'struct-set!
+ (list struct
+ index
+ (make-lexical-ref src 'v v)))
+ (make-lexical-ref src 'v v)))))
+
+ (($ <prompt> src escape-only? tag body
+ ($ <lambda> hsrc hmeta
+ ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
+ exp)
+
+ ;; Eta-convert prompts without inline handlers.
+ (($ <prompt> src escape-only? tag body handler)
+ (let ((h (gensym "h "))
+ (args (gensym "args ")))
+ (make-let
+ src (list 'h) (list h) (list handler)
+ (make-seq
+ src
+ (make-conditional
+ src
+ (make-primcall src 'procedure? (list (make-lexical-ref #f 'h h)))
+ (make-void src)
+ (make-primcall
+ src 'scm-error
+ (list
+ (make-const #f 'wrong-type-arg)
+ (make-const #f "call-with-prompt")
+ (make-const #f "Wrong type (expecting procedure): ~S")
+ (make-primcall #f 'list (list (make-lexical-ref #f 'h h)))
+ (make-primcall #f 'list (list (make-lexical-ref #f 'h h))))))
+ (make-prompt
+ src escape-only? tag body
+ (make-lambda
+ src '()
+ (make-lambda-case
+ src '() #f 'args #f '() (list args)
+ (make-primcall
+ src 'apply
+ (list (make-lexical-ref #f 'h h)
+ (make-lexical-ref #f 'args args)))
+ #f)))))))
+ (_ exp)))
+ exp))
+
(define (compile-cps exp env opts)
- (values (cps-convert/thunk (optimize-tree-il exp env opts))
+ (values (cps-convert/thunk
+ (canonicalize (optimize-tree-il exp env opts)))
env
env))
HCoop / bpt / guile.git / blobdiff