1 ;;; Continuation-passing style (CPS) intermediate language (IL)
3 ;; Copyright (C) 2013 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 src ($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 src ($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 src ($kargs ('module) (module)
117 ($primcall 'cache-current-module!
118 (module scope-sym))))))
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 src ($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 src ($kargs (name) (phi)
178 ($continue k ($primcall 'box (phi))))))
181 (let-gensyms (knext kbound kunbound)
183 ($letk ((knext src ($kargs (name) (subst-sym) ,body)))
188 ($letk ((kbound src ($kargs () () ($continue k ($var sym))))
189 (kunbound src ($kargs () () ,(convert init k subst))))
190 ,(unbound? src sym kunbound kbound))))))))))))
192 ;; exp k-name alist -> term
193 (define (convert exp k subst)
194 ;; exp (v-name -> term) -> term
195 (define (convert-arg exp k)
197 (($ <lexical-ref> src name sym)
198 (match (assq-ref subst sym)
200 (let-gensyms (kunboxed unboxed)
202 ($letk ((kunboxed src ($kargs ('unboxed) (unboxed) ,(k unboxed))))
203 ($continue kunboxed ($primcall 'box-ref (box)))))))
204 ((subst #f) (k subst))
207 (let ((src (tree-il-src exp)))
208 (let-gensyms (karg arg)
210 ($letk ((karg src ($kargs ('arg) (arg) ,(k arg))))
211 ,(convert exp karg subst))))))))
212 ;; (exp ...) ((v-name ...) -> term) -> term
213 (define (convert-args exps k)
221 (k (cons name names)))))))))
222 (define (box-bound-var name sym body)
223 (match (assq-ref subst sym)
227 ($letk ((k #f ($kargs (name) (box) ,body)))
228 ($continue k ($primcall 'box (sym)))))))
232 (($ <lexical-ref> src name sym)
233 (match (assq-ref subst sym)
234 ((box #t) (build-cps-term ($continue k ($primcall 'box-ref (box)))))
235 ((subst #f) (build-cps-term ($continue k ($var subst))))
236 (#f (build-cps-term ($continue k ($var sym))))))
239 (build-cps-term ($continue k ($void))))
242 (build-cps-term ($continue k ($const exp))))
244 (($ <primitive-ref> src name)
245 (build-cps-term ($continue k ($prim name))))
247 (($ <lambda> fun-src meta body)
249 (define (convert-clauses body ktail)
252 (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
253 (let* ((arity (make-$arity req (or opt '()) rest
254 (if kw (cdr kw) '()) (and kw (car kw))))
255 (names (fold-formals (lambda (name sym init names)
258 arity gensyms inits)))
260 (let-gensyms (kclause kargs)
267 ($kargs names gensyms
269 (lambda (name sym init body)
271 (init-default-value name sym subst init body)
272 (box-bound-var name sym body)))
273 (convert body ktail subst)
274 arity gensyms inits)))))))
275 (convert-clauses alternate ktail))))))
276 (if (current-topbox-scope)
277 (let-gensyms (kentry self ktail)
282 ($kentry self (ktail #f ($ktail))
283 ,(convert-clauses body ktail)))))))
284 (let-gensyms (scope kscope)
286 ($letk ((kscope fun-src
288 ,(parameterize ((current-topbox-scope scope))
289 (convert exp k subst)))))
290 ,(capture-toplevel-scope fun-src scope kscope)))))))
292 (($ <module-ref> src mod name public?)
294 src mod name public? #t
296 (build-cps-term ($continue k ($primcall 'box-ref (box)))))))
298 (($ <module-set> src mod name public? exp)
302 src mod name public? #f
304 (build-cps-term ($continue k ($primcall 'box-set! (box val)))))))))
306 (($ <toplevel-ref> src name)
310 (build-cps-term ($continue k ($primcall 'box-ref (box)))))))
312 (($ <toplevel-set> src name exp)
318 (build-cps-term ($continue k ($primcall 'box-set! (box val)))))))))
320 (($ <toplevel-define> src name exp)
323 (let-gensyms (kname name-sym)
325 ($letconst (('name name-sym name))
326 ($continue k ($primcall 'define! (name-sym val)))))))))
328 (($ <call> src proc args)
329 (convert-args (cons proc args)
332 (build-cps-term ($continue k ($call proc args)))))))
334 (($ <primcall> src name args)
337 (convert (fold-right (lambda (elem tail)
338 (make-primcall src 'cons
344 (if (branching-primitive? name)
345 (convert (make-conditional src exp (make-const #f #t)
350 (if (eq? name 'values)
351 (build-cps-term ($continue k ($values args)))
352 (build-cps-term ($continue k ($primcall name args))))))))))
354 ;; Prompts with inline handlers.
355 (($ <prompt> src escape-only? tag body
356 ($ <lambda> hsrc hmeta
357 ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
359 ;; khargs: check args returned to handler, -> khbody
360 ;; khbody: the handler, -> k
363 ;; krest: collect return vals from body to list, -> kpop
364 ;; kpop: pop the prompt, -> kprim
365 ;; kprim: load the values primitive, -> kret
366 ;; kret: (apply values rvals), -> k
368 ;; Escape prompts evaluate the body with the continuation of krest.
369 ;; Otherwise we do a no-inline call to body, continuing to krest.
372 (let ((hnames (append hreq (if hrest (list hrest) '()))))
373 (let-gensyms (khargs khbody kret kprim prim kpop krest vals kbody)
375 ($letk* ((khbody hsrc ($kargs hnames hsyms
377 (convert hbody k subst)
379 (khargs hsrc ($ktrunc hreq hrest khbody))
381 ($kargs ('rest) (vals)
387 ($kargs ('prim) (prim)
394 ($primcall 'pop-prompt ())))))
395 (krest src ($ktrunc '() 'rest kpop)))
398 ($letk ((kbody (tree-il-src body)
400 ,(convert body krest subst))))
401 ($continue kbody ($prompt #t tag khargs))))
405 ($letk ((kbody (tree-il-src body)
408 ($primcall 'call-thunk/no-inline
411 ($prompt #f tag khargs))))))))))))))
413 ;; Eta-convert prompts without inline handlers.
414 (($ <prompt> src escape-only? tag body handler)
415 (let-gensyms (h args)
418 src (list 'h) (list h) (list handler)
423 (make-primcall src 'procedure? (list (make-lexical-ref #f 'h h)))
428 (make-const #f 'wrong-type-arg)
429 (make-const #f "call-with-prompt")
430 (make-const #f "Wrong type (expecting procedure): ~S")
431 (make-primcall #f 'list (list (make-lexical-ref #f 'h h)))
432 (make-primcall #f 'list (list (make-lexical-ref #f 'h h))))))
434 src escape-only? tag body
438 src '() #f 'args #f '() (list args)
441 (list (make-lexical-ref #f 'h h)
442 (make-lexical-ref #f 'args args)))
447 (($ <abort> src tag args tail)
448 (convert-args (append (list tag) args (list tail))
450 (build-cps-term ($continue k ($primcall 'abort args*))))))
452 (($ <conditional> src test consequent alternate)
453 (let-gensyms (kif kt kf)
455 ($letk* ((kt (tree-il-src consequent) ($kargs () ()
456 ,(convert consequent k subst)))
457 (kf (tree-il-src alternate) ($kargs () ()
458 ,(convert alternate k subst)))
459 (kif src ($kif kt kf)))
461 (($ <primcall> src (? branching-primitive? name) args)
464 (build-cps-term ($continue kif ($primcall name args))))))
467 (build-cps-term ($continue kif ($var test)))))))))))
469 (($ <lexical-set> src name gensym exp)
472 (match (assq-ref subst gensym)
475 ($continue k ($primcall 'box-set! (box exp)))))))))
477 (($ <seq> src head tail)
478 (let-gensyms (ktrunc kseq)
480 ($letk* ((kseq (tree-il-src tail) ($kargs () ()
481 ,(convert tail k subst)))
482 (ktrunc src ($ktrunc '() #f kseq)))
483 ,(convert head ktrunc subst)))))
485 (($ <let> src names syms vals body)
486 (let lp ((names names) (syms syms) (vals vals))
487 (match (list names syms vals)
488 ((() () ()) (convert body k subst))
489 (((name . names) (sym . syms) (val . vals))
492 ($letk ((klet src ($kargs (name) (sym)
493 ,(box-bound-var name sym
494 (lp names syms vals)))))
495 ,(convert val klet subst))))))))
497 (($ <fix> src names gensyms funs body)
498 ;; Some letrecs can be contified; that happens later.
499 (if (current-topbox-scope)
505 (match (convert fun k subst)
506 (($ $continue _ (and fun ($ $fun)))
509 ,(convert body k subst))))
510 (let-gensyms (scope kscope)
512 ($letk ((kscope src ($kargs () ()
513 ,(parameterize ((current-topbox-scope scope))
514 (convert exp k subst)))))
515 ,(capture-toplevel-scope src scope kscope))))))
517 (($ <let-values> src exp
518 ($ <lambda-case> lsrc req #f rest #f () syms body #f))
519 (let ((names (append req (if rest (list rest) '()))))
520 (let-gensyms (ktrunc kargs)
522 ($letk* ((kargs src ($kargs names syms
524 (convert body k subst)
526 (ktrunc src ($ktrunc req rest kargs)))
527 ,(convert exp ktrunc subst))))))))
529 (define (build-subst exp)
530 "Compute a mapping from lexical gensyms to substituted gensyms. The
531 usual reason to replace one variable by another is assignment
532 conversion. Default argument values is the other reason.
534 Returns a list of (ORIG-SYM SUBST-SYM BOXED?). A true value for BOXED?
535 indicates that the replacement variable is in a box."
536 (define (box-set-vars exp subst)
538 (($ <lexical-set> src name sym exp)
541 (cons (list sym (gensym "b") #t) subst)))
543 (define (default-args exp subst)
545 (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
546 (fold-formals (lambda (name sym init subst)
548 (let ((box? (match (assq-ref subst sym)
551 (subst-sym (gensym (symbol->string name))))
552 (cons (list sym subst-sym box?) subst))
555 (make-$arity req (or opt '()) rest
556 (if kw (cdr kw) '()) (and kw (car kw)))
560 (tree-il-fold box-set-vars default-args '() exp))
562 (define (cps-convert/thunk exp)
563 (let ((src (tree-il-src exp)))
564 (let-gensyms (kinit init ktail kclause kbody)
571 ($kclause ('() '() #f '() #f)
575 (build-subst exp))))))))))))))
577 (define *comp-module* (make-fluid))
579 (define %warning-passes
580 `((unused-variable . ,unused-variable-analysis)
581 (unused-toplevel . ,unused-toplevel-analysis)
582 (unbound-variable . ,unbound-variable-analysis)
583 (arity-mismatch . ,arity-analysis)
584 (format . ,format-analysis)))
586 (define (optimize-tree-il x e opts)
588 (or (and=> (memq #:warnings opts) cadr)
591 ;; Go through the warning passes.
592 (let ((analyses (filter-map (lambda (kind)
593 (assoc-ref %warning-passes kind))
595 (analyze-tree analyses x e))
599 (define (compile-cps exp env opts)
600 (values (cps-convert/thunk (optimize-tree-il exp env opts))
605 ;;; eval: (put 'convert-arg 'scheme-indent-function 1)
606 ;;; eval: (put 'convert-args 'scheme-indent-function 1)