1 ;;; Tree-IL partial evaluator
3 ;; Copyright (C) 2011 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
19 (define-module (language tree-il peval)
20 #:use-module (language tree-il)
21 #:use-module (language tree-il primitives)
22 #:use-module (ice-9 vlist)
23 #:use-module (ice-9 match)
24 #:use-module (srfi srfi-1)
25 #:use-module (srfi srfi-9)
26 #:use-module (srfi srfi-11)
27 #:use-module (srfi srfi-26)
31 ;;; Partial evaluation is Guile's most important source-to-source
32 ;;; optimization pass. It performs copy propagation, dead code
33 ;;; elimination, inlining, and constant folding, all while preserving
34 ;;; the order of effects in the residual program.
36 ;;; For more on partial evaluation, see William Cook’s excellent
37 ;;; tutorial on partial evaluation at DSL 2011, called “Build your own
38 ;;; partial evaluator in 90 minutes”[0].
40 ;;; Our implementation of this algorithm was heavily influenced by
41 ;;; Waddell and Dybvig's paper, "Fast and Effective Procedure Inlining",
42 ;;; IU CS Dept. TR 484.
44 ;;; [0] http://www.cs.utexas.edu/~wcook/tutorial/.
47 ;; First, some helpers.
49 (define-syntax *logging* (identifier-syntax #f))
51 ;; For efficiency we define *logging* to inline to #f, so that the call
52 ;; to log* gets optimized out. If you want to log, uncomment these
55 ;; (define %logging #f)
56 ;; (define-syntax *logging* (identifier-syntax %logging))
58 ;; Then you can change %logging at runtime.
64 (or (eq? *logging* #t)
65 (memq 'event *logging*)))
66 (log* 'event arg ...)))))
68 (define (log* event . args)
69 (let ((pp (module-ref (resolve-interface '(ice-9 pretty-print))
71 (pp `(log ,event . ,args))
75 (define-syntax-rule (let/ec k e e* ...)
76 (let ((tag (make-prompt-tag)))
80 (let ((k (lambda args (apply abort-to-prompt tag args))))
82 (lambda (_ res) res))))
84 (define (tree-il-any proc exp)
86 (tree-il-fold (lambda (exp res)
87 (let ((res (proc exp)))
90 (let ((res (proc exp)))
95 (define (vlist-any proc vlist)
96 (let ((len (vlist-length vlist)))
99 (or (proc (vlist-ref vlist i))
102 ;; Peval will do a one-pass analysis on the source program to determine
103 ;; the set of assigned lexicals, and to identify unreferenced and
104 ;; singly-referenced lexicals.
106 ;; If peval introduces more code, via copy-propagation, it will need to
107 ;; run `build-var-table' on the new code to add to make sure it can find
108 ;; a <var> for each gensym bound in the program.
110 (define-record-type <var>
111 (make-var name gensym refcount set?)
115 (refcount var-refcount set-var-refcount!)
116 (set? var-set? set-var-set?!))
118 (define* (build-var-table exp #:optional (table vlist-null))
122 (($ <lexical-ref> src name gensym)
123 (let ((var (vhash-assq gensym res)))
126 (set-var-refcount! (cdr var) (1+ (var-refcount (cdr var))))
128 (vhash-consq gensym (make-var name gensym 1 #f) res))))
132 (($ <lexical-set> src name gensym exp)
133 (let ((var (vhash-assq gensym res)))
136 (set-var-set?! (cdr var) #t)
138 (vhash-consq gensym (make-var name gensym 0 #t) res))))
140 (lambda (exp res) res)
143 ;; Counters are data structures used to limit the effort that peval
144 ;; spends on particular inlining attempts. Each call site in the source
145 ;; program is allocated some amount of effort. If peval exceeds the
146 ;; effort counter while attempting to inline a call site, it aborts the
147 ;; inlining attempt and residualizes a call instead.
149 ;; As there is a fixed number of call sites, that makes `peval' O(N) in
150 ;; the number of call sites in the source program.
152 ;; Counters should limit the size of the residual program as well, but
153 ;; currently this is not implemented.
155 ;; At the top level, before seeing any peval call, there is no counter,
156 ;; because inlining will terminate as there is no recursion. When peval
157 ;; sees a call at the top level, it will make a new counter, allocating
158 ;; it some amount of effort and size.
160 ;; This top-level effort counter effectively "prints money". Within a
161 ;; toplevel counter, no more effort is printed ex nihilo; for a nested
162 ;; inlining attempt to proceed, effort must be transferred from the
163 ;; toplevel counter to the nested counter.
165 ;; Via `data' and `prev', counters form a linked list, terminating in a
166 ;; toplevel counter. In practice `data' will be the a pointer to the
167 ;; source expression of the procedure being inlined.
169 ;; In this way peval can detect a recursive inlining attempt, by walking
170 ;; back on the `prev' links looking for matching `data'. Recursive
171 ;; counters receive a more limited effort allocation, as we don't want
172 ;; to spend all of the effort for a toplevel inlining site on loops.
173 ;; Also, recursive counters don't need a prompt at each inlining site:
174 ;; either the call chain folds entirely, or it will be residualized at
175 ;; its original call.
177 (define-record-type <counter>
178 (%make-counter effort size continuation recursive? data prev)
180 (effort effort-counter)
182 (continuation counter-continuation)
183 (recursive? counter-recursive?)
187 (define (abort-counter c)
188 ((counter-continuation c)))
190 (define (record-effort! c)
191 (let ((e (effort-counter c)))
192 (if (zero? (variable-ref e))
194 (variable-set! e (1- (variable-ref e))))))
196 (define (record-size! c)
197 (let ((s (size-counter c)))
198 (if (zero? (variable-ref s))
200 (variable-set! s (1- (variable-ref s))))))
202 (define (find-counter data counter)
204 (if (eq? data (counter-data counter))
206 (find-counter data (counter-prev counter)))))
208 (define* (transfer! from to #:optional
209 (effort (variable-ref (effort-counter from)))
210 (size (variable-ref (size-counter from))))
211 (define (transfer-counter! from-v to-v amount)
212 (let* ((from-balance (variable-ref from-v))
213 (to-balance (variable-ref to-v))
214 (amount (min amount from-balance)))
215 (variable-set! from-v (- from-balance amount))
216 (variable-set! to-v (+ to-balance amount))))
218 (transfer-counter! (effort-counter from) (effort-counter to) effort)
219 (transfer-counter! (size-counter from) (size-counter to) size))
221 (define (make-top-counter effort-limit size-limit continuation data)
222 (%make-counter (make-variable effort-limit)
223 (make-variable size-limit)
229 (define (make-nested-counter continuation data current)
230 (let ((c (%make-counter (make-variable 0)
236 (transfer! current c)
239 (define (make-recursive-counter effort-limit size-limit orig current)
240 (let ((c (%make-counter (make-variable 0)
242 (counter-continuation orig)
246 (transfer! current c effort-limit size-limit)
249 ;; Operand structures allow bindings to be processed lazily instead of
250 ;; eagerly. By doing so, hopefully we can get process them in a way
251 ;; appropriate to their use contexts. Operands also prevent values from
252 ;; being visited multiple times, wasting effort.
254 (define-record-type <operand>
255 (%make-operand var sym visit source visit-count residualize?
256 copyable? residual-value constant-value)
260 (visit %operand-visit)
261 (source operand-source)
262 (visit-count operand-visit-count set-operand-visit-count!)
263 (residualize? operand-residualize? set-operand-residualize?!)
264 (copyable? operand-copyable? set-operand-copyable?!)
265 (residual-value operand-residual-value set-operand-residual-value!)
266 (constant-value operand-constant-value set-operand-constant-value!))
268 (define* (make-operand var sym #:optional source visit)
269 ;; Bound operands are considered copyable until we prove otherwise.
270 (%make-operand var sym visit source 0 #f (and source #t) #f #f))
272 (define (make-bound-operands vars syms sources visit)
273 (map (lambda (x y z) (make-operand x y z visit)) vars syms sources))
275 (define (make-unbound-operands vars syms)
276 (map make-operand vars syms))
278 (define* (visit-operand op counter ctx #:optional effort-limit size-limit)
279 ;; Peval is O(N) in call sites of the source program. However,
280 ;; visiting an operand can introduce new call sites. If we visit an
281 ;; operand outside a counter -- i.e., outside an inlining attempt --
282 ;; this can lead to divergence. So, if we are visiting an operand to
283 ;; try to copy it, and there is no counter, make a new one.
285 ;; This will only happen at most as many times as there are lexical
286 ;; references in the source program.
287 (and (zero? (operand-visit-count op))
290 (set-operand-visit-count! op (1+ (operand-visit-count op))))
292 (and (operand-source op)
293 (if (or counter (and (not effort-limit) (not size-limit)))
294 ((%operand-visit op) (operand-source op) counter ctx)
296 (define (abort) (k #f))
299 (make-top-counter effort-limit size-limit abort op)
302 (set-operand-visit-count! op (1- (operand-visit-count op)))))))
304 ;; A helper for constant folding.
306 (define (types-check? primitive-name args)
309 ((not pair? null? list? symbol? vector? struct?)
313 ;; FIXME: add more cases?
316 (define (fresh-gensyms syms)
317 (map (lambda (x) (gensym (string-append (symbol->string x) " ")))
320 ;; Copy propagation of terms that bind variables, like `lambda' terms,
321 ;; will need to bind fresh variables. This procedure renames all the
322 ;; lexicals in a term.
324 (define (alpha-rename exp)
325 "Alpha-rename EXP. For any lambda in EXP, generate new symbols and
326 replace all lexical references to the former symbols with lexical
327 references to the new symbols."
328 ;; XXX: This should be factorized somehow.
330 (mapping vlist-null)) ; maps old to new gensyms
332 (($ <lambda-case> src req opt rest kw inits gensyms body alt)
333 ;; Create new symbols to replace GENSYMS and propagate them down
335 (let* ((new (fresh-gensyms
338 (if rest (list rest) '())
340 ((aok? (_ name _) ...) name)
342 (mapping (fold vhash-consq mapping gensyms new)))
343 (make-lambda-case src req opt rest
345 ((aok? (kw name old) ...)
349 (take-right new (length old)))))
351 (map (cut loop <> mapping) inits)
354 (and alt (loop alt mapping)))))
355 (($ <lexical-ref> src name gensym)
356 ;; Possibly replace GENSYM by the new gensym defined in MAPPING.
357 (let ((val (vhash-assq gensym mapping)))
359 (make-lexical-ref src name (cdr val))
361 (($ <lexical-set> src name gensym exp)
362 (let ((val (vhash-assq gensym mapping)))
363 (make-lexical-set src name (if val (cdr val) gensym)
364 (loop exp mapping))))
365 (($ <lambda> src meta body)
366 (make-lambda src meta (loop body mapping)))
367 (($ <let> src names gensyms vals body)
368 ;; As for `lambda-case' rename GENSYMS to avoid any collision.
369 (let* ((new (fresh-gensyms names))
370 (mapping (fold vhash-consq mapping gensyms new))
371 (vals (map (cut loop <> mapping) vals))
372 (body (loop body mapping)))
373 (make-let src names new vals body)))
374 (($ <letrec> src in-order? names gensyms vals body)
376 (let* ((new (fresh-gensyms names))
377 (mapping (fold vhash-consq mapping gensyms new))
378 (vals (map (cut loop <> mapping) vals))
379 (body (loop body mapping)))
380 (make-letrec src in-order? names new vals body)))
381 (($ <fix> src names gensyms vals body)
383 (let* ((new (fresh-gensyms names))
384 (mapping (fold vhash-consq mapping gensyms new))
385 (vals (map (cut loop <> mapping) vals))
386 (body (loop body mapping)))
387 (make-fix src names new vals body)))
388 (($ <let-values> src exp body)
389 (make-let-values src (loop exp mapping) (loop body mapping)))
400 (($ <toplevel-set> src name exp)
401 (make-toplevel-set src name (loop exp mapping)))
402 (($ <toplevel-define> src name exp)
403 (make-toplevel-define src name (loop exp mapping)))
404 (($ <module-set> src mod name public? exp)
405 (make-module-set src mod name public? (loop exp mapping)))
406 (($ <dynlet> src fluids vals body)
408 (map (cut loop <> mapping) fluids)
409 (map (cut loop <> mapping) vals)
410 (loop body mapping)))
411 (($ <dynwind> src winder body unwinder)
413 (loop winder mapping)
415 (loop unwinder mapping)))
416 (($ <dynref> src fluid)
417 (make-dynref src (loop fluid mapping)))
418 (($ <dynset> src fluid exp)
419 (make-dynset src (loop fluid mapping) (loop exp mapping)))
420 (($ <conditional> src condition subsequent alternate)
421 (make-conditional src
422 (loop condition mapping)
423 (loop subsequent mapping)
424 (loop alternate mapping)))
425 (($ <application> src proc args)
426 (make-application src (loop proc mapping)
427 (map (cut loop <> mapping) args)))
428 (($ <sequence> src exps)
429 (make-sequence src (map (cut loop <> mapping) exps)))
430 (($ <prompt> src tag body handler)
431 (make-prompt src (loop tag mapping) (loop body mapping)
432 (loop handler mapping)))
433 (($ <abort> src tag args tail)
434 (make-abort src (loop tag mapping) (map (cut loop <> mapping) args)
435 (loop tail mapping))))))
437 (define* (peval exp #:optional (cenv (current-module)) (env vlist-null)
439 (operator-size-limit 40)
440 (operand-size-limit 20)
441 (value-size-limit 10)
443 (recursive-effort-limit 100))
444 "Partially evaluate EXP in compilation environment CENV, with
445 top-level bindings from ENV and return the resulting expression."
447 ;; This is a simple partial evaluator. It effectively performs
448 ;; constant folding, copy propagation, dead code elimination, and
453 ;; Propagate copies across toplevel bindings, if we can prove the
454 ;; bindings to be immutable.
456 ;; Specialize lambda expressions with invariant arguments.
458 (define local-toplevel-env
459 ;; The top-level environment of the module being compiled.
461 (($ <toplevel-define> _ name)
462 (vhash-consq name #t env))
463 (($ <sequence> _ exps)
466 (($ <toplevel-define> _ name)
467 (vhash-consq name #t r))
473 (define (local-toplevel? name)
474 (vhash-assq name local-toplevel-env))
477 ;; renamed-term -> original-term
479 (define store (build-var-table exp))
481 (define (assigned-lexical? sym)
482 (let ((v (vhash-assq sym store)))
483 (and v (var-set? (cdr v)))))
485 (define (lexical-refcount sym)
486 (let ((v (vhash-assq sym store)))
487 (if v (var-refcount (cdr v)) 0)))
489 ;; ORIG has been alpha-renamed to NEW. Analyze NEW and record a link
492 (define (record-source-expression! orig new)
493 (set! store (vhash-consq new
494 (source-expression orig)
495 (build-var-table new store)))
498 ;; Find the source expression corresponding to NEW. Used to detect
499 ;; recursive inlining attempts.
501 (define (source-expression new)
502 (let ((x (vhash-assq new store)))
505 (define residual-lexical-references (make-hash-table))
507 (define (record-residual-lexical-reference! sym)
508 (hashq-set! residual-lexical-references sym #t))
510 (define (apply-primitive name args)
511 ;; todo: further optimize commutative primitives
516 (apply (module-ref the-scm-module name) args))
518 (values #t results))))
522 (define (inline-values exp src names gensyms body)
523 (let loop ((exp exp))
525 ;; Some expression types are always singly-valued.
534 ($ <lexical-set>) ; FIXME: these set! expressions
535 ($ <toplevel-set>) ; could return zero values in
536 ($ <toplevel-define>) ; the future
539 (and (= (length names) 1)
540 (make-let src names gensyms (list exp) body)))
541 (($ <application> src
542 ($ <primitive-ref> _ (? singly-valued-primitive? name)))
543 (and (= (length names) 1)
544 (make-let src names gensyms (list exp) body)))
546 ;; Statically-known number of values.
547 (($ <application> src ($ <primitive-ref> _ 'values) vals)
548 (and (= (length names) (length vals))
549 (make-let src names gensyms vals body)))
551 ;; Not going to copy code into both branches.
552 (($ <conditional>) #f)
554 ;; Bail on other applications.
555 (($ <application>) #f)
557 ;; Bail on prompt and abort.
561 ;; Propagate to tail positions.
562 (($ <let> src names gensyms vals body)
563 (let ((body (loop body)))
565 (make-let src names gensyms vals body))))
566 (($ <letrec> src in-order? names gensyms vals body)
567 (let ((body (loop body)))
569 (make-letrec src in-order? names gensyms vals body))))
570 (($ <fix> src names gensyms vals body)
571 (let ((body (loop body)))
573 (make-fix src names gensyms vals body))))
574 (($ <let-values> src exp
575 ($ <lambda-case> src2 req opt rest kw inits gensyms body #f))
576 (let ((body (loop body)))
578 (make-let-values src exp
579 (make-lambda-case src2 req opt rest kw
580 inits gensyms body #f)))))
581 (($ <dynwind> src winder body unwinder)
582 (let ((body (loop body)))
584 (make-dynwind src winder body unwinder))))
585 (($ <dynlet> src fluids vals body)
586 (let ((body (loop body)))
588 (make-dynlet src fluids vals body))))
589 (($ <sequence> src exps)
592 (let ((tail (loop tail)))
594 (make-sequence src (append head (list tail)))))))))))
596 (define (make-values src values)
598 ((single) single) ; 1 value
599 ((_ ...) ; 0, or 2 or more values
600 (make-application src (make-primitive-ref src 'values)
603 (define (constant-expression? x)
604 ;; Return true if X is constant---i.e., if it is known to have no
605 ;; effects, does not allocate storage for a mutable object, and does
606 ;; not access mutable data (like `car' or toplevel references).
612 (($ <lambda-case> _ req opt rest kw inits _ body alternate)
613 (and (every loop inits) (loop body)
614 (or (not alternate) (loop alternate))))
615 (($ <lexical-ref> _ _ gensym)
616 (not (assigned-lexical? gensym)))
617 (($ <primitive-ref>) #t)
618 (($ <conditional> _ condition subsequent alternate)
619 (and (loop condition) (loop subsequent) (loop alternate)))
620 (($ <application> _ ($ <primitive-ref> _ name) args)
621 (and (effect-free-primitive? name)
622 (not (constructor-primitive? name))
623 (types-check? name args)
625 (($ <application> _ ($ <lambda> _ _ body) args)
626 (and (loop body) (every loop args)))
627 (($ <sequence> _ exps)
629 (($ <let> _ _ _ vals body)
630 (and (every loop vals) (loop body)))
631 (($ <letrec> _ _ _ _ vals body)
632 (and (every loop vals) (loop body)))
633 (($ <fix> _ _ _ vals body)
634 (and (every loop vals) (loop body)))
635 (($ <let-values> _ exp body)
636 (and (loop exp) (loop body)))
637 (($ <prompt> _ tag body handler)
638 (and (loop tag) (loop body) (loop handler)))
641 (define (prune-bindings names syms vals body for-effect
643 (let lp ((names names) (syms syms) (vals vals)
644 (names* '()) (syms* '()) (vals* '())
646 (match (list names syms vals)
648 (let ((body (if (null? effects)
650 (make-sequence #f (reverse (cons body effects))))))
653 (build-result (reverse names*) (reverse syms*)
654 (reverse vals*) body))))
655 (((name . names) (sym . syms) (val . vals))
656 (if (hashq-ref residual-lexical-references sym)
658 (cons name names*) (cons sym syms*) (cons val vals*)
660 (let ((effect (for-effect val)))
667 (cons effect effects)))))))))
669 (define (small-expression? x limit)
672 (lambda (x res) ; leaf
674 (lambda (x res) ; down
684 (env vlist-null) ; static environment
685 (counter #f) ; inlined call stack
686 (ctx 'value)) ; effect, value, test, operator, or operand
688 (and=> (vhash-assq var env) cdr))
690 (define (visit exp ctx)
691 (loop exp env counter ctx))
693 (define (for-value exp) (visit exp 'value))
694 (define (for-operand exp) (visit exp 'operand))
695 (define (for-test exp) (visit exp 'test))
696 (define (for-effect exp) (visit exp 'effect))
697 (define (for-tail exp) (visit exp ctx))
700 (record-effort! counter))
702 (log 'visit ctx (and=> counter effort-counter)
703 (unparse-tree-il exp))
708 ((effect) (make-void #f))
712 ((test) (make-const #f #t))
714 (($ <lexical-ref> _ _ gensym)
716 ((effect) (make-void #f))
718 (log 'begin-copy gensym)
719 (let ((val (lookup gensym)))
722 (assigned-lexical? gensym)
723 (not (constant-expression? val)))
724 ;; Don't copy-propagate through assigned variables,
725 ;; and don't reorder effects.
726 (log 'unbound-or-not-constant gensym val)
727 (record-residual-lexical-reference! gensym)
733 (primitive-ref? val))
734 ;; Always propagate simple values that cannot lead to
736 (log 'copy-simple gensym val)
738 ((= 1 (lexical-refcount gensym))
739 ;; Always propagate values referenced only once.
740 ;; There is no need to rename the bindings, as they
741 ;; are only being moved, not copied. However in
742 ;; operator context we do rename it, as that
743 ;; effectively clears out the residualized-lexical
744 ;; flags that may have been set when this value was
745 ;; visited previously as an operand.
746 (log 'copy-single gensym val)
748 ((test) (for-test val))
749 ((operator) (record-source-expression! val (alpha-rename val)))
751 ;; FIXME: do demand-driven size accounting rather than
754 ;; A pure expression in the operator position. Inline
755 ;; if it's a lambda that's small enough.
756 (if (and (lambda? val)
757 (small-expression? val operator-size-limit))
759 (log 'copy-operator gensym val)
760 (record-source-expression! val (alpha-rename val)))
762 (log 'too-big-for-operator gensym val)
763 (record-residual-lexical-reference! gensym)
766 ;; A pure expression in the operand position. Inline
767 ;; if it's small enough.
768 (if (small-expression? val operand-size-limit)
770 (log 'copy-operand gensym val)
771 (record-source-expression! val (alpha-rename val)))
773 (log 'too-big-for-operand gensym val)
774 (record-residual-lexical-reference! gensym)
777 ;; A pure expression, processed for value. Don't
778 ;; inline lambdas, because they will probably won't
779 ;; fold because we don't know the operator.
780 (if (and (small-expression? val value-size-limit)
781 (not (tree-il-any lambda? val)))
783 (log 'copy-value gensym val)
784 (record-source-expression! val (alpha-rename val)))
786 (log 'too-big-or-has-lambda gensym val)
787 (record-residual-lexical-reference! gensym)
789 (($ <lexical-set> src name gensym exp)
790 (if (zero? (lexical-refcount gensym))
791 (let ((exp (for-effect exp)))
794 (make-sequence src (list exp (make-void #f)))))
796 (record-residual-lexical-reference! gensym)
797 (make-lexical-set src name gensym (for-value exp)))))
798 (($ <let> src names gensyms vals body)
799 (let* ((vals (map for-operand vals))
801 (fold vhash-consq env gensyms vals)
806 (for-tail (make-sequence src (append vals (list body)))))
807 ((and (lexical-ref? body)
808 (memq (lexical-ref-gensym body) gensyms))
809 (let ((sym (lexical-ref-gensym body))
810 (pairs (map cons gensyms vals)))
811 ;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo)
815 (append (map cdr (alist-delete sym pairs eq?))
816 (list (assq-ref pairs sym)))))))
818 ;; Only include bindings for which lexical references
819 ;; have been residualized.
820 (prune-bindings names gensyms vals body for-effect
821 (lambda (names gensyms vals body)
822 (if (null? names) (error "what!" names))
823 (make-let src names gensyms vals body)))))))
824 (($ <letrec> src in-order? names gensyms vals body)
825 ;; Things could be done more precisely when IN-ORDER? but
826 ;; it's OK not to do it---at worst we lost an optimization
828 (let* ((vals (map for-operand vals))
830 (fold vhash-consq env gensyms vals)
833 (if (and (const? body)
834 (every constant-expression? vals))
836 (prune-bindings names gensyms vals body for-effect
837 (lambda (names gensyms vals body)
838 (make-letrec src in-order?
839 names gensyms vals body))))))
840 (($ <fix> src names gensyms vals body)
841 (let* ((vals (map for-operand vals))
843 (fold vhash-consq env gensyms vals)
848 (prune-bindings names gensyms vals body for-effect
849 (lambda (names gensyms vals body)
850 (make-fix src names gensyms vals body))))))
851 (($ <let-values> lv-src producer consumer)
852 ;; Peval the producer, then try to inline the consumer into
853 ;; the producer. If that succeeds, peval again. Otherwise
854 ;; reconstruct the let-values, pevaling the consumer.
855 (let ((producer (for-value producer)))
857 (($ <lambda-case> src req #f #f #f () gensyms body #f)
859 ((inline-values producer src req gensyms body)
863 (make-let-values lv-src producer (for-tail consumer)))))
864 (($ <dynwind> src winder body unwinder)
865 (make-dynwind src (for-value winder) (for-tail body)
866 (for-value unwinder)))
867 (($ <dynlet> src fluids vals body)
868 (make-dynlet src (map for-value fluids) (map for-value vals)
870 (($ <dynref> src fluid)
871 (make-dynref src (for-value fluid)))
872 (($ <dynset> src fluid exp)
873 (make-dynset src (for-value fluid) (for-value exp)))
874 (($ <toplevel-ref> src (? effect-free-primitive? name))
875 (if (local-toplevel? name)
877 (resolve-primitives! exp cenv)))
879 ;; todo: open private local bindings.
881 (($ <module-ref> src module (? effect-free-primitive? name) #f)
882 (let ((module (false-if-exception
883 (resolve-module module #:ensure #f))))
885 (let ((var (module-variable module name)))
886 (if (eq? var (module-variable the-scm-module name))
887 (make-primitive-ref src name)
892 (($ <module-set> src mod name public? exp)
893 (make-module-set src mod name public? (for-value exp)))
894 (($ <toplevel-define> src name exp)
895 (make-toplevel-define src name (for-value exp)))
896 (($ <toplevel-set> src name exp)
897 (make-toplevel-set src name (for-value exp)))
900 ((effect) (make-void #f))
901 ((test) (make-const #f #t))
903 (($ <conditional> src condition subsequent alternate)
904 (let ((condition (for-test condition)))
905 (if (const? condition)
906 (if (const-exp condition)
907 (for-tail subsequent)
908 (for-tail alternate))
909 (make-conditional src condition
910 (for-tail subsequent)
911 (for-tail alternate)))))
912 (($ <application> src
913 ($ <primitive-ref> _ '@call-with-values)
917 ;; No optional or kwargs.
919 _ req #f rest #f () gensyms body #f)))))
920 (for-tail (make-let-values src (make-application src producer '())
923 (($ <application> src orig-proc orig-args)
924 ;; todo: augment the global env with specialized functions
925 (let ((proc (loop orig-proc env counter 'operator)))
927 (($ <primitive-ref> _ (? constructor-primitive? name))
930 (let ((res (if (eq? ctx 'effect)
932 (make-const #f #t))))
933 (match (for-value exp)
934 (($ <application> _ ($ <primitive-ref> _ 'cons) (x xs))
936 (make-sequence src (list x xs res))))
937 (($ <application> _ ($ <primitive-ref> _ 'list) elts)
939 (make-sequence src (append elts (list res)))))
940 (($ <application> _ ($ <primitive-ref> _ 'vector) elts)
942 (make-sequence src (append elts (list res)))))
943 (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) ())
945 (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag)
946 (($ <const> _ (? string?))))
950 (match (cons name (map for-value orig-args))
954 (make-application src (make-primitive-ref #f 'list)
956 (($ <application> src ($ <primitive-ref> _ 'list) elts)
957 (make-application src (make-primitive-ref #f 'list)
959 (_ (make-application src proc
962 ;; FIXME: these for-tail recursions could take
963 ;; place outside an effort counter.
964 (('car ($ <application> src ($ <primitive-ref> _ 'cons) (head tail)))
965 (for-tail (make-sequence src (list tail head))))
966 (('cdr ($ <application> src ($ <primitive-ref> _ 'cons) (head tail)))
967 (for-tail (make-sequence src (list head tail))))
968 (('car ($ <application> src ($ <primitive-ref> _ 'list) (head . tail)))
969 (for-tail (make-sequence src (append tail (list head)))))
970 (('cdr ($ <application> src ($ <primitive-ref> _ 'list) (head . tail)))
971 (for-tail (make-sequence
975 src (make-primitive-ref #f 'list) tail)))))
977 (('car ($ <const> src (head . tail)))
978 (for-tail (make-const src head)))
979 (('cdr ($ <const> src (head . tail)))
980 (for-tail (make-const src tail)))
983 (make-application src proc args))))))
984 (($ <primitive-ref> _ (? effect-free-primitive? name))
985 (let ((args (map for-value orig-args)))
986 (if (every const? args) ; only simple constants
987 (let-values (((success? values)
988 (apply-primitive name
989 (map const-exp args))))
990 (log 'fold success? values exp)
993 ((effect) (make-void #f))
995 ;; Values truncation: only take the first
998 (make-const #f (car values))
999 (make-values src '())))
1001 (make-values src (map (cut make-const src <>)
1003 (make-application src proc args)))
1005 ((and (eq? ctx 'effect) (types-check? name args))
1008 (make-application src proc args))))))
1010 ($ <lambda-case> _ req opt #f #f inits gensyms body #f))
1011 ;; Simple case: no rest, no keyword arguments.
1012 ;; todo: handle the more complex cases
1013 (let* ((nargs (length orig-args))
1015 (nopt (if opt (length opt) 0))
1016 (key (source-expression proc)))
1018 ((or (< nargs nreq) (> nargs (+ nreq nopt)))
1019 ;; An error, or effecting arguments.
1020 (make-application src (for-value orig-proc)
1021 (map for-value orig-args)))
1022 ((or (and=> (find-counter key counter) counter-recursive?)
1023 (lambda? orig-proc))
1024 ;; A recursive call, or a lambda in the operator
1025 ;; position of the source expression. Process again in
1027 (log 'inline-recurse key)
1028 (loop (make-let src (append req (or opt '()))
1031 (drop inits (- nargs nreq)))
1035 ;; An integration at the top-level, the first
1036 ;; recursion of a recursive procedure, or a nested
1037 ;; integration of a procedure that hasn't been seen
1039 (log 'inline-begin exp)
1042 (log 'inline-abort exp)
1043 (k (make-application src
1044 (for-value orig-proc)
1045 (map for-value orig-args))))
1048 ;; These first two cases will transfer effort
1049 ;; from the current counter into the new
1051 ((find-counter key counter)
1053 (make-recursive-counter recursive-effort-limit
1057 (make-nested-counter abort key counter))
1058 ;; This case opens a new account, effectively
1059 ;; printing money. It should only do so once
1060 ;; for each call site in the source program.
1062 (make-top-counter effort-limit operand-size-limit
1065 (loop (make-let src (append req (or opt '()))
1068 (drop inits (- nargs nreq)))
1070 env new-counter ctx))
1073 ;; The nested inlining attempt succeeded.
1074 ;; Deposit the unspent effort and size back
1075 ;; into the current counter.
1076 (transfer! new-counter counter))
1078 (log 'inline-end result exp)
1081 (make-application src proc
1082 (map for-value orig-args))))))
1083 (($ <lambda> src meta body)
1085 ((effect) (make-void #f))
1086 ((test) (make-const #f #t))
1089 (make-lambda src meta (for-value body)))))
1090 (($ <lambda-case> src req opt rest kw inits gensyms body alt)
1091 (make-lambda-case src req opt rest kw
1092 (map for-value inits)
1095 (and alt (for-tail alt))))
1096 (($ <sequence> src exps)
1097 (let lp ((exps exps) (effects '()))
1104 (reverse (cons (for-tail last) effects)))))
1106 (let ((head (for-effect head)))
1109 (lp (append (sequence-exps head) rest) effects))
1113 (lp rest (cons head effects)))))))))
1114 (($ <prompt> src tag body handler)
1115 (define (singly-used-definition x)
1117 ((and (lexical-ref? x)
1118 ;; Only fetch definitions with single uses.
1119 (= (lexical-refcount (lexical-ref-gensym x)) 1)
1120 (lookup (lexical-ref-gensym x)))
1121 => singly-used-definition)
1123 (match (singly-used-definition tag)
1124 (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag)
1125 (or () ((? constant-expression?))))
1126 ;; There is no way that an <abort> could know the tag
1127 ;; for this <prompt>, so we can elide the <prompt>
1131 (make-prompt src (for-value tag) (for-tail body)
1132 (for-value handler)))))
1133 (($ <abort> src tag args tail)
1134 (make-abort src (for-value tag) (map for-value args)
1135 (for-value tail))))))