mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
e2fafeb901
* libguile/tags.h (scm_tc7_keyword): Allocate a tc7, so that the VM can
have cheap keyword? tests.
* libguile/keywords.c:
* libguile/keywords.h: Adapt.
* libguile/goops.c (scm_class_of, scm_sys_goops_early_init): Capture
<keyword>.
* libguile/print.c (iprin1): Inline keyword printer.
* libguile/evalext.c (scm_self_evaluating_p): Add keywords here.
* libguile/deprecated.h:
* libguile/deprecated.c (scm_tc16_keyword): Deprecate.
* module/language/cps/compile-bytecode.scm (compile-fun): Add keyword?
case, and bitvector? case while we're at it.
* module/language/cps/effects-analysis.scm (define-primitive-effects):
Add bytevector?, keyword?, and bitvector? cases.
* module/language/cps/primitives.scm (*branching-primcall-arities*): Add
keyword?.
* module/language/cps/types.scm (bitvector?, keyword?, bytevector?): Add
branch inferrers.
* module/language/tree-il/primitives.scm (*interesting-primitive-names*):
(*effect-free-primitives*):
(*effect+exception-free-primitives*): Add bytevector?, keyword?, and
bitvector?.
* module/oop/goops.scm (<keyword>): New class.
* module/system/base/types.scm (%tc7-keyword, cell->object): Add cases.
* module/system/vm/assembler.scm (br-if-keyword): New definition.
* module/system/vm/disassembler.scm (code-annotation): Add br-if-tc7
case for keywords.
* test-suite/tests/types.test ("clonable objects"): Update now that
keywords are cloneable.
749 lines
30 KiB
Scheme
749 lines
30 KiB
Scheme
;;; Continuation-passing style (CPS) intermediate language (IL)
|
|
|
|
;; 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
|
|
;;;; License as published by the Free Software Foundation; either
|
|
;;;; version 3 of the License, or (at your option) any later version.
|
|
;;;;
|
|
;;;; This library is distributed in the hope that it will be useful,
|
|
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;;;; Lesser General Public License for more details.
|
|
;;;;
|
|
;;;; You should have received a copy of the GNU Lesser General Public
|
|
;;;; License along with this library; if not, write to the Free Software
|
|
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
|
|
|
;;; Commentary:
|
|
;;;
|
|
;;; This pass converts Tree-IL to the continuation-passing style (CPS)
|
|
;;; language.
|
|
;;;
|
|
;;; CPS is a lower-level representation than Tree-IL. Converting to
|
|
;;; CPS, beyond adding names for all control points and all values,
|
|
;;; simplifies expressions in the following ways, among others:
|
|
;;;
|
|
;;; * Fixing the order of evaluation.
|
|
;;;
|
|
;;; * Converting assigned variables to boxed variables.
|
|
;;;
|
|
;;; * Requiring that Scheme's <letrec> has already been lowered to
|
|
;;; <fix>.
|
|
;;;
|
|
;;; * Inlining default-value initializers into lambda-case
|
|
;;; expressions.
|
|
;;;
|
|
;;; * Inlining prompt bodies.
|
|
;;;
|
|
;;; * Turning toplevel and module references into primcalls. This
|
|
;;; involves explicitly modelling the "scope" of toplevel lookups
|
|
;;; (indicating the module with respect to which toplevel bindings
|
|
;;; are resolved).
|
|
;;;
|
|
;;; The utility of CPS is that it gives a name to everything: every
|
|
;;; intermediate value, and every control point (continuation). As such
|
|
;;; it is more verbose than Tree-IL, but at the same time more simple as
|
|
;;; the number of concepts is reduced.
|
|
;;;
|
|
;;; Code:
|
|
|
|
(define-module (language tree-il compile-cps)
|
|
#:use-module (ice-9 match)
|
|
#:use-module ((srfi srfi-1) #:select (fold fold-right filter-map))
|
|
#:use-module (srfi srfi-26)
|
|
#:use-module ((system foreign) #:select (make-pointer pointer->scm))
|
|
#:use-module (language cps)
|
|
#:use-module (language cps primitives)
|
|
#:use-module (language tree-il analyze)
|
|
#:use-module (language tree-il optimize)
|
|
#:use-module (language tree-il)
|
|
#:export (compile-cps))
|
|
|
|
;;; Guile's semantics are that a toplevel lambda captures a reference on
|
|
;;; the current module, and that all contained lambdas use that module
|
|
;;; to resolve toplevel variables. This parameter tracks whether or not
|
|
;;; we are in a toplevel lambda. If we are in a lambda, the parameter
|
|
;;; is bound to a fresh name identifying the module that was current
|
|
;;; when the toplevel lambda is defined.
|
|
;;;
|
|
;;; This is more complicated than it need be. Ideally we should resolve
|
|
;;; all toplevel bindings to bindings from specific modules, unless the
|
|
;;; binding is unbound. This is always valid if the compilation unit
|
|
;;; sets the module explicitly, as when compiling a module, but it
|
|
;;; 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-fresh (kbox) (name-sym bound?-sym box)
|
|
(build-cps-term
|
|
($letconst (('name name-sym name)
|
|
('bound? bound?-sym bound?))
|
|
($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
|
|
,(match (current-topbox-scope)
|
|
(#f
|
|
(build-cps-term
|
|
($continue kbox src
|
|
($primcall 'resolve
|
|
(name-sym bound?-sym)))))
|
|
(scope-id
|
|
(let-fresh () (scope-sym)
|
|
(build-cps-term
|
|
($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-fresh (kbox) (module-sym name-sym public?-sym bound?-sym box)
|
|
(build-cps-term
|
|
($letconst (('module module-sym module)
|
|
('name name-sym name)
|
|
('public? public?-sym public?)
|
|
('bound? bound?-sym bound?))
|
|
($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
|
|
($continue kbox src
|
|
($primcall 'cached-module-box
|
|
(module-sym name-sym public?-sym bound?-sym))))))))
|
|
|
|
(define (capture-toplevel-scope src scope-id k)
|
|
(let-fresh (kmodule) (module scope-sym)
|
|
(build-cps-term
|
|
($letconst (('scope scope-sym scope-id))
|
|
($letk ((kmodule ($kargs ('module) (module)
|
|
($continue k src
|
|
($primcall 'cache-current-module!
|
|
(module scope-sym))))))
|
|
($continue kmodule src
|
|
($primcall 'current-module ())))))))
|
|
|
|
(define (fold-formals proc seed arity gensyms inits)
|
|
(match arity
|
|
(($ $arity req opt rest kw allow-other-keys?)
|
|
(let ()
|
|
(define (fold-req names gensyms seed)
|
|
(match names
|
|
(() (fold-opt opt gensyms inits seed))
|
|
((name . names)
|
|
(proc name (car gensyms) #f
|
|
(fold-req names (cdr gensyms) seed)))))
|
|
(define (fold-opt names gensyms inits seed)
|
|
(match names
|
|
(() (fold-rest rest gensyms inits seed))
|
|
((name . names)
|
|
(proc name (car gensyms) (car inits)
|
|
(fold-opt names (cdr gensyms) (cdr inits) seed)))))
|
|
(define (fold-rest rest gensyms inits seed)
|
|
(match rest
|
|
(#f (fold-kw kw gensyms inits seed))
|
|
(name (proc name (car gensyms) #f
|
|
(fold-kw kw (cdr gensyms) inits seed)))))
|
|
(define (fold-kw kw gensyms inits seed)
|
|
(match kw
|
|
(()
|
|
(unless (null? gensyms)
|
|
(error "too many gensyms"))
|
|
(unless (null? inits)
|
|
(error "too many inits"))
|
|
seed)
|
|
(((key name var) . kw)
|
|
;; 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 var kt kf)
|
|
(define tc8-iflag 4)
|
|
(define unbound-val 9)
|
|
(define unbound-bits (logior (ash unbound-val 8) tc8-iflag))
|
|
(let-fresh () (unbound)
|
|
(build-cps-term
|
|
($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 (hashq-ref subst sym)
|
|
((orig-var subst-var box?)
|
|
(let ((src (tree-il-src init)))
|
|
(define (maybe-box k make-body)
|
|
(if box?
|
|
(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-fresh (knext kbound kunbound kreceive krest) (val rest)
|
|
(build-cps-term
|
|
($letk ((knext ($kargs (name) (subst-var) ,body)))
|
|
,(maybe-box
|
|
knext
|
|
(lambda (k)
|
|
(build-cps-term
|
|
($letk ((kbound ($kargs () () ($continue k src
|
|
($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)
|
|
;; exp (v-name -> term) -> term
|
|
(define (convert-arg exp k)
|
|
(match exp
|
|
(($ <lexical-ref> src name sym)
|
|
(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)))))))
|
|
((orig-var subst-var #f) (k subst-var))
|
|
(var (k var))))
|
|
(else
|
|
(let-fresh (kreceive karg) (arg rest)
|
|
(build-cps-term
|
|
($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
|
|
(() (k '()))
|
|
((exp . exps)
|
|
(convert-arg exp
|
|
(lambda (name)
|
|
(convert-args exps
|
|
(lambda (names)
|
|
(k (cons name names)))))))))
|
|
(define (box-bound-var name sym body)
|
|
(match (hashq-ref subst sym)
|
|
((orig-var subst-var #t)
|
|
(let-fresh (k) ()
|
|
(build-cps-term
|
|
($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)
|
|
(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))))
|
|
|
|
(($ <const> src exp)
|
|
(build-cps-term ($continue k src ($const exp))))
|
|
|
|
(($ <primitive-ref> src name)
|
|
(build-cps-term ($continue k src ($prim name))))
|
|
|
|
(($ <lambda> fun-src meta body)
|
|
(let ()
|
|
(define (convert-clauses body ktail)
|
|
(match body
|
|
(#f #f)
|
|
(($ <lambda-case> src req opt rest kw inits gensyms body alternate)
|
|
(let* ((arity (make-$arity req (or opt '()) rest
|
|
(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)))
|
|
(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-fresh (kfun ktail) (self)
|
|
(build-cps-term
|
|
($continue k fun-src
|
|
($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
|
|
src mod name public? #t
|
|
(lambda (box)
|
|
(build-cps-term ($continue k src ($primcall 'box-ref (box)))))))
|
|
|
|
(($ <module-set> src mod name public? exp)
|
|
(convert-arg exp
|
|
(lambda (val)
|
|
(module-box
|
|
src mod name public? #f
|
|
(lambda (box)
|
|
(build-cps-term
|
|
($continue k src ($primcall 'box-set! (box val)))))))))
|
|
|
|
(($ <toplevel-ref> src name)
|
|
(toplevel-box
|
|
src name #t
|
|
(lambda (box)
|
|
(build-cps-term ($continue k src ($primcall 'box-ref (box)))))))
|
|
|
|
(($ <toplevel-set> src name exp)
|
|
(convert-arg exp
|
|
(lambda (val)
|
|
(toplevel-box
|
|
src name #f
|
|
(lambda (box)
|
|
(build-cps-term
|
|
($continue k src ($primcall 'box-set! (box val)))))))))
|
|
|
|
(($ <toplevel-define> src name exp)
|
|
(convert-arg exp
|
|
(lambda (val)
|
|
(let-fresh (kname) (name-sym)
|
|
(build-cps-term
|
|
($letconst (('name name-sym name))
|
|
($continue k src ($primcall 'define! (name-sym val)))))))))
|
|
|
|
(($ <call> src proc args)
|
|
(convert-args (cons proc args)
|
|
(match-lambda
|
|
((proc . args)
|
|
(build-cps-term ($continue k src ($call proc args)))))))
|
|
|
|
(($ <primcall> src name args)
|
|
(cond
|
|
((branching-primitive? name)
|
|
(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>)
|
|
($ <void>)
|
|
($ <lambda>)
|
|
($ <lexical-ref>)) #t)
|
|
(_ #f))
|
|
args))
|
|
;; 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-fresh (ktail) (tail)
|
|
(build-cps-term
|
|
($letk ((ktail ($kargs ('tail) (tail)
|
|
,(convert-arg arg
|
|
(lambda (head)
|
|
(build-cps-term
|
|
($continue k src
|
|
($primcall 'cons (head tail)))))))))
|
|
,(lp args ktail))))))))
|
|
(else
|
|
(convert-args args
|
|
(lambda (args)
|
|
(build-cps-term ($continue k src ($primcall name args))))))))
|
|
|
|
;; Prompts with inline handlers.
|
|
(($ <prompt> src escape-only? tag body
|
|
($ <lambda> hsrc hmeta
|
|
($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
|
|
;; Handler:
|
|
;; khargs: check args returned to handler, -> khbody
|
|
;; khbody: the handler, -> k
|
|
;;
|
|
;; Post-body:
|
|
;; krest: collect return vals from body to list, -> kpop
|
|
;; kpop: pop the prompt, -> kprim
|
|
;; kprim: load the values primitive, -> kret
|
|
;; kret: (apply values rvals), -> k
|
|
;;
|
|
;; Escape prompts evaluate the body with the continuation of krest.
|
|
;; 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) '())))
|
|
(bound-vars (map bound-var hsyms)))
|
|
(let-fresh (khargs khbody kret kprim kpop krest kbody) (prim vals)
|
|
(build-cps-term
|
|
;; FIXME: Attach hsrc to $kreceive.
|
|
($letk* ((khbody ($kargs hnames bound-vars
|
|
,(fold box-bound-var
|
|
(convert hbody k subst)
|
|
hnames hsyms)))
|
|
(khargs ($kreceive hreq hrest khbody))
|
|
(kpop ($kargs ('rest) (vals)
|
|
($letk ((kret
|
|
($kargs () ()
|
|
($letk ((kprim
|
|
($kargs ('prim) (prim)
|
|
($continue k src
|
|
($primcall 'apply
|
|
(prim vals))))))
|
|
($continue kprim src
|
|
($prim 'values))))))
|
|
($continue kret src
|
|
($primcall 'unwind ())))))
|
|
(krest ($kreceive '() 'rest kpop)))
|
|
,(if escape-only?
|
|
(build-cps-term
|
|
($letk ((kbody ($kargs () ()
|
|
,(convert body krest subst))))
|
|
($continue kbody src ($prompt #t tag khargs))))
|
|
(convert-arg body
|
|
(lambda (thunk)
|
|
(build-cps-term
|
|
($letk ((kbody ($kargs () ()
|
|
($continue krest (tree-il-src body)
|
|
($primcall 'call-thunk/no-inline
|
|
(thunk))))))
|
|
($continue kbody (tree-il-src body)
|
|
($prompt #f tag khargs))))))))))))))
|
|
|
|
(($ <abort> src tag args ($ <const> _ ()))
|
|
(convert-args (cons tag args)
|
|
(lambda (args*)
|
|
(build-cps-term
|
|
($continue k src
|
|
($primcall 'abort-to-prompt args*))))))
|
|
|
|
(($ <abort> src tag args tail)
|
|
(convert-args (append (list (make-primitive-ref #f 'abort-to-prompt)
|
|
tag)
|
|
args
|
|
(list tail))
|
|
(lambda (args*)
|
|
(build-cps-term
|
|
($continue k src ($primcall 'apply args*))))))
|
|
|
|
(($ <conditional> src test consequent alternate)
|
|
(let-fresh (kt kf) ()
|
|
(build-cps-term
|
|
($letk* ((kt ($kargs () () ,(convert consequent k subst)))
|
|
(kf ($kargs () () ,(convert alternate k subst))))
|
|
,(match test
|
|
(($ <primcall> src (? branching-primitive? name) args)
|
|
(convert-args args
|
|
(lambda (args)
|
|
(build-cps-term
|
|
($continue kf src
|
|
($branch kt ($primcall name args)))))))
|
|
(_ (convert-arg test
|
|
(lambda (test)
|
|
(build-cps-term
|
|
($continue kf src
|
|
($branch kt ($values (test)))))))))))))
|
|
|
|
(($ <lexical-set> src name gensym exp)
|
|
(convert-arg exp
|
|
(lambda (exp)
|
|
(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-fresh (kreceive kseq) (vals)
|
|
(build-cps-term
|
|
($letk* ((kseq ($kargs ('vals) (vals)
|
|
,(convert tail k 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-fresh (kreceive klet) (rest)
|
|
(build-cps-term
|
|
($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-fresh () (self)
|
|
(build-cps-term
|
|
($letrec names
|
|
(map bound-var gensyms)
|
|
(map (lambda (fun)
|
|
(match (convert fun k subst)
|
|
(($ $continue _ _ (and fun ($ $fun)))
|
|
fun)))
|
|
funs)
|
|
,(convert body k subst))))
|
|
(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) '())))
|
|
(bound-vars (map bound-var syms)))
|
|
(let-fresh (kreceive kargs) ()
|
|
(build-cps-term
|
|
($letk* ((kargs ($kargs names bound-vars
|
|
,(fold box-bound-var
|
|
(convert body k subst)
|
|
names syms)))
|
|
(kreceive ($kreceive req rest kargs)))
|
|
,(convert exp kreceive subst))))))))
|
|
|
|
(define (build-subst 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)
|
|
(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))
|
|
|
|
(define %warning-passes
|
|
`((unused-variable . ,unused-variable-analysis)
|
|
(unused-toplevel . ,unused-toplevel-analysis)
|
|
(unbound-variable . ,unbound-variable-analysis)
|
|
(arity-mismatch . ,arity-analysis)
|
|
(format . ,format-analysis)))
|
|
|
|
(define (optimize-tree-il x e opts)
|
|
(define warnings
|
|
(or (and=> (memq #:warnings opts) cadr)
|
|
'()))
|
|
|
|
;; Go through the warning passes.
|
|
(let ((analyses (filter-map (lambda (kind)
|
|
(assoc-ref %warning-passes kind))
|
|
warnings)))
|
|
(analyze-tree analyses x e))
|
|
|
|
(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
|
|
(canonicalize (optimize-tree-il exp env opts)))
|
|
env
|
|
env))
|
|
|
|
;;; Local Variables:
|
|
;;; eval: (put 'convert-arg 'scheme-indent-function 1)
|
|
;;; eval: (put 'convert-args 'scheme-indent-function 1)
|
|
;;; End:
|