1 ;;; Continuation-passing style (CPS) intermediate language (IL)
3 ;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
5 ;;;; This library is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU Lesser General Public
7 ;;;; License as published by the Free Software Foundation; either
8 ;;;; version 3 of the License, or (at your option) any later version.
10 ;;;; This library is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;;; Lesser General Public License for more details.
15 ;;;; You should have received a copy of the GNU Lesser General Public
16 ;;;; License along with this library; if not, write to the Free Software
17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
21 ;;; This pass converts Tree-IL to the continuation-passing style (CPS)
24 ;;; CPS is a lower-level representation than Tree-IL. Converting to
25 ;;; CPS, beyond adding names for all control points and all values,
26 ;;; simplifies expressions in the following ways, among others:
28 ;;; * Fixing the order of evaluation.
30 ;;; * Converting assigned variables to boxed variables.
32 ;;; * Requiring that Scheme's <letrec> has already been lowered to
35 ;;; * Inlining default-value initializers into lambda-case
38 ;;; * Inlining prompt bodies.
40 ;;; * Turning toplevel and module references into primcalls. This
41 ;;; involves explicitly modelling the "scope" of toplevel lookups
42 ;;; (indicating the module with respect to which toplevel bindings
45 ;;; The utility of CPS is that it gives a name to everything: every
46 ;;; intermediate value, and every control point (continuation). As such
47 ;;; it is more verbose than Tree-IL, but at the same time more simple as
48 ;;; the number of concepts is reduced.
52 (define-module (language tree-il compile-cps)
53 #:use-module (ice-9 match)
54 #:use-module ((srfi srfi-1) #:select (fold fold-right filter-map))
55 #:use-module (srfi srfi-26)
56 #:use-module ((system foreign) #:select (make-pointer pointer->scm))
57 #:use-module (language cps)
58 #:use-module (language cps primitives)
59 #:use-module (language tree-il analyze)
60 #:use-module (language tree-il optimize)
61 #:use-module ((language tree-il) #:hide (let-gensyms))
62 #:export (compile-cps))
64 ;;; Guile's semantics are that a toplevel lambda captures a reference on
65 ;;; the current module, and that all contained lambdas use that module
66 ;;; to resolve toplevel variables. This parameter tracks whether or not
67 ;;; we are in a toplevel lambda. If we are in a lambda, the parameter
68 ;;; is bound to a fresh name identifying the module that was current
69 ;;; when the toplevel lambda is defined.
71 ;;; This is more complicated than it need be. Ideally we should resolve
72 ;;; all toplevel bindings to bindings from specific modules, unless the
73 ;;; binding is unbound. This is always valid if the compilation unit
74 ;;; sets the module explicitly, as when compiling a module, but it
75 ;;; doesn't work for files auto-compiled for use with `load'.
77 (define current-topbox-scope (make-parameter #f))
79 (define (toplevel-box src name bound? val-proc)
80 (let-gensyms (name-sym bound?-sym kbox box)
82 ($letconst (('name name-sym name)
83 ('bound? bound?-sym bound?))
84 ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
85 ,(match (current-topbox-scope)
90 (name-sym bound?-sym)))))
92 (let-gensyms (scope-sym)
94 ($letconst (('scope scope-sym scope))
96 ($primcall 'cached-toplevel-box
97 (scope-sym name-sym bound?-sym)))))))))))))
99 (define (module-box src module name public? bound? val-proc)
100 (let-gensyms (module-sym name-sym public?-sym bound?-sym kbox box)
102 ($letconst (('module module-sym module)
103 ('name name-sym name)
104 ('public? public?-sym public?)
105 ('bound? bound?-sym bound?))
106 ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
108 ($primcall 'cached-module-box
109 (module-sym name-sym public?-sym bound?-sym))))))))
111 (define (capture-toplevel-scope src scope k)
112 (let-gensyms (module scope-sym kmodule)
114 ($letconst (('scope scope-sym scope))
115 ($letk ((kmodule ($kargs ('module) (module)
117 ($primcall 'cache-current-module!
118 (module scope-sym))))))
119 ($continue kmodule src
120 ($primcall 'current-module ())))))))
122 (define (fold-formals proc seed arity gensyms inits)
124 (($ $arity req opt rest kw allow-other-keys?)
126 (define (fold-req names gensyms seed)
128 (() (fold-opt opt gensyms inits seed))
130 (proc name (car gensyms) #f
131 (fold-req names (cdr gensyms) seed)))))
132 (define (fold-opt names gensyms inits seed)
134 (() (fold-rest rest gensyms inits seed))
136 (proc name (car gensyms) (car inits)
137 (fold-opt names (cdr gensyms) (cdr inits) seed)))))
138 (define (fold-rest rest gensyms inits seed)
140 (#f (fold-kw kw gensyms inits seed))
141 (name (proc name (car gensyms) #f
142 (fold-kw kw (cdr gensyms) inits seed)))))
143 (define (fold-kw kw gensyms inits seed)
146 (unless (null? gensyms)
147 (error "too many gensyms"))
148 (unless (null? inits)
149 (error "too many inits"))
151 (((key name var) . kw)
152 (unless (eq? var (car gensyms))
153 (error "unexpected keyword arg order"))
154 (proc name var (car inits)
155 (fold-kw kw (cdr gensyms) (cdr inits) seed)))))
156 (fold-req req gensyms seed)))))
158 (define (unbound? src sym kt kf)
160 (define unbound-val 9)
161 (define unbound-bits (logior (ash unbound-val 8) tc8-iflag))
162 (let-gensyms (unbound ktest)
164 ($letconst (('unbound unbound (pointer->scm (make-pointer unbound-bits))))
165 ($letk ((ktest ($kif kt kf)))
167 ($primcall 'eq? (sym unbound))))))))
169 (define (init-default-value name sym subst init body)
170 (match (assq-ref subst sym)
172 (let ((src (tree-il-src init)))
173 (define (maybe-box k make-body)
175 (let-gensyms (kbox phi)
177 ($letk ((kbox ($kargs (name) (phi)
178 ($continue k src ($primcall 'box (phi))))))
181 (let-gensyms (knext kbound kunbound kreceive krest val rest)
183 ($letk ((knext ($kargs (name) (subst-sym) ,body)))
188 ($letk ((kbound ($kargs () () ($continue k src
190 (krest ($kargs (name 'rest) (val rest)
191 ($continue k src ($values (val)))))
192 (kreceive ($kreceive (list name) 'rest krest))
193 (kunbound ($kargs () ()
194 ,(convert init kreceive subst))))
195 ,(unbound? src sym kunbound kbound))))))))))))
197 ;; exp k-name alist -> term
198 (define (convert exp k subst)
199 ;; exp (v-name -> term) -> term
200 (define (convert-arg exp k)
202 (($ <lexical-ref> src name sym)
203 (match (assq-ref subst sym)
205 (let-gensyms (kunboxed unboxed)
207 ($letk ((kunboxed ($kargs ('unboxed) (unboxed) ,(k unboxed))))
208 ($continue kunboxed src ($primcall 'box-ref (box)))))))
209 ((subst #f) (k subst))
212 (let-gensyms (kreceive karg arg rest)
214 ($letk ((karg ($kargs ('arg 'rest) (arg rest) ,(k arg)))
215 (kreceive ($kreceive '(arg) 'rest karg)))
216 ,(convert exp kreceive subst)))))))
217 ;; (exp ...) ((v-name ...) -> term) -> term
218 (define (convert-args exps k)
226 (k (cons name names)))))))))
227 (define (box-bound-var name sym body)
228 (match (assq-ref subst sym)
232 ($letk ((k ($kargs (name) (box) ,body)))
233 ($continue k #f ($primcall 'box (sym)))))))
237 (($ <lexical-ref> src name sym)
238 (match (assq-ref subst sym)
239 ((box #t) (build-cps-term ($continue k src ($primcall 'box-ref (box)))))
240 ((subst #f) (build-cps-term ($continue k src ($values (subst)))))
241 (#f (build-cps-term ($continue k src ($values (sym)))))))
244 (build-cps-term ($continue k src ($void))))
247 (build-cps-term ($continue k src ($const exp))))
249 (($ <primitive-ref> src name)
250 (build-cps-term ($continue k src ($prim name))))
252 (($ <lambda> fun-src meta body)
254 (define (convert-clauses body ktail)
257 (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
258 (let* ((arity (make-$arity req (or opt '()) rest
259 (if kw (cdr kw) '()) (and kw (car kw))))
260 (names (fold-formals (lambda (name sym init names)
263 arity gensyms inits)))
265 (let-gensyms (kclause kargs)
270 ($kargs names gensyms
272 (lambda (name sym init body)
274 (init-default-value name sym subst init body)
275 (box-bound-var name sym body)))
276 (convert body ktail subst)
277 arity gensyms inits)))))))
278 (convert-clauses alternate ktail))))))
279 (if (current-topbox-scope)
280 (let-gensyms (kentry self ktail)
283 ($fun fun-src meta '()
284 (kentry ($kentry self (ktail ($ktail))
285 ,(convert-clauses body ktail)))))))
286 (let-gensyms (scope kscope)
288 ($letk ((kscope ($kargs () ()
289 ,(parameterize ((current-topbox-scope scope))
290 (convert exp k subst)))))
291 ,(capture-toplevel-scope fun-src scope kscope)))))))
293 (($ <module-ref> src mod name public?)
295 src mod name public? #t
297 (build-cps-term ($continue k src ($primcall 'box-ref (box)))))))
299 (($ <module-set> src mod name public? exp)
303 src mod name public? #f
306 ($continue k src ($primcall 'box-set! (box val)))))))))
308 (($ <toplevel-ref> src name)
312 (build-cps-term ($continue k src ($primcall 'box-ref (box)))))))
314 (($ <toplevel-set> src name exp)
321 ($continue k src ($primcall 'box-set! (box val)))))))))
323 (($ <toplevel-define> src name exp)
326 (let-gensyms (kname name-sym)
328 ($letconst (('name name-sym name))
329 ($continue k src ($primcall 'define! (name-sym val)))))))))
331 (($ <call> src proc args)
332 (convert-args (cons proc args)
335 (build-cps-term ($continue k src ($call proc args)))))))
337 (($ <primcall> src name args)
339 ((branching-primitive? name)
340 (convert (make-conditional src exp (make-const #f #t)
343 ((and (eq? name 'vector)
344 (and-map (match-lambda
348 ($ <lexical-ref>)) #t)
351 ;; Some macros generate calls to "vector" with like 300
352 ;; arguments. Since we eventually compile to make-vector and
353 ;; vector-set!, it reduces live variable pressure to allocate the
354 ;; vector first, then set values as they are produced, if we can
355 ;; prove that no value can capture the continuation. (More on
357 ;; http://wingolog.org/archives/2013/11/02/scheme-quiz-time).
359 ;; Normally we would do this transformation in the compiler, but
360 ;; it's quite tricky there and quite easy here, so hold your nose
361 ;; while we drop some smelly code.
362 (convert (let ((len (length args)))
367 (list (make-primcall src 'make-vector
368 (list (make-const #f len)
369 (make-const #f #f))))
370 (fold (lambda (arg n tail)
375 (list (make-lexical-ref src 'v v)
379 (make-lexical-ref src 'v v)
380 (reverse args) (reverse (iota len))))))
382 ((and (eq? name 'list)
383 (and-map (match-lambda
387 ($ <lexical-ref>)) #t)
390 ;; The same situation occurs with "list".
391 (let lp ((args args) (k k))
395 ($continue k src ($const '()))))
397 (let-gensyms (ktail tail)
399 ($letk ((ktail ($kargs ('tail) (tail)
404 ($primcall 'cons (head tail)))))))))
405 ,(lp args ktail))))))))
409 (build-cps-term ($continue k src ($primcall name args))))))))
411 ;; Prompts with inline handlers.
412 (($ <prompt> src escape-only? tag body
413 ($ <lambda> hsrc hmeta
414 ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
416 ;; khargs: check args returned to handler, -> khbody
417 ;; khbody: the handler, -> k
420 ;; krest: collect return vals from body to list, -> kpop
421 ;; kpop: pop the prompt, -> kprim
422 ;; kprim: load the values primitive, -> kret
423 ;; kret: (apply values rvals), -> k
425 ;; Escape prompts evaluate the body with the continuation of krest.
426 ;; Otherwise we do a no-inline call to body, continuing to krest.
429 (let ((hnames (append hreq (if hrest (list hrest) '()))))
430 (let-gensyms (khargs khbody kret kprim prim kpop krest vals kbody)
432 ;; FIXME: Attach hsrc to $kreceive.
433 ($letk* ((khbody ($kargs hnames hsyms
435 (convert hbody k subst)
437 (khargs ($kreceive hreq hrest khbody))
438 (kpop ($kargs ('rest) (vals)
442 ($kargs ('prim) (prim)
449 ($primcall 'unwind ())))))
450 (krest ($kreceive '() 'rest kpop)))
453 ($letk ((kbody ($kargs () ()
454 ,(convert body krest subst))))
455 ($continue kbody src ($prompt #t tag khargs))))
459 ($letk ((kbody ($kargs () ()
460 ($continue krest (tree-il-src body)
461 ($primcall 'call-thunk/no-inline
463 ($continue kbody (tree-il-src body)
464 ($prompt #f tag khargs))))))))))))))
466 ;; Eta-convert prompts without inline handlers.
467 (($ <prompt> src escape-only? tag body handler)
468 (let-gensyms (h args)
471 src (list 'h) (list h) (list handler)
476 (make-primcall src 'procedure? (list (make-lexical-ref #f 'h h)))
481 (make-const #f 'wrong-type-arg)
482 (make-const #f "call-with-prompt")
483 (make-const #f "Wrong type (expecting procedure): ~S")
484 (make-primcall #f 'list (list (make-lexical-ref #f 'h h)))
485 (make-primcall #f 'list (list (make-lexical-ref #f 'h h))))))
487 src escape-only? tag body
491 src '() #f 'args #f '() (list args)
494 (list (make-lexical-ref #f 'h h)
495 (make-lexical-ref #f 'args args)))
500 (($ <abort> src tag args ($ <const> _ ()))
501 (convert-args (cons tag args)
505 ($primcall 'abort-to-prompt args*))))))
507 (($ <abort> src tag args tail)
508 (convert-args (append (list (make-primitive-ref #f 'abort-to-prompt)
514 ($continue k src ($primcall 'apply args*))))))
516 (($ <conditional> src test consequent alternate)
517 (let-gensyms (kif kt kf)
519 ($letk* ((kt ($kargs () () ,(convert consequent k subst)))
520 (kf ($kargs () () ,(convert alternate k subst)))
523 (($ <primcall> src (? branching-primitive? name) args)
527 ($continue kif src ($primcall name args))))))
531 ($continue kif src ($values (test))))))))))))
533 (($ <lexical-set> src name gensym exp)
536 (match (assq-ref subst gensym)
539 ($continue k src ($primcall 'box-set! (box exp)))))))))
541 (($ <seq> src head tail)
542 (let-gensyms (kreceive kseq vals)
544 ($letk* ((kseq ($kargs ('vals) (vals)
545 ,(convert tail k subst)))
546 (kreceive ($kreceive '() 'vals kseq)))
547 ,(convert head kreceive subst)))))
549 (($ <let> src names syms vals body)
550 (let lp ((names names) (syms syms) (vals vals))
551 (match (list names syms vals)
552 ((() () ()) (convert body k subst))
553 (((name . names) (sym . syms) (val . vals))
554 (let-gensyms (kreceive klet rest)
556 ($letk* ((klet ($kargs (name 'rest) (sym rest)
557 ,(box-bound-var name sym
558 (lp names syms vals))))
559 (kreceive ($kreceive (list name) 'rest klet)))
560 ,(convert val kreceive subst))))))))
562 (($ <fix> src names gensyms funs body)
563 ;; Some letrecs can be contified; that happens later.
564 (if (current-topbox-scope)
570 (match (convert fun k subst)
571 (($ $continue _ _ (and fun ($ $fun)))
574 ,(convert body k subst))))
575 (let-gensyms (scope kscope)
577 ($letk ((kscope ($kargs () ()
578 ,(parameterize ((current-topbox-scope scope))
579 (convert exp k subst)))))
580 ,(capture-toplevel-scope src scope kscope))))))
582 (($ <let-values> src exp
583 ($ <lambda-case> lsrc req #f rest #f () syms body #f))
584 (let ((names (append req (if rest (list rest) '()))))
585 (let-gensyms (kreceive kargs)
587 ($letk* ((kargs ($kargs names syms
589 (convert body k subst)
591 (kreceive ($kreceive req rest kargs)))
592 ,(convert exp kreceive subst))))))))
594 (define (build-subst exp)
595 "Compute a mapping from lexical gensyms to substituted gensyms. The
596 usual reason to replace one variable by another is assignment
597 conversion. Default argument values is the other reason.
599 Returns a list of (ORIG-SYM SUBST-SYM BOXED?). A true value for BOXED?
600 indicates that the replacement variable is in a box."
601 (define (box-set-vars exp subst)
603 (($ <lexical-set> src name sym exp)
606 (cons (list sym (gensym "b") #t) subst)))
608 (define (default-args exp subst)
610 (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
611 (fold-formals (lambda (name sym init subst)
613 (let ((box? (match (assq-ref subst sym)
616 (subst-sym (gensym (symbol->string name))))
617 (cons (list sym subst-sym box?) subst))
620 (make-$arity req (or opt '()) rest
621 (if kw (cdr kw) '()) (and kw (car kw)))
625 (tree-il-fold box-set-vars default-args '() exp))
627 (define (cps-convert/thunk exp)
628 (let ((src (tree-il-src exp)))
629 (let-gensyms (kinit init ktail kclause kbody)
635 ($kclause ('() '() #f '() #f)
638 (build-subst exp))))))))))))))
640 (define *comp-module* (make-fluid))
642 (define %warning-passes
643 `((unused-variable . ,unused-variable-analysis)
644 (unused-toplevel . ,unused-toplevel-analysis)
645 (unbound-variable . ,unbound-variable-analysis)
646 (arity-mismatch . ,arity-analysis)
647 (format . ,format-analysis)))
649 (define (optimize-tree-il x e opts)
651 (or (and=> (memq #:warnings opts) cadr)
654 ;; Go through the warning passes.
655 (let ((analyses (filter-map (lambda (kind)
656 (assoc-ref %warning-passes kind))
658 (analyze-tree analyses x e))
662 (define (compile-cps exp env opts)
663 (values (cps-convert/thunk (optimize-tree-il exp env opts))
668 ;;; eval: (put 'convert-arg 'scheme-indent-function 1)
669 ;;; eval: (put 'convert-args 'scheme-indent-function 1)