mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 22:10:21 +02:00
Add $code CPS expression type
* module/language/cps.scm ($code): New CPS type, for labels as values. Add cases to all CPS type dispatches. $closure now indicates only statically allocated closures. * module/language/cps/closure-conversion.scm (convert-one): Only reify $closure for statically allocated procedures. Otherwise allocate an object using low-level primitives. * module/language/cps/compile-bytecode.scm (compile-function): Remove make-closure case. * module/language/cps/slot-allocation.scm (compute-var-representations): $code produces a u64 value. * module/system/vm/assembler.scm: Remove make-closure export. * module/language/cps/contification.scm: * module/language/cps/cse.scm: * module/language/cps/dce.scm: * module/language/cps/devirtualize-integers.scm: * module/language/cps/effects-analysis.scm: * module/language/cps/licm.scm: * module/language/cps/peel-loops.scm: * module/language/cps/renumber.scm: * module/language/cps/rotate-loops.scm: * module/language/cps/simplify.scm: * module/language/cps/specialize-numbers.scm: * module/language/cps/types.scm: * module/language/cps/utils.scm: * module/language/cps/verify.scm: Add cases for $code.
This commit is contained in:
Andy Wingo
parent
70e3a4a311
commit
9f98b4a5b1
19 changed files with 68 additions and 22 deletions
|
|
@ -130,7 +130,7 @@
|
|||
$continue $branch $prompt $throw
|
||||
|
||||
;; Expressions.
|
||||
$const $prim $fun $rec $closure
|
||||
$const $prim $fun $rec $closure $code
|
||||
$call $callk $primcall $values
|
||||
|
||||
;; Building macros.
|
||||
|
|
@ -189,6 +189,7 @@
|
|||
(define-cps-type $fun body) ; Higher-order.
|
||||
(define-cps-type $rec names syms funs) ; Higher-order.
|
||||
(define-cps-type $closure label nfree) ; First-order.
|
||||
(define-cps-type $code label) ; First-order.
|
||||
(define-cps-type $call proc args)
|
||||
(define-cps-type $callk k proc args) ; First-order.
|
||||
(define-cps-type $primcall name param args)
|
||||
|
|
@ -242,7 +243,7 @@
|
|||
|
||||
(define-syntax build-exp
|
||||
(syntax-rules (unquote
|
||||
$const $prim $fun $rec $closure
|
||||
$const $prim $fun $rec $closure $code
|
||||
$call $callk $primcall $values)
|
||||
((_ (unquote exp)) exp)
|
||||
((_ ($const val)) (make-$const val))
|
||||
|
|
@ -250,6 +251,7 @@
|
|||
((_ ($fun kentry)) (make-$fun kentry))
|
||||
((_ ($rec names gensyms funs)) (make-$rec names gensyms funs))
|
||||
((_ ($closure k nfree)) (make-$closure k nfree))
|
||||
((_ ($code k)) (make-$code k))
|
||||
((_ ($call proc (unquote args))) (make-$call proc args))
|
||||
((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
|
||||
((_ ($call proc args)) (make-$call proc args))
|
||||
|
|
@ -313,6 +315,8 @@
|
|||
(build-exp ($fun kbody)))
|
||||
(('closure k nfree)
|
||||
(build-exp ($closure k nfree)))
|
||||
(('code k)
|
||||
(build-exp ($code k)))
|
||||
(('rec (name sym fun) ...)
|
||||
(build-exp ($rec name sym (map parse-cps fun))))
|
||||
(('call proc arg ...)
|
||||
|
|
@ -362,6 +366,8 @@
|
|||
`(fun ,kbody))
|
||||
(($ $closure k nfree)
|
||||
`(closure ,k ,nfree))
|
||||
(($ $code k)
|
||||
`(code ,k))
|
||||
(($ $rec names syms funs)
|
||||
`(rec ,@(map (lambda (name sym fun)
|
||||
(list name sym (unparse-cps fun)))
|
||||
|
|
|
|||
|
|
@ -19,9 +19,8 @@
|
|||
;;; Commentary:
|
||||
;;;
|
||||
;;; This pass converts a CPS term in such a way that no function has any
|
||||
;;; free variables. Instead, closures are built explicitly with
|
||||
;;; make-closure primcalls, and free variables are referenced through
|
||||
;;; the closure.
|
||||
;;; free variables. Instead, closures are built explicitly as heap
|
||||
;;; objects, and free variables are referenced through the closure.
|
||||
;;;
|
||||
;;; Closure conversion also removes any $rec expressions that
|
||||
;;; contification did not handle. See (language cps) for a further
|
||||
|
|
@ -520,10 +519,36 @@ term."
|
|||
(define (allocate-closure cps k src label known? nfree)
|
||||
"Allocate a new closure, and pass it to $var{k}."
|
||||
(match (vector known? nfree)
|
||||
(#(#f 0)
|
||||
;; The call sites cannot be enumerated, but the closure has no
|
||||
;; identity; statically allocate it.
|
||||
(with-cps cps
|
||||
(build-term ($continue k src ($closure label 0)))))
|
||||
(#(#f nfree)
|
||||
;; The call sites cannot be enumerated; allocate a closure.
|
||||
(with-cps cps
|
||||
(build-term ($continue k src ($closure label nfree)))))
|
||||
(letv closure tag code)
|
||||
(letk k* ($kargs () ()
|
||||
($continue k src ($values (closure)))))
|
||||
(letk kinit ($kargs ('code) (code)
|
||||
($continue k* src
|
||||
($primcall 'word-set!/immediate '(closure . 1)
|
||||
(closure code)))))
|
||||
(letk kcode ($kargs () ()
|
||||
($continue kinit src ($code label))))
|
||||
(letk ktag1
|
||||
($kargs ('tag) (tag)
|
||||
($continue kcode src
|
||||
($primcall 'word-set!/immediate '(closure . 0)
|
||||
(closure tag)))))
|
||||
(letk ktag0
|
||||
($kargs ('closure) (closure)
|
||||
($continue ktag1 src
|
||||
($primcall 'load-u64 (+ %tc7-program (ash nfree 16)) ()))))
|
||||
(build-term
|
||||
($continue ktag0 src
|
||||
($primcall 'allocate-words/immediate `(closure . ,(+ nfree 2))
|
||||
())))))
|
||||
(#(#t 2)
|
||||
;; Well-known closure with two free variables; the closure is a
|
||||
;; pair.
|
||||
|
|
|
|||
|
|
@ -137,8 +137,8 @@
|
|||
(emit-load-constant asm (from-sp dst) exp))
|
||||
(($ $closure k 0)
|
||||
(emit-load-static-procedure asm (from-sp dst) k))
|
||||
(($ $closure k nfree)
|
||||
(emit-make-closure asm (from-sp dst) k nfree))
|
||||
(($ $code k)
|
||||
(emit-load-label asm (from-sp dst) k))
|
||||
(($ $primcall 'current-module)
|
||||
(emit-current-module asm (from-sp dst)))
|
||||
(($ $primcall 'current-thread)
|
||||
|
|
|
|||
|
|
@ -169,7 +169,7 @@ $call, and are always called with a compatible arity."
|
|||
(match cont
|
||||
(($ $kargs _ _ ($ $continue _ _ exp))
|
||||
(match exp
|
||||
((or ($ $const) ($ $prim) ($ $closure) ($ $fun) ($ $rec))
|
||||
((or ($ $const) ($ $prim) ($ $closure) ($ $code) ($ $fun) ($ $rec))
|
||||
functions)
|
||||
(($ $values args)
|
||||
(exclude-vars functions args))
|
||||
|
|
|
|||
|
|
@ -215,6 +215,7 @@ false. It could be that both true and false proofs are available."
|
|||
(($ $fun body) #f)
|
||||
(($ $rec names syms funs) #f)
|
||||
(($ $closure label nfree) #f)
|
||||
(($ $code label) (cons 'code label))
|
||||
(($ $call proc args) #f)
|
||||
(($ $callk k proc args) #f)
|
||||
(($ $primcall name param args)
|
||||
|
|
@ -360,7 +361,7 @@ false. It could be that both true and false proofs are available."
|
|||
|
||||
(define (visit-exp exp)
|
||||
(rewrite-exp exp
|
||||
((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure)) ,exp)
|
||||
((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure) ($ $code)) ,exp)
|
||||
(($ $call proc args)
|
||||
($call (subst-var proc) ,(map subst-var args)))
|
||||
(($ $callk k proc args)
|
||||
|
|
|
|||
|
|
@ -136,6 +136,8 @@ sites."
|
|||
(values (intset-add live-labels body) live-vars))
|
||||
(($ $closure body)
|
||||
(values (intset-add live-labels body) live-vars))
|
||||
(($ $code body)
|
||||
(values (intset-add live-labels body) live-vars))
|
||||
(($ $rec names vars (($ $fun kfuns) ...))
|
||||
(let lp ((vars vars) (kfuns kfuns)
|
||||
(live-labels live-labels) (live-vars live-vars))
|
||||
|
|
|
|||
|
|
@ -63,7 +63,7 @@
|
|||
(match term
|
||||
(($ $continue k src exp)
|
||||
(match exp
|
||||
((or ($ $const) ($ $prim) ($ $fun) ($ $closure) ($ $rec))
|
||||
((or ($ $const) ($ $prim) ($ $fun) ($ $closure) ($ $code) ($ $rec))
|
||||
use-counts)
|
||||
(($ $values args)
|
||||
(add-uses use-counts args))
|
||||
|
|
|
|||
|
|
@ -558,7 +558,7 @@ the LABELS that are clobbered by the effects of LABEL."
|
|||
|
||||
(define (expression-effects exp)
|
||||
(match exp
|
||||
((or ($ $const) ($ $prim) ($ $values))
|
||||
((or ($ $const) ($ $prim) ($ $values) ($ $code))
|
||||
&no-effects)
|
||||
(($ $closure _ 0)
|
||||
&no-effects)
|
||||
|
|
|
|||
|
|
@ -67,7 +67,7 @@
|
|||
(not (effect-clobbers? fx* fx))))
|
||||
loop-effects #t))
|
||||
(match exp
|
||||
((or ($ $const) ($ $prim) ($ $closure)) #t)
|
||||
((or ($ $const) ($ $prim) ($ $closure) ($ $code)) #t)
|
||||
(($ $primcall name param args)
|
||||
(and-map (lambda (arg) (not (intset-ref loop-vars arg)))
|
||||
args))
|
||||
|
|
|
|||
|
|
@ -142,7 +142,7 @@
|
|||
(intmap-ref fresh-vars var (lambda (var) var)))
|
||||
(define (rename-exp exp)
|
||||
(rewrite-exp exp
|
||||
((or ($ $const) ($ $prim) ($ $closure) ($ $rec ())) ,exp)
|
||||
((or ($ $const) ($ $prim) ($ $closure) ($ $code) ($ $rec ())) ,exp)
|
||||
(($ $values args)
|
||||
($values ,(map rename-var args)))
|
||||
(($ $call proc args)
|
||||
|
|
|
|||
|
|
@ -145,6 +145,8 @@
|
|||
;; Closures with zero free vars get copy-propagated so it's
|
||||
;; possible to already have visited them.
|
||||
(maybe-visit-fun kfun labels vars))
|
||||
(($ $kargs names syms ($ $continue k src ($ $code kfun)))
|
||||
(maybe-visit-fun kfun labels vars))
|
||||
(($ $kargs names syms ($ $continue k src ($ $callk kfun)))
|
||||
;; Well-known functions never have a $closure created for them
|
||||
;; and are only referenced by their $callk call sites.
|
||||
|
|
@ -169,6 +171,8 @@
|
|||
((or ($ $const) ($ $prim)) ,exp)
|
||||
(($ $closure k nfree)
|
||||
($closure (rename-label k) nfree))
|
||||
(($ $code k)
|
||||
($code (rename-label k)))
|
||||
(($ $fun body)
|
||||
($fun (rename-label body)))
|
||||
(($ $rec names vars funs)
|
||||
|
|
|
|||
|
|
@ -110,7 +110,7 @@ corresponding var from REPLACEMENTS; otherwise return VAR."
|
|||
(($ $continue k src exp)
|
||||
($continue k src
|
||||
,(rewrite-exp exp
|
||||
((or ($ $const) ($ $prim) ($ $closure)) ,exp)
|
||||
((or ($ $const) ($ $prim) ($ $closure) ($ $code)) ,exp)
|
||||
(($ $values args)
|
||||
($values ,(rename* args)))
|
||||
(($ $call proc args)
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@
|
|||
(match cont
|
||||
(($ $kargs _ _ ($ $continue _ _ exp))
|
||||
(match exp
|
||||
((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure))
|
||||
((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure) ($ $code))
|
||||
(values single multiple))
|
||||
(($ $call proc args)
|
||||
(ref* (cons proc args)))
|
||||
|
|
@ -250,7 +250,8 @@
|
|||
(($ $continue k src exp)
|
||||
($continue k src
|
||||
,(rewrite-exp exp
|
||||
((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure))
|
||||
((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure)
|
||||
($ $code))
|
||||
,exp)
|
||||
(($ $call proc args)
|
||||
($call (subst proc) ,(map subst args)))
|
||||
|
|
|
|||
|
|
@ -146,7 +146,7 @@ by a label, respectively."
|
|||
(return (intset self) empty-intset))
|
||||
(($ $kargs _ _ ($ $continue k src exp))
|
||||
(match exp
|
||||
((or ($ $const) ($ $closure))
|
||||
((or ($ $const) ($ $closure) ($ $code))
|
||||
(return (get-defs k) empty-intset))
|
||||
(($ $call proc args)
|
||||
(return (get-defs k) (intset-add (vars->intset args) proc)))
|
||||
|
|
@ -770,6 +770,8 @@ are comparable with eqv?. A tmp slot may be used."
|
|||
(($ $primcall (or 'pointer-ref/immediate
|
||||
'tail-pointer-ref/immediate))
|
||||
(intmap-add representations var 'ptr))
|
||||
(($ $code)
|
||||
(intmap-add representations var 'u64))
|
||||
(_
|
||||
(intmap-add representations var 'scm))))
|
||||
(vars
|
||||
|
|
|
|||
|
|
@ -311,7 +311,8 @@ BITS indicating the significant bits needed for a variable. BITS may be
|
|||
(match term
|
||||
(($ $continue k src exp)
|
||||
(match exp
|
||||
((or ($ $const) ($ $prim) ($ $fun) ($ $closure) ($ $rec))
|
||||
((or ($ $const) ($ $prim) ($ $fun) ($ $closure)
|
||||
($ $code) ($ $rec))
|
||||
;; No uses, so no info added to sigbits.
|
||||
out)
|
||||
(($ $values args)
|
||||
|
|
|
|||
|
|
@ -1786,7 +1786,7 @@ maximum, where type is a bitset as a fixnum."
|
|||
(let ((entry (match exp
|
||||
(($ $const val)
|
||||
(constant-type val))
|
||||
((or ($ $prim) ($ $fun) ($ $closure))
|
||||
((or ($ $prim) ($ $fun) ($ $closure) ($ $code))
|
||||
;; Could be more precise here.
|
||||
(make-type-entry &procedure -inf.0 +inf.0)))))
|
||||
(propagate1 k (adjoin-var types var entry))))))))
|
||||
|
|
|
|||
|
|
@ -226,6 +226,7 @@ intset."
|
|||
(($ $fun label) (return1 label))
|
||||
(($ $rec _ _ (($ $fun labels) ...)) (return labels))
|
||||
(($ $closure label nfree) (return1 label))
|
||||
(($ $code label) (return1 label))
|
||||
(($ $callk label) (return1 label))
|
||||
(_ (return0))))
|
||||
(_ (return0))))
|
||||
|
|
|
|||
|
|
@ -148,6 +148,8 @@ definitions that are available at LABEL."
|
|||
(visit-fun kfun bound first-order))
|
||||
(($ $closure kfun)
|
||||
(visit-first-order kfun))
|
||||
(($ $code kfun)
|
||||
(visit-first-order kfun))
|
||||
(($ $rec names vars (($ $fun kfuns) ...))
|
||||
(let ((bound (fold1 adjoin-def vars bound)))
|
||||
(fold1 (lambda (kfun first-order)
|
||||
|
|
@ -184,6 +186,8 @@ definitions that are available at LABEL."
|
|||
(visit-fun kfun bound first-order))
|
||||
(($ $closure kfun)
|
||||
(visit-first-order kfun))
|
||||
(($ $code kfun)
|
||||
(visit-first-order kfun))
|
||||
(($ $rec names vars (($ $fun kfuns) ...))
|
||||
(let ((bound (fold1 adjoin-def vars bound)))
|
||||
(fold1 (lambda (kfun first-order)
|
||||
|
|
@ -262,7 +266,7 @@ definitions that are available at LABEL."
|
|||
((or ($ $kreceive) ($ $ktail)) #t)
|
||||
(_ (error "expected $kreceive or $ktail continuation" cont))))
|
||||
(match exp
|
||||
((or ($ $const) ($ $prim) ($ $closure) ($ $fun))
|
||||
((or ($ $const) ($ $prim) ($ $closure) ($ $code) ($ $fun))
|
||||
(assert-unary))
|
||||
(($ $rec names vars funs)
|
||||
(unless (= (length names) (length vars) (length funs))
|
||||
|
|
|
|||
|
|
@ -215,7 +215,6 @@
|
|||
emit-assert-nargs-ee/locals
|
||||
emit-bind-kwargs
|
||||
emit-bind-rest
|
||||
emit-make-closure
|
||||
emit-load-label
|
||||
emit-current-module
|
||||
emit-resolve
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue