[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 17/24: Add $code CPS expression type
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 17/24: Add $code CPS expression type |
|
Date: |
Tue, 10 Apr 2018 13:24:15 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 9f98b4a5b1067b177c700d27abf4ed477f013951
Author: Andy Wingo <address@hidden>
Date: Tue Apr 10 17:03:16 2018 +0200
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.
---
module/language/cps.scm | 10 ++++++--
module/language/cps/closure-conversion.scm | 33 +++++++++++++++++++++++----
module/language/cps/compile-bytecode.scm | 4 ++--
module/language/cps/contification.scm | 2 +-
module/language/cps/cse.scm | 3 ++-
module/language/cps/dce.scm | 2 ++
module/language/cps/devirtualize-integers.scm | 2 +-
module/language/cps/effects-analysis.scm | 2 +-
module/language/cps/licm.scm | 2 +-
module/language/cps/peel-loops.scm | 2 +-
module/language/cps/renumber.scm | 4 ++++
module/language/cps/rotate-loops.scm | 2 +-
module/language/cps/simplify.scm | 5 ++--
module/language/cps/slot-allocation.scm | 4 +++-
module/language/cps/specialize-numbers.scm | 3 ++-
module/language/cps/types.scm | 2 +-
module/language/cps/utils.scm | 1 +
module/language/cps/verify.scm | 6 ++++-
module/system/vm/assembler.scm | 1 -
19 files changed, 68 insertions(+), 22 deletions(-)
diff --git a/module/language/cps.scm b/module/language/cps.scm
index 55b34c9..d4c42ac 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -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)))
diff --git a/module/language/cps/closure-conversion.scm
b/module/language/cps/closure-conversion.scm
index 4f92963..746e5ce 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -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.
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index bcd535f..f9eb8a4 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -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)
diff --git a/module/language/cps/contification.scm
b/module/language/cps/contification.scm
index 934ae5e..6401a0b 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -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))
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 3956145..01b38b6 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -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)
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index 40f501a..3ee0f00 100644
--- a/module/language/cps/dce.scm
+++ b/module/language/cps/dce.scm
@@ -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))
diff --git a/module/language/cps/devirtualize-integers.scm
b/module/language/cps/devirtualize-integers.scm
index c4b875d..d45287b 100644
--- a/module/language/cps/devirtualize-integers.scm
+++ b/module/language/cps/devirtualize-integers.scm
@@ -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))
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index b19027d..684adef 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -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)
diff --git a/module/language/cps/licm.scm b/module/language/cps/licm.scm
index 4a82528..622940e 100644
--- a/module/language/cps/licm.scm
+++ b/module/language/cps/licm.scm
@@ -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))
diff --git a/module/language/cps/peel-loops.scm
b/module/language/cps/peel-loops.scm
index 43e9869..46a4462 100644
--- a/module/language/cps/peel-loops.scm
+++ b/module/language/cps/peel-loops.scm
@@ -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)
diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm
index 8b4996e..73a00cb 100644
--- a/module/language/cps/renumber.scm
+++ b/module/language/cps/renumber.scm
@@ -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)
diff --git a/module/language/cps/rotate-loops.scm
b/module/language/cps/rotate-loops.scm
index 48be0d9..92198df 100644
--- a/module/language/cps/rotate-loops.scm
+++ b/module/language/cps/rotate-loops.scm
@@ -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)
diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm
index c50372b..24963bc 100644
--- a/module/language/cps/simplify.scm
+++ b/module/language/cps/simplify.scm
@@ -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)))
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index d3f7ce3..a7a9ab5 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -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
diff --git a/module/language/cps/specialize-numbers.scm
b/module/language/cps/specialize-numbers.scm
index 578a042..e7405a9 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -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)
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 9fb0df9..74a73bb 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -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))))))))
diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm
index 77431b8..d1b2073 100644
--- a/module/language/cps/utils.scm
+++ b/module/language/cps/utils.scm
@@ -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))))
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index 938c37a..e72d395 100644
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -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))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index b3d2bb2..3e36dfe 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -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
- [Guile-commits] 13/24: Instruction explosion for char->integer, (continued)
- [Guile-commits] 13/24: Instruction explosion for char->integer, Andy Wingo, 2018/04/10
- [Guile-commits] 05/24: Add VM ops needed for string-ref, Andy Wingo, 2018/04/10
- [Guile-commits] 01/24: Add instrinsics to runtime, Andy Wingo, 2018/04/10
- [Guile-commits] 02/24: Compile some generic arithmetic to intrinsic calls, Andy Wingo, 2018/04/10
- [Guile-commits] 23/24: Remove class-of opcode, Andy Wingo, 2018/04/10
- [Guile-commits] 19/24: string->number, etc intrinsics, Andy Wingo, 2018/04/10
- [Guile-commits] 24/24: Remove load-typed-array, make-array opcodes, Andy Wingo, 2018/04/10
- [Guile-commits] 20/24: Remove string->number, etc opcodes, Andy Wingo, 2018/04/10
- [Guile-commits] 09/24: Explode "string-set!", Andy Wingo, 2018/04/10
- [Guile-commits] 14/24: Remove char->integer from VM, Andy Wingo, 2018/04/10
- [Guile-commits] 17/24: Add $code CPS expression type,
Andy Wingo <=
- [Guile-commits] 15/24: Remove dead code in CPS converter, Andy Wingo, 2018/04/10
- [Guile-commits] 22/24: Class-of is intrinsic, Andy Wingo, 2018/04/10
- [Guile-commits] 18/24: Remove unused make-closure opcode., Andy Wingo, 2018/04/10
- [Guile-commits] 08/24: Add string-set! intrinsic, Andy Wingo, 2018/04/10