[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, wip-rtl-halloween, updated. v2.1.0-340
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, wip-rtl-halloween, updated. v2.1.0-340-g4b8d21c |
|
Date: |
Thu, 07 Nov 2013 15:58:57 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=4b8d21c17c9e72fb6f61747099c0798d5e264496
The branch, wip-rtl-halloween has been updated
via 4b8d21c17c9e72fb6f61747099c0798d5e264496 (commit)
via 31602aa04aefe58fa780eb066caefd20f87b275b (commit)
via 32ca15d7d733202bd1495d1beed7251bd566ec2d (commit)
via 6e422a3599d0f293078576b1e77c74f408d80a14 (commit)
via 963d95f1d92248d2689efc8b67a9de1f1c8204fb (commit)
via 111a305be88a318f65707d251051d3b95c46d647 (commit)
from 0a1d52ac77e6424dbd1359827718af5a4d6c154a (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 4b8d21c17c9e72fb6f61747099c0798d5e264496
Author: Andy Wingo <address@hidden>
Date: Thu Nov 7 11:16:24 2013 +0100
Fix DWARF source test now that we have more precise source info.
* test-suite/tests/dwarf.test: Fix test after the $continue/$cont source
change, which reifies proper source info for the +.
commit 31602aa04aefe58fa780eb066caefd20f87b275b
Author: Andy Wingo <address@hidden>
Date: Thu Nov 7 11:10:36 2013 +0100
Fix line advance DWARF opcodes when line advance is exactly 128
* module/system/vm/assembler.scm (link-debug): Fix off-by-one error in
which forward jumps of 128 were mis-rendered.
commit 32ca15d7d733202bd1495d1beed7251bd566ec2d
Author: Andy Wingo <address@hidden>
Date: Thu Nov 7 10:52:47 2013 +0100
Write DWARF files list in correct order.
* module/system/vm/assembler.scm (link-debug): Fix order of writing the
source files list; it was being written backwards.
commit 6e422a3599d0f293078576b1e77c74f408d80a14
Author: Andy Wingo <address@hidden>
Date: Thu Nov 7 10:32:21 2013 +0100
Source information goes on the $continue, not the $cont.
* module/language/cps.scm ($continue, $cont): Put source information on
the $continue, not on the $cont. Otherwise it is difficult for CPS
conversion to preserve source information.
($fun): Add a src member to $fun. Otherwise we might miss the source
info for the start of the function.
* .dir-locals.el:
* module/language/cps/arities.scm:
* module/language/cps/closure-conversion.scm:
* module/language/cps/compile-rtl.scm:
* module/language/cps/constructors.scm:
* module/language/cps/contification.scm:
* module/language/cps/dfg.scm:
* module/language/cps/elide-values.scm:
* module/language/cps/reify-primitives.scm:
* module/language/cps/slot-allocation.scm:
* module/language/cps/verify.scm:
* module/language/tree-il/compile-cps.scm: Update the whole CPS world
for this change.
commit 963d95f1d92248d2689efc8b67a9de1f1c8204fb
Author: Andy Wingo <address@hidden>
Date: Wed Nov 6 17:33:43 2013 +0100
Fix first find-program-sources result
* module/system/vm/debug.scm (find-program-sources): Manually set the pc
of the first result in a function.
commit 111a305be88a318f65707d251051d3b95c46d647
Author: Andy Wingo <address@hidden>
Date: Tue Nov 5 21:33:00 2013 +0100
compiler.test fix for rtl compilation
* test-suite/tests/compiler.test ("current-reader"): Fix the way we make
programs from objcode.
-----------------------------------------------------------------------
Summary of changes:
.dir-locals.el | 2 +-
module/language/cps.scm | 75 ++--
module/language/cps/arities.scm | 134 +++---
module/language/cps/closure-conversion.scm | 91 ++--
module/language/cps/compile-rtl.scm | 780 ++++++++++++++--------------
module/language/cps/constructors.scm | 52 +-
module/language/cps/contification.scm | 72 ++--
module/language/cps/dfg.scm | 34 +-
module/language/cps/elide-values.scm | 30 +-
module/language/cps/reify-primitives.scm | 80 ++--
module/language/cps/slot-allocation.scm | 12 +-
module/language/cps/verify.scm | 18 +-
module/language/tree-il/compile-cps.scm | 205 ++++----
module/system/vm/assembler.scm | 23 +-
module/system/vm/debug.scm | 12 +-
test-suite/tests/compiler.test | 8 +-
test-suite/tests/dwarf.test | 12 +-
17 files changed, 818 insertions(+), 822 deletions(-)
diff --git a/.dir-locals.el b/.dir-locals.el
index 94a2126..0589229 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -21,7 +21,7 @@
(eval . (put '$letk 'scheme-indent-function 1))
(eval . (put '$letk* 'scheme-indent-function 1))
(eval . (put '$letconst 'scheme-indent-function 1))
- (eval . (put '$continue 'scheme-indent-function 1))
+ (eval . (put '$continue 'scheme-indent-function 2))
(eval . (put '$kargs 'scheme-indent-function 2))
(eval . (put '$kentry 'scheme-indent-function 2))
(eval . (put '$kclause 'scheme-indent-function 1))
diff --git a/module/language/cps.scm b/module/language/cps.scm
index d39124e..4dc88eb 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -25,15 +25,15 @@
;;; and terms that call continuations.
;;;
;;; $letk binds a set of mutually recursive continuations, each one an
-;;; instance of $cont. A $cont declares the name and source of a
-;;; continuation, and then contains as a subterm the particular
-;;; continuation instance: $kif for test continuations, $kargs for
-;;; continuations that bind values, etc.
+;;; instance of $cont. A $cont declares the name of a continuation, and
+;;; then contains as a subterm the particular continuation instance:
+;;; $kif for test continuations, $kargs for continuations that bind
+;;; values, etc.
;;;
;;; $continue nodes call continuations. The expression contained in the
;;; $continue node determines the value or values that are passed to the
;;; target continuation: $const to pass a constant value, $values to
-;;; pass multiple named values, etc.
+;;; pass multiple named values, etc. $continue nodes also record the source
at which
;;;
;;; Additionally there is $letrec, a term that binds mutually recursive
;;; functions. The contification pass will turn $letrec into $letk if
@@ -71,8 +71,8 @@
;;; That's to say that a $fun can be matched like this:
;;;
;;; (match f
-;;; (($ $fun meta free
-;;; ($ $cont kentry src
+;;; (($ $fun src meta free
+;;; ($ $cont kentry
;;; ($ $kentry self ($ $cont ktail _ ($ $ktail))
;;; (($ $kclause arity
;;; ($ $cont kbody _ ($ $kargs names syms body)))
@@ -165,11 +165,11 @@
;; Terms.
(define-cps-type $letk conts body)
-(define-cps-type $continue k exp)
+(define-cps-type $continue k src exp)
(define-cps-type $letrec names syms funs body)
;; Continuations
-(define-cps-type $cont k src cont)
+(define-cps-type $cont k cont)
(define-cps-type $kif kt kf)
(define-cps-type $ktrunc arity k)
(define-cps-type $kargs names syms body)
@@ -182,7 +182,7 @@
(define-cps-type $void)
(define-cps-type $const val)
(define-cps-type $prim name)
-(define-cps-type $fun meta free body)
+(define-cps-type $fun src meta free body)
(define-cps-type $call proc args)
(define-cps-type $primcall name args)
(define-cps-type $values args)
@@ -224,7 +224,7 @@
(define-syntax build-cps-cont
(syntax-rules (unquote)
((_ (unquote exp)) exp)
- ((_ (k src cont)) (make-$cont k src (build-cont-body cont)))))
+ ((_ (k cont)) (make-$cont k (build-cont-body cont)))))
(define-syntax build-cps-exp
(syntax-rules (unquote
@@ -234,7 +234,8 @@
((_ ($void)) (make-$void))
((_ ($const val)) (make-$const val))
((_ ($prim name)) (make-$prim name))
- ((_ ($fun meta free body)) (make-$fun meta free (build-cps-cont body)))
+ ((_ ($fun src meta free body))
+ (make-$fun src meta free (build-cps-cont body)))
((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
((_ ($call proc args)) (make-$call proc args))
((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
@@ -262,12 +263,14 @@
((_ ($letconst ((name sym val) tail ...) body))
(let-gensyms (kconst)
(build-cps-term
- ($letk ((kconst #f ($kargs (name) (sym) ($letconst (tail ...) body))))
- ($continue kconst ($const val))))))
+ ($letk ((kconst ($kargs (name) (sym) ($letconst (tail ...) body))))
+ ($continue kconst (let ((props (source-properties val)))
+ (and (pair? props) props))
+ ($const val))))))
((_ ($letrec names gensyms funs body))
(make-$letrec names gensyms funs (build-cps-term body)))
- ((_ ($continue k exp))
- (make-$continue k (build-cps-exp exp)))))
+ ((_ ($continue k src exp))
+ (make-$continue k src (build-cps-exp exp)))))
(define-syntax-rule (rewrite-cps-term x (pat body) ...)
(match x
@@ -287,20 +290,20 @@
;; Continuations.
(('letconst k (name sym c) body)
(build-cps-term
- ($letk ((k (src exp) ($kargs (name) (sym)
- ,(parse-cps body))))
- ($continue k ($const c)))))
+ ($letk ((k ($kargs (name) (sym)
+ ,(parse-cps body))))
+ ($continue k (src exp) ($const c)))))
(('let k (name sym val) body)
(build-cps-term
- ($letk ((k (src exp) ($kargs (name) (sym)
- ,(parse-cps body))))
+ ($letk ((k ($kargs (name) (sym)
+ ,(parse-cps body))))
,(parse-cps val))))
(('letk (cont ...) body)
(build-cps-term
($letk ,(map parse-cps cont) ,(parse-cps body))))
(('k sym body)
(build-cps-cont
- (sym (src exp) ,(parse-cps body))))
+ (sym ,(parse-cps body))))
(('kif kt kf)
(build-cont-body ($kif kt kf)))
(('ktrunc req rest k)
@@ -322,7 +325,7 @@
;; Calls.
(('continue k exp)
- (build-cps-term ($continue k ,(parse-cps exp))))
+ (build-cps-term ($continue k (src exp) ,(parse-cps exp))))
(('var sym)
(build-cps-exp ($var sym)))
(('void)
@@ -332,7 +335,7 @@
(('prim name)
(build-cps-exp ($prim name)))
(('fun meta free body)
- (build-cps-exp ($fun meta free ,(parse-cps body))))
+ (build-cps-exp ($fun (src exp) meta free ,(parse-cps body))))
(('letrec ((name sym fun) ...) body)
(build-cps-term
($letrec name sym (map parse-cps fun) ,(parse-cps body))))
@@ -350,16 +353,16 @@
(define (unparse-cps exp)
(match exp
;; Continuations.
- (($ $letk (($ $cont k src ($ $kargs (name) (sym) body)))
- ($ $continue k ($ $const c)))
+ (($ $letk (($ $cont k ($ $kargs (name) (sym) body)))
+ ($ $continue k src ($ $const c)))
`(letconst ,k (,name ,sym ,c)
,(unparse-cps body)))
- (($ $letk (($ $cont k src ($ $kargs (name) (sym) body))) val)
+ (($ $letk (($ $cont k ($ $kargs (name) (sym) body))) val)
`(let ,k (,name ,sym ,(unparse-cps val))
,(unparse-cps body)))
(($ $letk conts body)
`(letk ,(map unparse-cps conts) ,(unparse-cps body)))
- (($ $cont sym src body)
+ (($ $cont sym body)
`(k ,sym ,(unparse-cps body)))
(($ $kif kt kf)
`(kif ,kt ,kf))
@@ -377,7 +380,7 @@
`(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,(unparse-cps body)))
;; Calls.
- (($ $continue k exp)
+ (($ $continue k src exp)
`(continue ,k ,(unparse-cps exp)))
(($ $var sym)
`(var ,sym))
@@ -387,7 +390,7 @@
`(const ,val))
(($ $prim name)
`(prim ,name))
- (($ $fun meta free body)
+ (($ $fun src meta free body)
`(fun ,meta ,free ,(unparse-cps body)))
(($ $letrec names syms funs body)
`(letrec ,(map (lambda (name sym fun)
@@ -408,8 +411,8 @@
(define (fold-conts proc seed fun)
(define (cont-folder cont seed)
(match cont
- (($ $cont k src cont)
- (let ((seed (proc k src cont seed)))
+ (($ $cont k cont)
+ (let ((seed (proc k cont seed)))
(match cont
(($ $kargs names syms body)
(term-folder body seed))
@@ -424,7 +427,7 @@
(define (fun-folder fun seed)
(match fun
- (($ $fun meta free body)
+ (($ $fun src meta free body)
(cont-folder body seed))))
(define (term-folder term seed)
@@ -432,7 +435,7 @@
(($ $letk conts body)
(fold cont-folder (term-folder body seed) conts))
- (($ $continue k exp)
+ (($ $continue k src exp)
(match exp
(($ $fun) (fun-folder exp seed))
(_ seed)))
@@ -445,8 +448,8 @@
(define (fold-local-conts proc seed cont)
(define (cont-folder cont seed)
(match cont
- (($ $cont k src cont)
- (let ((seed (proc k src cont seed)))
+ (($ $cont k cont)
+ (let ((seed (proc k cont seed)))
(match cont
(($ $kargs names syms body)
(term-folder body seed))
diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm
index fb888fd..430d697 100644
--- a/module/language/cps/arities.scm
+++ b/module/language/cps/arities.scm
@@ -35,105 +35,105 @@
(define (fix-clause-arities clause)
(let ((conts (build-local-cont-table clause))
(ktail (match clause
- (($ $cont _ _ ($ $kentry _ ($ $cont ktail) _)) ktail))))
+ (($ $cont _ ($ $kentry _ ($ $cont ktail) _)) ktail))))
(define (visit-term term)
(rewrite-cps-term term
(($ $letk conts body)
($letk ,(map visit-cont conts) ,(visit-term body)))
(($ $letrec names syms funs body)
($letrec names syms (map fix-arities funs) ,(visit-term body)))
- (($ $continue k exp)
- ,(visit-exp k exp))))
+ (($ $continue k src exp)
+ ,(visit-exp k src exp))))
- (define (adapt-exp nvals k exp)
+ (define (adapt-exp nvals k src exp)
(match nvals
(0
(rewrite-cps-term (lookup-cont k conts)
(($ $ktail)
,(let-gensyms (kvoid kunspec unspec)
(build-cps-term
- ($letk* ((kunspec #f ($kargs (unspec) (unspec)
- ($continue k
- ($primcall 'return (unspec)))))
- (kvoid #f ($kargs () ()
- ($continue kunspec ($void)))))
- ($continue kvoid ,exp)))))
+ ($letk* ((kunspec ($kargs (unspec) (unspec)
+ ($continue k src
+ ($primcall 'return (unspec)))))
+ (kvoid ($kargs () ()
+ ($continue kunspec src ($void)))))
+ ($continue kvoid src ,exp)))))
(($ $ktrunc arity kargs)
,(rewrite-cps-term arity
(($ $arity () () #f () #f)
- ($continue kargs ,exp))
+ ($continue kargs src ,exp))
(_
,(let-gensyms (kvoid kvalues void)
(build-cps-term
- ($letk* ((kvalues #f ($kargs ('void) (void)
- ($continue k
- ($primcall 'values (void)))))
- (kvoid #f ($kargs () ()
- ($continue kvalues
- ($void)))))
- ($continue kvoid ,exp)))))))
+ ($letk* ((kvalues ($kargs ('void) (void)
+ ($continue k src
+ ($primcall 'values (void)))))
+ (kvoid ($kargs () ()
+ ($continue kvalues src
+ ($void)))))
+ ($continue kvoid src ,exp)))))))
(($ $kargs () () _)
- ($continue k ,exp))
+ ($continue k src ,exp))
(_
,(let-gensyms (k*)
(build-cps-term
- ($letk ((k* #f ($kargs () () ($continue k ($void)))))
- ($continue k* ,exp)))))))
+ ($letk ((k* ($kargs () () ($continue k src ($void)))))
+ ($continue k* src ,exp)))))))
(1
(rewrite-cps-term (lookup-cont k conts)
(($ $ktail)
,(rewrite-cps-term exp
(($var sym)
- ($continue ktail ($primcall 'return (sym))))
+ ($continue ktail src ($primcall 'return (sym))))
(_
,(let-gensyms (k* v)
(build-cps-term
- ($letk ((k* #f ($kargs (v) (v)
- ($continue k
- ($primcall 'return (v))))))
- ($continue k* ,exp)))))))
+ ($letk ((k* ($kargs (v) (v)
+ ($continue k src
+ ($primcall 'return (v))))))
+ ($continue k* src ,exp)))))))
(($ $ktrunc arity kargs)
,(rewrite-cps-term arity
(($ $arity (_) () #f () #f)
- ($continue kargs ,exp))
+ ($continue kargs src ,exp))
(_
,(let-gensyms (kvalues value)
(build-cps-term
- ($letk ((kvalues #f ($kargs ('value) (value)
- ($continue k
- ($primcall 'values (value))))))
- ($continue kvalues ,exp)))))))
+ ($letk ((kvalues ($kargs ('value) (value)
+ ($continue k src
+ ($primcall 'values (value))))))
+ ($continue kvalues src ,exp)))))))
(($ $kargs () () _)
,(let-gensyms (k* drop)
(build-cps-term
- ($letk ((k* #f ($kargs ('drop) (drop)
- ($continue k ($values ())))))
- ($continue k* ,exp)))))
+ ($letk ((k* ($kargs ('drop) (drop)
+ ($continue k src ($values ())))))
+ ($continue k* src ,exp)))))
(_
- ($continue k ,exp))))))
+ ($continue k src ,exp))))))
- (define (visit-exp k exp)
+ (define (visit-exp k src exp)
(rewrite-cps-term exp
((or ($ $void)
($ $const)
($ $prim)
($ $var))
- ,(adapt-exp 1 k exp))
+ ,(adapt-exp 1 k src exp))
(($ $fun)
- ,(adapt-exp 1 k (fix-arities exp)))
+ ,(adapt-exp 1 k src (fix-arities exp)))
(($ $call)
;; In general, calls have unknown return arity. For that
;; reason every non-tail call has an implicit adaptor
;; continuation to adapt the return to the target
;; continuation, and we don't need to do any adapting here.
- ($continue k ,exp))
+ ($continue k src ,exp))
(($ $primcall 'return (arg))
;; Primcalls to return are in tail position.
- ($continue ktail ,exp))
+ ($continue ktail src ,exp))
(($ $primcall (? (lambda (name)
(and (not (prim-rtl-instruction name))
(not (branching-primitive? name))))))
- ($continue k ,exp))
+ ($continue k src ,exp))
(($ $primcall 'struct-set! (obj pos val))
;; Unhappily, and undocumentedly, struct-set! returns the value
;; that was set. There is code that relies on this. Hackety
@@ -142,63 +142,63 @@
(($ $ktail)
,(let-gensyms (kvoid)
(build-cps-term
- ($letk* ((kvoid #f ($kargs () ()
- ($continue ktail
- ($primcall 'return (val))))))
- ($continue kvoid ,exp)))))
+ ($letk* ((kvoid ($kargs () ()
+ ($continue ktail src
+ ($primcall 'return (val))))))
+ ($continue kvoid src ,exp)))))
(($ $ktrunc arity kargs)
,(rewrite-cps-term arity
(($ $arity () () #f () #f)
- ($continue kargs ,exp))
+ ($continue kargs src ,exp))
(_
,(let-gensyms (kvoid)
(build-cps-term
- ($letk* ((kvoid #f ($kargs () ()
- ($continue k
- ($primcall 'values (val))))))
- ($continue kvoid ,exp)))))))
+ ($letk* ((kvoid ($kargs () ()
+ ($continue k src
+ ($primcall 'values (val))))))
+ ($continue kvoid src ,exp)))))))
(($ $kargs () () _)
- ($continue k ,exp))
+ ($continue k src ,exp))
(_
,(let-gensyms (k*)
(build-cps-term
- ($letk ((k* #f ($kargs () () ($continue k ($var val)))))
- ($continue k* ,exp)))))))
+ ($letk ((k* ($kargs () () ($continue k src ($var val)))))
+ ($continue k* src ,exp)))))))
(($ $primcall name args)
,(match (prim-arity name)
((out . in)
(if (= in (length args))
- (adapt-exp out k
+ (adapt-exp out k src
(let ((inst (prim-rtl-instruction name)))
(if (and inst (not (eq? inst name)))
(build-cps-exp ($primcall inst args))
exp)))
(let-gensyms (k* p*)
(build-cps-term
- ($letk ((k* #f ($kargs ('prim) (p*)
- ($continue k ($call p* args)))))
- ($continue k* ($prim name)))))))))
+ ($letk ((k* ($kargs ('prim) (p*)
+ ($continue k src ($call p* args)))))
+ ($continue k* src ($prim name)))))))))
(($ $values)
;; Values nodes are inserted by CPS optimization passes, so
;; we assume they are correct.
- ($continue k ,exp))
+ ($continue k src ,exp))
(($ $prompt)
- ($continue k ,exp))))
+ ($continue k src ,exp))))
(define (visit-cont cont)
(rewrite-cps-cont cont
- (($ $cont sym src ($ $kargs names syms body))
- (sym src ($kargs names syms ,(visit-term body))))
- (($ $cont sym src ($ $kclause arity body))
- (sym src ($kclause ,arity ,(visit-cont body))))
+ (($ $cont sym ($ $kargs names syms body))
+ (sym ($kargs names syms ,(visit-term body))))
+ (($ $cont sym ($ $kclause arity body))
+ (sym ($kclause ,arity ,(visit-cont body))))
(($ $cont)
,cont)))
(rewrite-cps-cont clause
- (($ $cont sym src ($ $kentry self tail clauses))
- (sym src ($kentry self ,tail ,(map visit-cont clauses)))))))
+ (($ $cont sym ($ $kentry self tail clauses))
+ (sym ($kentry self ,tail ,(map visit-cont clauses)))))))
(define (fix-arities fun)
(rewrite-cps-exp fun
- (($ $fun meta free body)
- ($fun meta free ,(fix-clause-arities body)))))
+ (($ $fun src meta free body)
+ ($fun src meta free ,(fix-clause-arities body)))))
diff --git a/module/language/cps/closure-conversion.scm
b/module/language/cps/closure-conversion.scm
index 05d9bdb..3cea53a 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -63,8 +63,8 @@ values in the term."
(let-gensyms (k* sym*)
(receive (exp free) (k sym*)
(values (build-cps-term
- ($letk ((k* #f ($kargs (sym*) (sym*) ,exp)))
- ($continue k* ($primcall 'free-ref (self sym)))))
+ ($letk ((k* ($kargs (sym*) (sym*) ,exp)))
+ ($continue k* #f ($primcall 'free-ref (self sym)))))
(cons sym free))))))
(define (convert-free-vars syms self bound k)
@@ -88,13 +88,13 @@ performed, and @var{outer-bound} is the list of bound
variables there."
(fold (lambda (free idx body)
(let-gensyms (k idxsym)
(build-cps-term
- ($letk ((k src ($kargs () () ,body)))
+ ($letk ((k ($kargs () () ,body)))
,(convert-free-var
free outer-self outer-bound
(lambda (free)
(values (build-cps-term
($letconst (('idx idxsym idx))
- ($continue k
+ ($continue k src
($primcall 'free-set! (v idxsym free)))))
'())))))))
body
@@ -123,19 +123,19 @@ convert functions to flat closures."
(values (build-cps-term ($letk ,conts ,body))
(union free free*)))))
- (($ $cont sym src ($ $kargs names syms body))
+ (($ $cont sym ($ $kargs names syms body))
(receive (body free) (cc body self (append syms bound))
- (values (build-cps-cont (sym src ($kargs names syms ,body)))
+ (values (build-cps-cont (sym ($kargs names syms ,body)))
free)))
- (($ $cont sym src ($ $kentry self tail clauses))
+ (($ $cont sym ($ $kentry self tail clauses))
(receive (clauses free) (cc* clauses self (list self))
- (values (build-cps-cont (sym src ($kentry self ,tail ,clauses)))
+ (values (build-cps-cont (sym ($kentry self ,tail ,clauses)))
free)))
- (($ $cont sym src ($ $kclause arity body))
+ (($ $cont sym ($ $kclause arity body))
(receive (body free) (cc body self bound)
- (values (build-cps-cont (sym src ($kclause ,arity ,body)))
+ (values (build-cps-cont (sym ($kclause ,arity ,body)))
free)))
(($ $cont)
@@ -153,76 +153,76 @@ convert functions to flat closures."
(free free))
(match in
(() (values (bindings body) free))
- (((name sym ($ $fun meta () fun-body)) . in)
+ (((name sym ($ $fun src meta () fun-body)) . in)
(receive (fun-body fun-free) (cc fun-body #f '())
(lp in
(lambda (body)
(let-gensyms (k)
(build-cps-term
- ($letk ((k #f ($kargs (name) (sym) ,(bindings
body))))
- ($continue k
- ($fun meta fun-free ,fun-body))))))
- (init-closure #f sym fun-free self bound body)
+ ($letk ((k ($kargs (name) (sym) ,(bindings body))))
+ ($continue k src
+ ($fun src meta fun-free ,fun-body))))))
+ (init-closure src sym fun-free self bound body)
(union free (difference fun-free bound))))))))))
- (($ $continue k ($ $var sym))
+ (($ $continue k src ($ $var sym))
(convert-free-var sym self bound
(lambda (sym)
- (values (build-cps-term ($continue k ($var sym)))
+ (values (build-cps-term ($continue k src ($var sym)))
'()))))
- (($ $continue k
+ (($ $continue k src
(or ($ $void)
($ $const)
($ $prim)))
(values exp '()))
- (($ $continue k ($ $fun meta () body))
+ (($ $continue k src ($ $fun src* meta () body))
(receive (body free) (cc body #f '())
(match free
(()
(values (build-cps-term
- ($continue k ($fun meta free ,body)))
+ ($continue k src ($fun src* meta free ,body)))
free))
(_
(values
(let-gensyms (kinit v)
(build-cps-term
- ($letk ((kinit #f ($kargs (v) (v)
- ,(init-closure #f v free self bound
- (build-cps-term
- ($continue k ($var v)))))))
- ($continue kinit ($fun meta free ,body)))))
+ ($letk ((kinit ($kargs (v) (v)
+ ,(init-closure src v free self bound
+ (build-cps-term
+ ($continue k src ($var
v)))))))
+ ($continue kinit src ($fun src* meta free ,body)))))
(difference free bound))))))
- (($ $continue k ($ $call proc args))
+ (($ $continue k src ($ $call proc args))
(convert-free-vars (cons proc args) self bound
(match-lambda
((proc . args)
(values (build-cps-term
- ($continue k ($call proc args)))
+ ($continue k src ($call proc args)))
'())))))
- (($ $continue k ($ $primcall name args))
+ (($ $continue k src ($ $primcall name args))
(convert-free-vars args self bound
(lambda (args)
(values (build-cps-term
- ($continue k ($primcall name args)))
+ ($continue k src ($primcall name args)))
'()))))
- (($ $continue k ($ $values args))
+ (($ $continue k src ($ $values args))
(convert-free-vars args self bound
(lambda (args)
(values (build-cps-term
- ($continue k ($values args)))
+ ($continue k src ($values args)))
'()))))
- (($ $continue k ($ $prompt escape? tag handler pop))
+ (($ $continue k src ($ $prompt escape? tag handler pop))
(convert-free-var
tag self bound
(lambda (tag)
(values (build-cps-term
- ($continue k ($prompt escape? tag handler pop)))
+ ($continue k src ($prompt escape? tag handler pop)))
'()))))
(_ (error "what" exp))))
@@ -237,37 +237,38 @@ convert functions to flat closures."
(rewrite-cps-term term
(($ $letk conts body)
($letk ,(map visit-cont conts) ,(visit-term body)))
- (($ $continue k ($ $primcall 'free-ref (closure sym)))
+ (($ $continue k src ($ $primcall 'free-ref (closure sym)))
,(let-gensyms (idx)
(build-cps-term
($letconst (('idx idx (free-index sym)))
- ($continue k ($primcall 'free-ref (closure idx)))))))
- (($ $continue k ($ $fun meta free body))
- ($continue k ($fun meta free ,(convert-to-indices body free))))
+ ($continue k src ($primcall 'free-ref (closure idx)))))))
+ (($ $continue k src ($ $fun src* meta free body))
+ ($continue k src
+ ($fun src* meta free ,(convert-to-indices body free))))
(($ $continue)
,term)))
(define (visit-cont cont)
(rewrite-cps-cont cont
- (($ $cont sym src ($ $kargs names syms body))
- (sym src ($kargs names syms ,(visit-term body))))
- (($ $cont sym src ($ $kclause arity body))
- (sym src ($kclause ,arity ,(visit-cont body))))
+ (($ $cont sym ($ $kargs names syms body))
+ (sym ($kargs names syms ,(visit-term body))))
+ (($ $cont sym ($ $kclause arity body))
+ (sym ($kclause ,arity ,(visit-cont body))))
;; Other kinds of continuations don't bind values and don't have
;; bodies.
(($ $cont)
,cont)))
(rewrite-cps-cont body
- (($ $cont sym src ($ $kentry self tail clauses))
- (sym src ($kentry self ,tail ,(map visit-cont clauses))))))
+ (($ $cont sym ($ $kentry self tail clauses))
+ (sym ($kentry self ,tail ,(map visit-cont clauses))))))
(define (convert-closures exp)
"Convert free reference in @var{exp} to primcalls to @code{free-ref},
and allocate and initialize flat closures."
(match exp
- (($ $fun meta () body)
+ (($ $fun src meta () body)
(receive (body free) (cc body #f '())
(unless (null? free)
(error "Expected no free vars in toplevel thunk" exp body free))
(build-cps-exp
- ($fun meta free ,(convert-to-indices body free)))))))
+ ($fun src meta free ,(convert-to-indices body free)))))))
diff --git a/module/language/cps/compile-rtl.scm
b/module/language/cps/compile-rtl.scm
index a842804..a3bef46 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -76,413 +76,405 @@
exp))
(define (collect-conts f cfa)
- (let ((srcv (make-vector (cfa-k-count cfa) #f))
- (contv (make-vector (cfa-k-count cfa) #f)))
+ (let ((contv (make-vector (cfa-k-count cfa) #f)))
(fold-local-conts
- (lambda (k src cont tail)
+ (lambda (k cont tail)
(let ((idx (cfa-k-idx cfa k #:default (lambda (k) #f))))
(when idx
- (when src
- (vector-set! srcv idx src))
(vector-set! contv idx cont))))
'()
(match f
- (($ $fun meta free entry)
+ (($ $fun src meta free entry)
entry)))
- (values srcv contv)))
+ contv))
(define (compile-fun f asm)
(let* ((dfg (compute-dfg f #:global? #f))
(cfa (analyze-control-flow f dfg))
- (allocation (allocate-slots f dfg)))
- (call-with-values (lambda () (collect-conts f cfa))
- (lambda (srcv contv)
- (define (lookup-cont k)
- (vector-ref contv (cfa-k-idx cfa k)))
-
- (define (maybe-emit-source n)
- (let ((src (vector-ref srcv n)))
- (when src
- (emit-source asm src))))
-
- (define (emit-label-and-maybe-source n)
- (emit-label asm (cfa-k-sym cfa n))
- (maybe-emit-source n))
-
- (define (immediate-u8? val)
- (and (integer? val) (exact? val) (<= 0 val 255)))
-
- (define (maybe-immediate-u8 sym)
- (call-with-values (lambda ()
- (lookup-maybe-constant-value sym allocation))
- (lambda (has-const? val)
- (and has-const? (immediate-u8? val) val))))
-
- (define (slot sym)
- (lookup-slot sym allocation))
-
- (define (constant sym)
- (lookup-constant-value sym allocation))
-
- (define (maybe-mov dst src)
- (unless (= dst src)
- (emit-mov asm dst src)))
-
- (define (maybe-load-constant slot src)
- (call-with-values (lambda ()
- (lookup-maybe-constant-value src allocation))
- (lambda (has-const? val)
- (and has-const?
- (begin
- (emit-load-constant asm slot val)
- #t)))))
-
- (define (compile-entry meta)
- (match (vector-ref contv 0)
- (($ $kentry self tail clauses)
- (emit-begin-program asm (cfa-k-sym cfa 0) meta)
- (maybe-emit-source 0)
- (let lp ((n 1)
- (ks (map (match-lambda (($ $cont k) k)) clauses)))
- (match ks
- (()
- (unless (= n (vector-length contv))
- (error "unexpected end of clauses"))
- (emit-end-program asm))
- ((k . ks)
- (unless (eq? (cfa-k-sym cfa n) k)
- (error "unexpected k" k))
- (lp (compile-clause n (and (pair? ks) (car ks)))
- ks)))))))
-
- (define (compile-clause n alternate)
- (match (vector-ref contv n)
- (($ $kclause ($ $arity req opt rest kw allow-other-keys?))
- (let ((kw-indices (map (match-lambda
- ((key name sym)
- (cons key (lookup-slot sym allocation))))
- kw))
- (nlocals (lookup-nlocals (cfa-k-sym cfa n) allocation)))
- (emit-label-and-maybe-source n)
- (emit-begin-kw-arity asm req opt rest kw-indices
- allow-other-keys? nlocals alternate)
- (let ((next (compile-body (1+ n) nlocals)))
- (emit-end-arity asm)
- next)))))
-
- (define (compile-body n nlocals)
- (let compile-cont ((n n))
- (if (= n (vector-length contv))
- n
- (match (vector-ref contv n)
- (($ $kclause) n)
- (($ $kargs _ _ term)
- (emit-label-and-maybe-source n)
- (let find-exp ((term term))
- (match term
- (($ $letk conts term)
- (find-exp term))
- (($ $continue k exp)
- (compile-expression n k exp nlocals)
- (compile-cont (1+ n))))))
- (_
- (emit-label-and-maybe-source n)
- (compile-cont (1+ n)))))))
-
- (define (compile-expression n k exp nlocals)
- (let* ((label (cfa-k-sym cfa n))
- (k-idx (cfa-k-idx cfa k))
- (fallthrough? (= k-idx (1+ n))))
- (define (maybe-emit-jump)
- (unless (= k-idx (1+ n))
- (emit-br asm k)))
- (match (vector-ref contv k-idx)
- (($ $ktail)
- (compile-tail label exp))
- (($ $kargs (name) (sym))
- (let ((dst (slot sym)))
- (when dst
- (compile-value label exp dst nlocals)))
- (maybe-emit-jump))
- (($ $kargs () ())
- (compile-effect label exp k nlocals)
- (maybe-emit-jump))
- (($ $kargs names syms)
- (compile-values label exp syms)
- (maybe-emit-jump))
- (($ $kif kt kf)
- (compile-test label exp kt kf
- (and (= k-idx (1+ n))
- (< (+ n 2) (cfa-k-count cfa))
- (cfa-k-sym cfa (+ n 2)))))
- (($ $ktrunc ($ $arity req () rest () #f) k)
- (compile-trunc label exp (length req) (and rest #t) nlocals)
- (unless (and (= k-idx (1+ n))
- (< (+ n 2) (cfa-k-count cfa))
- (eq? (cfa-k-sym cfa (+ n 2)) k))
- (emit-br asm k))))))
-
- (define (compile-tail label exp)
- ;; There are only three kinds of expressions in tail position:
- ;; tail calls, multiple-value returns, and single-value returns.
- (match exp
- (($ $call proc args)
- (for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
- (lookup-parallel-moves label allocation))
- (let ((tail-slots (cdr (iota (1+ (length args))))))
- (for-each maybe-load-constant tail-slots args))
- (emit-tail-call asm (1+ (length args))))
- (($ $values args)
- (let ((tail-slots (cdr (iota (1+ (length args))))))
- (for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
- (lookup-parallel-moves label allocation))
- (for-each maybe-load-constant tail-slots args))
- (emit-reset-frame asm (1+ (length args)))
- (emit-return-values asm))
- (($ $primcall 'return (arg))
- (emit-return asm (slot arg)))))
-
- (define (compile-value label exp dst nlocals)
- (match exp
- (($ $var sym)
- (maybe-mov dst (slot sym)))
- ;; FIXME: Remove ($var sym), replace with ($values (sym))
- (($ $values (arg))
- (or (maybe-load-constant dst arg)
- (maybe-mov dst (slot arg))))
- (($ $void)
- (emit-load-constant asm dst *unspecified*))
- (($ $const exp)
- (emit-load-constant asm dst exp))
- (($ $fun meta () ($ $cont k))
- (emit-load-static-procedure asm dst k))
- (($ $fun meta free ($ $cont k))
- (emit-make-closure asm dst k (length free)))
- (($ $call proc args)
- (let ((proc-slot (lookup-call-proc-slot label allocation))
- (nargs (length args)))
- (or (maybe-load-constant proc-slot proc)
- (maybe-mov proc-slot (slot proc)))
- (let lp ((n (1+ proc-slot)) (args args))
- (match args
- (()
- (emit-call asm proc-slot (+ nargs 1))
- (emit-receive asm dst proc-slot nlocals))
- ((arg . args)
- (or (maybe-load-constant n arg)
- (maybe-mov n (slot arg)))
- (lp (1+ n) args))))))
- (($ $primcall 'current-module)
- (emit-current-module asm dst))
- (($ $primcall 'cached-toplevel-box (scope name bound?))
- (emit-cached-toplevel-box asm dst (constant scope) (constant name)
- (constant bound?)))
- (($ $primcall 'cached-module-box (mod name public? bound?))
- (emit-cached-module-box asm dst (constant mod) (constant name)
- (constant public?) (constant bound?)))
- (($ $primcall 'resolve (name bound?))
- (emit-resolve asm dst (constant bound?) (slot name)))
- (($ $primcall 'free-ref (closure idx))
- (emit-free-ref asm dst (slot closure) (constant idx)))
- (($ $primcall 'make-vector (length init))
- (cond
- ((maybe-immediate-u8 length)
- => (lambda (length)
- (emit-constant-make-vector asm dst length (slot init))))
- (else
- (emit-make-vector asm dst (slot length) (slot init)))))
- (($ $primcall 'vector-ref (vector index))
- (cond
- ((maybe-immediate-u8 index)
- => (lambda (index)
- (emit-constant-vector-ref asm dst (slot vector) index)))
- (else
- (emit-vector-ref asm dst (slot vector) (slot index)))))
- (($ $primcall 'builtin-ref (name))
- (emit-builtin-ref asm dst (constant name)))
- (($ $primcall 'bv-u8-ref (bv idx))
- (emit-bv-u8-ref asm dst (slot bv) (slot idx)))
- (($ $primcall 'bv-u16-ref (bv idx))
- (emit-bv-u16-ref asm dst (slot bv) (slot idx)))
- (($ $primcall 'bv-s16-ref (bv idx))
- (emit-bv-s16-ref asm dst (slot bv) (slot idx)))
- (($ $primcall 'bv-u32-ref (bv idx val))
- (emit-bv-u32-ref asm dst (slot bv) (slot idx)))
- (($ $primcall 'bv-s32-ref (bv idx val))
- (emit-bv-s32-ref asm dst (slot bv) (slot idx)))
- (($ $primcall 'bv-u64-ref (bv idx val))
- (emit-bv-u64-ref asm dst (slot bv) (slot idx)))
- (($ $primcall 'bv-s64-ref (bv idx val))
- (emit-bv-s64-ref asm dst (slot bv) (slot idx)))
- (($ $primcall 'bv-f32-ref (bv idx val))
- (emit-bv-f32-ref asm dst (slot bv) (slot idx)))
- (($ $primcall 'bv-f64-ref (bv idx val))
- (emit-bv-f64-ref asm dst (slot bv) (slot idx)))
- (($ $primcall name args)
- ;; FIXME: Inline all the cases.
- (let ((inst (prim-rtl-instruction name)))
- (emit-text asm `((,inst ,dst ,@(map slot args))))))))
-
- (define (compile-effect label exp k nlocals)
- (match exp
- (($ $values ()) #f)
- (($ $prompt escape? tag handler pop)
- (match (lookup-cont handler)
- (($ $ktrunc ($ $arity req () rest () #f) khandler-body)
- (let ((receive-args (gensym "handler"))
- (nreq (length req))
- (proc-slot (lookup-call-proc-slot label allocation)))
- (emit-prompt asm (slot tag) escape? proc-slot receive-args)
- (emit-br asm k)
- (emit-label asm receive-args)
- (emit-receive-values asm proc-slot (->bool rest) nreq)
- (when rest
- (emit-bind-rest asm (+ proc-slot 1 nreq)))
- (for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
- (lookup-parallel-moves handler allocation))
- (emit-reset-frame asm nlocals)
- (emit-br asm khandler-body)))))
- (($ $primcall 'cache-current-module! (sym scope))
- (emit-cache-current-module! asm (slot sym) (constant scope)))
- (($ $primcall 'free-set! (closure idx value))
- (emit-free-set! asm (slot closure) (slot value) (constant idx)))
- (($ $primcall 'box-set! (box value))
- (emit-box-set! asm (slot box) (slot value)))
- (($ $primcall 'struct-set! (struct index value))
- (emit-struct-set! asm (slot struct) (slot index) (slot value)))
- (($ $primcall 'vector-set! (vector index value))
- (call-with-values (lambda ()
- (lookup-maybe-constant-value index
allocation))
- (lambda (has-const? index-val)
- (if (and has-const? (integer? index-val) (exact? index-val)
- (<= 0 index-val 255))
- (emit-constant-vector-set! asm (slot vector) index-val
- (slot value))
- (emit-vector-set! asm (slot vector) (slot index)
- (slot value))))))
- (($ $primcall 'variable-set! (var val))
- (emit-box-set! asm (slot var) (slot val)))
- (($ $primcall 'set-car! (pair value))
- (emit-set-car! asm (slot pair) (slot value)))
- (($ $primcall 'set-cdr! (pair value))
- (emit-set-cdr! asm (slot pair) (slot value)))
- (($ $primcall 'define! (sym value))
- (emit-define! asm (slot sym) (slot value)))
- (($ $primcall 'push-fluid (fluid val))
- (emit-push-fluid asm (slot fluid) (slot val)))
- (($ $primcall 'pop-fluid ())
- (emit-pop-fluid asm))
- (($ $primcall 'wind (winder unwinder))
- (emit-wind asm (slot winder) (slot unwinder)))
- (($ $primcall 'bv-u8-set! (bv idx val))
- (emit-bv-u8-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'bv-u16-set! (bv idx val))
- (emit-bv-u16-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'bv-s16-set! (bv idx val))
- (emit-bv-s16-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'bv-u32-set! (bv idx val))
- (emit-bv-u32-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'bv-s32-set! (bv idx val))
- (emit-bv-s32-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'bv-u64-set! (bv idx val))
- (emit-bv-u64-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'bv-s64-set! (bv idx val))
- (emit-bv-s64-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'bv-f32-set! (bv idx val))
- (emit-bv-f32-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'bv-f64-set! (bv idx val))
- (emit-bv-f64-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'unwind ())
- (emit-unwind asm))))
-
- (define (compile-values label exp syms)
- (match exp
- (($ $values args)
- (for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
- (lookup-parallel-moves label allocation))
- (for-each maybe-load-constant (map slot syms) args))))
-
- (define (compile-test label exp kt kf next-label)
- (define (unary op sym)
- (cond
- ((eq? kt next-label)
- (op asm (slot sym) #t kf))
- (else
- (op asm (slot sym) #f kt)
- (unless (eq? kf next-label)
- (emit-br asm kf)))))
- (define (binary op a b)
- (cond
- ((eq? kt next-label)
- (op asm (slot a) (slot b) #t kf))
- (else
- (op asm (slot a) (slot b) #f kt)
- (unless (eq? kf next-label)
- (emit-br asm kf)))))
- (match exp
- (($ $var sym) (unary emit-br-if-true sym))
- (($ $primcall 'null? (a)) (unary emit-br-if-null a))
- (($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
- (($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
- (($ $primcall 'struct? (a)) (unary emit-br-if-struct a))
- (($ $primcall 'char? (a)) (unary emit-br-if-char a))
- (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a))
- (($ $primcall 'variable? (a)) (unary emit-br-if-variable a))
- (($ $primcall 'vector? (a)) (unary emit-br-if-vector a))
- (($ $primcall 'string? (a)) (unary emit-br-if-string a))
- (($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a))
- ;; Add more TC7 tests here. Keep in sync with
- ;; *branching-primcall-arities* in (language cps primitives) and
- ;; the set of macro-instructions in assembly.scm.
- (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
- (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
- (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
- (($ $primcall '< (a b)) (binary emit-br-if-< a b))
- (($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
- (($ $primcall '= (a b)) (binary emit-br-if-= a b))
- (($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
- (($ $primcall '> (a b)) (binary emit-br-if-< b a))))
-
- (define (compile-trunc label exp nreq rest? nlocals)
- (match exp
- (($ $call proc args)
- (let ((proc-slot (lookup-call-proc-slot label allocation))
- (nargs (length args)))
- (or (maybe-load-constant proc-slot proc)
- (maybe-mov proc-slot (slot proc)))
- (let lp ((n (1+ proc-slot)) (args args))
- (match args
- (()
- (emit-call asm proc-slot (+ nargs 1))
- ;; FIXME: Only allow more values if there is a rest arg.
- ;; Express values truncation by the presence of an
- ;; unused rest arg instead of implicitly.
- (emit-receive-values asm proc-slot #t nreq)
- (when rest?
- (emit-bind-rest asm (+ proc-slot 1 nreq)))
- (for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
- (lookup-parallel-moves label allocation))
- (emit-reset-frame asm nlocals))
- ((arg . args)
- (or (maybe-load-constant n arg)
- (maybe-mov n (slot arg)))
- (lp (1+ n) args))))))))
-
- (match f
- (($ $fun meta free ($ $cont k src ($ $kentry self tail clauses)))
- (compile-entry (or meta '()))))))))
+ (allocation (allocate-slots f dfg))
+ (contv (collect-conts f cfa)))
+ (define (lookup-cont k)
+ (vector-ref contv (cfa-k-idx cfa k)))
+
+ (define (immediate-u8? val)
+ (and (integer? val) (exact? val) (<= 0 val 255)))
+
+ (define (maybe-immediate-u8 sym)
+ (call-with-values (lambda ()
+ (lookup-maybe-constant-value sym allocation))
+ (lambda (has-const? val)
+ (and has-const? (immediate-u8? val) val))))
+
+ (define (slot sym)
+ (lookup-slot sym allocation))
+
+ (define (constant sym)
+ (lookup-constant-value sym allocation))
+
+ (define (maybe-mov dst src)
+ (unless (= dst src)
+ (emit-mov asm dst src)))
+
+ (define (maybe-load-constant slot src)
+ (call-with-values (lambda ()
+ (lookup-maybe-constant-value src allocation))
+ (lambda (has-const? val)
+ (and has-const?
+ (begin
+ (emit-load-constant asm slot val)
+ #t)))))
+
+ (define (compile-entry meta)
+ (match (vector-ref contv 0)
+ (($ $kentry self tail clauses)
+ (emit-begin-program asm (cfa-k-sym cfa 0) meta)
+ (let lp ((n 1)
+ (ks (map (match-lambda (($ $cont k) k)) clauses)))
+ (match ks
+ (()
+ (unless (= n (vector-length contv))
+ (error "unexpected end of clauses"))
+ (emit-end-program asm))
+ ((k . ks)
+ (unless (eq? (cfa-k-sym cfa n) k)
+ (error "unexpected k" k))
+ (lp (compile-clause n (and (pair? ks) (car ks)))
+ ks)))))))
+
+ (define (compile-clause n alternate)
+ (match (vector-ref contv n)
+ (($ $kclause ($ $arity req opt rest kw allow-other-keys?))
+ (let* ((kw-indices (map (match-lambda
+ ((key name sym)
+ (cons key (lookup-slot sym allocation))))
+ kw))
+ (k (cfa-k-sym cfa n))
+ (nlocals (lookup-nlocals k allocation)))
+ (emit-label asm k)
+ (emit-begin-kw-arity asm req opt rest kw-indices
+ allow-other-keys? nlocals alternate)
+ (let ((next (compile-body (1+ n) nlocals)))
+ (emit-end-arity asm)
+ next)))))
+
+ (define (compile-body n nlocals)
+ (let compile-cont ((n n))
+ (if (= n (vector-length contv))
+ n
+ (match (vector-ref contv n)
+ (($ $kclause) n)
+ (($ $kargs _ _ term)
+ (emit-label asm (cfa-k-sym cfa n))
+ (let find-exp ((term term))
+ (match term
+ (($ $letk conts term)
+ (find-exp term))
+ (($ $continue k src exp)
+ (when src
+ (emit-source asm src))
+ (compile-expression n k exp nlocals)
+ (compile-cont (1+ n))))))
+ (_
+ (emit-label asm (cfa-k-sym cfa n))
+ (compile-cont (1+ n)))))))
+
+ (define (compile-expression n k exp nlocals)
+ (let* ((label (cfa-k-sym cfa n))
+ (k-idx (cfa-k-idx cfa k))
+ (fallthrough? (= k-idx (1+ n))))
+ (define (maybe-emit-jump)
+ (unless (= k-idx (1+ n))
+ (emit-br asm k)))
+ (match (vector-ref contv k-idx)
+ (($ $ktail)
+ (compile-tail label exp))
+ (($ $kargs (name) (sym))
+ (let ((dst (slot sym)))
+ (when dst
+ (compile-value label exp dst nlocals)))
+ (maybe-emit-jump))
+ (($ $kargs () ())
+ (compile-effect label exp k nlocals)
+ (maybe-emit-jump))
+ (($ $kargs names syms)
+ (compile-values label exp syms)
+ (maybe-emit-jump))
+ (($ $kif kt kf)
+ (compile-test label exp kt kf
+ (and (= k-idx (1+ n))
+ (< (+ n 2) (cfa-k-count cfa))
+ (cfa-k-sym cfa (+ n 2)))))
+ (($ $ktrunc ($ $arity req () rest () #f) k)
+ (compile-trunc label exp (length req) (and rest #t) nlocals)
+ (unless (and (= k-idx (1+ n))
+ (< (+ n 2) (cfa-k-count cfa))
+ (eq? (cfa-k-sym cfa (+ n 2)) k))
+ (emit-br asm k))))))
+
+ (define (compile-tail label exp)
+ ;; There are only three kinds of expressions in tail position:
+ ;; tail calls, multiple-value returns, and single-value returns.
+ (match exp
+ (($ $call proc args)
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves label allocation))
+ (let ((tail-slots (cdr (iota (1+ (length args))))))
+ (for-each maybe-load-constant tail-slots args))
+ (emit-tail-call asm (1+ (length args))))
+ (($ $values args)
+ (let ((tail-slots (cdr (iota (1+ (length args))))))
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves label allocation))
+ (for-each maybe-load-constant tail-slots args))
+ (emit-reset-frame asm (1+ (length args)))
+ (emit-return-values asm))
+ (($ $primcall 'return (arg))
+ (emit-return asm (slot arg)))))
+
+ (define (compile-value label exp dst nlocals)
+ (match exp
+ (($ $var sym)
+ (maybe-mov dst (slot sym)))
+ ;; FIXME: Remove ($var sym), replace with ($values (sym))
+ (($ $values (arg))
+ (or (maybe-load-constant dst arg)
+ (maybe-mov dst (slot arg))))
+ (($ $void)
+ (emit-load-constant asm dst *unspecified*))
+ (($ $const exp)
+ (emit-load-constant asm dst exp))
+ (($ $fun src meta () ($ $cont k))
+ (emit-load-static-procedure asm dst k))
+ (($ $fun src meta free ($ $cont k))
+ (emit-make-closure asm dst k (length free)))
+ (($ $call proc args)
+ (let ((proc-slot (lookup-call-proc-slot label allocation))
+ (nargs (length args)))
+ (or (maybe-load-constant proc-slot proc)
+ (maybe-mov proc-slot (slot proc)))
+ (let lp ((n (1+ proc-slot)) (args args))
+ (match args
+ (()
+ (emit-call asm proc-slot (+ nargs 1))
+ (emit-receive asm dst proc-slot nlocals))
+ ((arg . args)
+ (or (maybe-load-constant n arg)
+ (maybe-mov n (slot arg)))
+ (lp (1+ n) args))))))
+ (($ $primcall 'current-module)
+ (emit-current-module asm dst))
+ (($ $primcall 'cached-toplevel-box (scope name bound?))
+ (emit-cached-toplevel-box asm dst (constant scope) (constant name)
+ (constant bound?)))
+ (($ $primcall 'cached-module-box (mod name public? bound?))
+ (emit-cached-module-box asm dst (constant mod) (constant name)
+ (constant public?) (constant bound?)))
+ (($ $primcall 'resolve (name bound?))
+ (emit-resolve asm dst (constant bound?) (slot name)))
+ (($ $primcall 'free-ref (closure idx))
+ (emit-free-ref asm dst (slot closure) (constant idx)))
+ (($ $primcall 'make-vector (length init))
+ (cond
+ ((maybe-immediate-u8 length)
+ => (lambda (length)
+ (emit-constant-make-vector asm dst length (slot init))))
+ (else
+ (emit-make-vector asm dst (slot length) (slot init)))))
+ (($ $primcall 'vector-ref (vector index))
+ (cond
+ ((maybe-immediate-u8 index)
+ => (lambda (index)
+ (emit-constant-vector-ref asm dst (slot vector) index)))
+ (else
+ (emit-vector-ref asm dst (slot vector) (slot index)))))
+ (($ $primcall 'builtin-ref (name))
+ (emit-builtin-ref asm dst (constant name)))
+ (($ $primcall 'bv-u8-ref (bv idx))
+ (emit-bv-u8-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-u16-ref (bv idx))
+ (emit-bv-u16-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-s16-ref (bv idx))
+ (emit-bv-s16-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-u32-ref (bv idx val))
+ (emit-bv-u32-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-s32-ref (bv idx val))
+ (emit-bv-s32-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-u64-ref (bv idx val))
+ (emit-bv-u64-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-s64-ref (bv idx val))
+ (emit-bv-s64-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-f32-ref (bv idx val))
+ (emit-bv-f32-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-f64-ref (bv idx val))
+ (emit-bv-f64-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall name args)
+ ;; FIXME: Inline all the cases.
+ (let ((inst (prim-rtl-instruction name)))
+ (emit-text asm `((,inst ,dst ,@(map slot args))))))))
+
+ (define (compile-effect label exp k nlocals)
+ (match exp
+ (($ $values ()) #f)
+ (($ $prompt escape? tag handler pop)
+ (match (lookup-cont handler)
+ (($ $ktrunc ($ $arity req () rest () #f) khandler-body)
+ (let ((receive-args (gensym "handler"))
+ (nreq (length req))
+ (proc-slot (lookup-call-proc-slot label allocation)))
+ (emit-prompt asm (slot tag) escape? proc-slot receive-args)
+ (emit-br asm k)
+ (emit-label asm receive-args)
+ (emit-receive-values asm proc-slot (->bool rest) nreq)
+ (when rest
+ (emit-bind-rest asm (+ proc-slot 1 nreq)))
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves handler allocation))
+ (emit-reset-frame asm nlocals)
+ (emit-br asm khandler-body)))))
+ (($ $primcall 'cache-current-module! (sym scope))
+ (emit-cache-current-module! asm (slot sym) (constant scope)))
+ (($ $primcall 'free-set! (closure idx value))
+ (emit-free-set! asm (slot closure) (slot value) (constant idx)))
+ (($ $primcall 'box-set! (box value))
+ (emit-box-set! asm (slot box) (slot value)))
+ (($ $primcall 'struct-set! (struct index value))
+ (emit-struct-set! asm (slot struct) (slot index) (slot value)))
+ (($ $primcall 'vector-set! (vector index value))
+ (call-with-values (lambda ()
+ (lookup-maybe-constant-value index allocation))
+ (lambda (has-const? index-val)
+ (if (and has-const? (integer? index-val) (exact? index-val)
+ (<= 0 index-val 255))
+ (emit-constant-vector-set! asm (slot vector) index-val
+ (slot value))
+ (emit-vector-set! asm (slot vector) (slot index)
+ (slot value))))))
+ (($ $primcall 'variable-set! (var val))
+ (emit-box-set! asm (slot var) (slot val)))
+ (($ $primcall 'set-car! (pair value))
+ (emit-set-car! asm (slot pair) (slot value)))
+ (($ $primcall 'set-cdr! (pair value))
+ (emit-set-cdr! asm (slot pair) (slot value)))
+ (($ $primcall 'define! (sym value))
+ (emit-define! asm (slot sym) (slot value)))
+ (($ $primcall 'push-fluid (fluid val))
+ (emit-push-fluid asm (slot fluid) (slot val)))
+ (($ $primcall 'pop-fluid ())
+ (emit-pop-fluid asm))
+ (($ $primcall 'wind (winder unwinder))
+ (emit-wind asm (slot winder) (slot unwinder)))
+ (($ $primcall 'bv-u8-set! (bv idx val))
+ (emit-bv-u8-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-u16-set! (bv idx val))
+ (emit-bv-u16-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-s16-set! (bv idx val))
+ (emit-bv-s16-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-u32-set! (bv idx val))
+ (emit-bv-u32-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-s32-set! (bv idx val))
+ (emit-bv-s32-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-u64-set! (bv idx val))
+ (emit-bv-u64-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-s64-set! (bv idx val))
+ (emit-bv-s64-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-f32-set! (bv idx val))
+ (emit-bv-f32-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-f64-set! (bv idx val))
+ (emit-bv-f64-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'unwind ())
+ (emit-unwind asm))))
+
+ (define (compile-values label exp syms)
+ (match exp
+ (($ $values args)
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves label allocation))
+ (for-each maybe-load-constant (map slot syms) args))))
+
+ (define (compile-test label exp kt kf next-label)
+ (define (unary op sym)
+ (cond
+ ((eq? kt next-label)
+ (op asm (slot sym) #t kf))
+ (else
+ (op asm (slot sym) #f kt)
+ (unless (eq? kf next-label)
+ (emit-br asm kf)))))
+ (define (binary op a b)
+ (cond
+ ((eq? kt next-label)
+ (op asm (slot a) (slot b) #t kf))
+ (else
+ (op asm (slot a) (slot b) #f kt)
+ (unless (eq? kf next-label)
+ (emit-br asm kf)))))
+ (match exp
+ (($ $var sym) (unary emit-br-if-true sym))
+ (($ $primcall 'null? (a)) (unary emit-br-if-null a))
+ (($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
+ (($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
+ (($ $primcall 'struct? (a)) (unary emit-br-if-struct a))
+ (($ $primcall 'char? (a)) (unary emit-br-if-char a))
+ (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a))
+ (($ $primcall 'variable? (a)) (unary emit-br-if-variable a))
+ (($ $primcall 'vector? (a)) (unary emit-br-if-vector a))
+ (($ $primcall 'string? (a)) (unary emit-br-if-string a))
+ (($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a))
+ ;; Add more TC7 tests here. Keep in sync with
+ ;; *branching-primcall-arities* in (language cps primitives) and
+ ;; the set of macro-instructions in assembly.scm.
+ (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
+ (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
+ (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
+ (($ $primcall '< (a b)) (binary emit-br-if-< a b))
+ (($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
+ (($ $primcall '= (a b)) (binary emit-br-if-= a b))
+ (($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
+ (($ $primcall '> (a b)) (binary emit-br-if-< b a))))
+
+ (define (compile-trunc label exp nreq rest? nlocals)
+ (match exp
+ (($ $call proc args)
+ (let ((proc-slot (lookup-call-proc-slot label allocation))
+ (nargs (length args)))
+ (or (maybe-load-constant proc-slot proc)
+ (maybe-mov proc-slot (slot proc)))
+ (let lp ((n (1+ proc-slot)) (args args))
+ (match args
+ (()
+ (emit-call asm proc-slot (+ nargs 1))
+ ;; FIXME: Only allow more values if there is a rest arg.
+ ;; Express values truncation by the presence of an
+ ;; unused rest arg instead of implicitly.
+ (emit-receive-values asm proc-slot #t nreq)
+ (when rest?
+ (emit-bind-rest asm (+ proc-slot 1 nreq)))
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves label allocation))
+ (emit-reset-frame asm nlocals))
+ ((arg . args)
+ (or (maybe-load-constant n arg)
+ (maybe-mov n (slot arg)))
+ (lp (1+ n) args))))))))
+
+ (match f
+ (($ $fun src meta free ($ $cont k ($ $kentry self tail clauses)))
+ ;; FIXME: src on kentry instead?
+ (when src
+ (emit-source asm src))
+ (compile-entry (or meta '()))))))
(define (visit-funs proc exp)
(match exp
- (($ $continue _ exp)
+ (($ $continue _ _ exp)
(visit-funs proc exp))
- (($ $fun meta free body)
+ (($ $fun src meta free body)
(proc exp)
(visit-funs proc body))
@@ -490,13 +482,13 @@
(visit-funs proc body)
(for-each (lambda (cont) (visit-funs proc cont)) conts))
- (($ $cont sym src ($ $kargs names syms body))
+ (($ $cont sym ($ $kargs names syms body))
(visit-funs proc body))
- (($ $cont sym src ($ $kclause arity body))
+ (($ $cont sym ($ $kclause arity body))
(visit-funs proc body))
- (($ $cont sym src ($ $kentry self tail clauses))
+ (($ $cont sym ($ $kentry self tail clauses))
(for-each (lambda (clause) (visit-funs proc clause)) clauses))
(_ (values))))
diff --git a/module/language/cps/constructors.scm
b/module/language/cps/constructors.scm
index b8d4e96..d7ff0ab 100644
--- a/module/language/cps/constructors.scm
+++ b/module/language/cps/constructors.scm
@@ -32,12 +32,12 @@
(define (inline-constructors fun)
(define (visit-cont cont)
(rewrite-cps-cont cont
- (($ $cont sym src ($ $kargs names syms body))
- (sym src ($kargs names syms ,(visit-term body))))
- (($ $cont sym src ($ $kentry self tail clauses))
- (sym src ($kentry self ,tail ,(map visit-cont clauses))))
- (($ $cont sym src ($ $kclause arity body))
- (sym src ($kclause ,arity ,(visit-cont body))))
+ (($ $cont sym ($ $kargs names syms body))
+ (sym ($kargs names syms ,(visit-term body))))
+ (($ $cont sym ($ $kentry self tail clauses))
+ (sym ($kentry self ,tail ,(map visit-cont clauses))))
+ (($ $cont sym ($ $kclause arity body))
+ (sym ($kclause ,arity ,(visit-cont body))))
(($ $cont)
,cont)))
(define (visit-term term)
@@ -48,51 +48,51 @@
(($ $letrec names syms funs body)
($letrec names syms (map inline-constructors funs)
,(visit-term body)))
- (($ $continue k ($ $primcall 'list args))
+ (($ $continue k src ($ $primcall 'list args))
,(let-gensyms (kvalues val)
(build-cps-term
- ($letk ((kvalues #f ($kargs ('val) (val)
- ($continue k
- ($primcall 'values (val))))))
+ ($letk ((kvalues ($kargs ('val) (val)
+ ($continue k src
+ ($primcall 'values (val))))))
,(let lp ((args args) (k kvalues))
(match args
(()
(build-cps-term
- ($continue k ($const '()))))
+ ($continue k src ($const '()))))
((arg . args)
(let-gensyms (ktail tail)
(build-cps-term
- ($letk ((ktail #f ($kargs ('tail) (tail)
- ($continue k
- ($primcall 'cons (arg tail))))))
+ ($letk ((ktail ($kargs ('tail) (tail)
+ ($continue k src
+ ($primcall 'cons (arg tail))))))
,(lp args ktail)))))))))))
- (($ $continue k ($ $primcall 'vector args))
+ (($ $continue k src ($ $primcall 'vector args))
,(let-gensyms (kalloc vec len init)
(define (initialize args n)
(match args
(()
(build-cps-term
- ($continue k ($primcall 'values (vec)))))
+ ($continue k src ($primcall 'values (vec)))))
((arg . args)
(let-gensyms (knext idx)
(build-cps-term
- ($letk ((knext #f ($kargs () ()
- ,(initialize args (1+ n)))))
+ ($letk ((knext ($kargs () ()
+ ,(initialize args (1+ n)))))
($letconst (('idx idx n))
- ($continue knext
+ ($continue knext src
($primcall 'vector-set! (vec idx arg))))))))))
(build-cps-term
- ($letk ((kalloc #f ($kargs ('vec) (vec)
- ,(initialize args 0))))
+ ($letk ((kalloc ($kargs ('vec) (vec)
+ ,(initialize args 0))))
($letconst (('len len (length args))
('init init #f))
- ($continue kalloc
+ ($continue kalloc src
($primcall 'make-vector (len init))))))))
- (($ $continue k (and fun ($ $fun)))
- ($continue k ,(inline-constructors fun)))
+ (($ $continue k src (and fun ($ $fun)))
+ ($continue k src ,(inline-constructors fun)))
(($ $continue)
,term)))
(rewrite-cps-exp fun
- (($ $fun meta free body)
- ($fun meta free ,(visit-cont body)))))
+ (($ $fun src meta free body)
+ ($fun src meta free ,(visit-cont body)))))
diff --git a/module/language/cps/contification.scm
b/module/language/cps/contification.scm
index da73206..6e8fe62 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -95,7 +95,7 @@
;; target continuation. Otherwise return #f.
(define (call-target use proc)
(match (find-call (lookup-cont use cont-table))
- (($ $continue k ($ $call proc* args))
+ (($ $continue k src ($ $call proc* args))
(and (eq? proc proc*) (not (memq proc args)) (applicable? proc args)
k))
(_ #f)))
@@ -141,7 +141,7 @@
;; bail.
(($ $kentry self tail clauses)
(match clauses
- ((($ $cont _ _ ($ $kclause arity ($ $cont kargs))))
+ ((($ $cont _ ($ $kclause arity ($ $cont kargs))))
kargs)
(_ #f)))
(_ scope)))))
@@ -168,15 +168,15 @@
(define (visit-fun term)
(match term
- (($ $fun meta free body)
+ (($ $fun src meta free body)
(visit-cont body))))
(define (visit-cont cont)
(match cont
- (($ $cont sym src ($ $kargs _ _ body))
+ (($ $cont sym ($ $kargs _ _ body))
(visit-term body sym))
- (($ $cont sym src ($ $kentry self tail clauses))
+ (($ $cont sym ($ $kentry self tail clauses))
(for-each visit-cont clauses))
- (($ $cont sym src ($ $kclause arity body))
+ (($ $cont sym ($ $kclause arity body))
(visit-cont body))
(($ $cont)
#t)))
@@ -199,7 +199,7 @@
(if (null? rec)
'()
(list rec)))
- (((and elt (n s ($ $fun meta free ($ $cont kentry))))
+ (((and elt (n s ($ $fun src meta free ($ $cont kentry))))
. nsf)
(if (recursive? kentry)
(lp nsf (cons elt rec))
@@ -208,11 +208,11 @@
(match component
(((name sym fun) ...)
(match fun
- ((($ $fun meta free
- ($ $cont fun-k _
+ ((($ $fun src meta free
+ ($ $cont fun-k
($ $kentry self
- ($ $cont tail-k _ ($ $ktail))
- (($ $cont _ _ ($ $kclause arity body))
+ ($ $cont tail-k ($ $ktail))
+ (($ $cont _ ($ $kclause arity body))
...))))
...)
(unless (contify-funs term-k sym self tail-k arity body)
@@ -220,13 +220,13 @@
(visit-term body term-k)
(for-each visit-component
(split-components (map list names syms funs))))
- (($ $continue k exp)
+ (($ $continue k src exp)
(match exp
- (($ $fun meta free
- ($ $cont fun-k _
+ (($ $fun src meta free
+ ($ $cont fun-k
($ $kentry self
- ($ $cont tail-k _ ($ $ktail))
- (($ $cont _ _ ($ $kclause arity body)) ...))))
+ ($ $cont tail-k ($ $ktail))
+ (($ $cont _ ($ $kclause arity body)) ...))))
(if (and=> (bound-symbol k)
(lambda (sym)
(contify-fun term-k sym self tail-k arity body)))
@@ -238,7 +238,7 @@
(values call-substs cont-substs fun-elisions cont-splices)))
(define (apply-contification fun call-substs cont-substs fun-elisions
cont-splices)
- (define (contify-call proc args)
+ (define (contify-call src proc args)
(and=> (assq-ref call-substs proc)
(lambda (clauses)
(let lp ((clauses clauses))
@@ -247,11 +247,11 @@
(((($ $arity req () #f () #f) . k) . clauses)
(if (= (length req) (length args))
(build-cps-term
- ($continue k
+ ($continue k src
($values args)))
(lp clauses)))
((_ . clauses) (lp clauses)))))))
- (define (continue k exp)
+ (define (continue k src exp)
(define (lookup-return-cont k)
(match (assq-ref cont-substs k)
(#f k)
@@ -260,13 +260,13 @@
;; We are contifying this return. It must be a call or a
;; primcall to values, return, or return-values.
(if (eq? k k*)
- (build-cps-term ($continue k ,exp))
+ (build-cps-term ($continue k src ,exp))
(rewrite-cps-term exp
(($ $primcall 'return (val))
- ($continue k* ($primcall 'values (val))))
+ ($continue k* src ($primcall 'values (val))))
(($ $values vals)
- ($continue k* ($primcall 'values vals)))
- (_ ($continue k* ,exp))))))
+ ($continue k* src ($primcall 'values vals)))
+ (_ ($continue k* src ,exp))))))
(define (splice-continuations term-k term)
(match (hashq-ref cont-splices term-k)
(#f term)
@@ -283,19 +283,19 @@
,body)))))))
(define (visit-fun term)
(rewrite-cps-exp term
- (($ $fun meta free body)
- ($fun meta free ,(visit-cont body)))))
+ (($ $fun src meta free body)
+ ($fun src meta free ,(visit-cont body)))))
(define (visit-cont cont)
(rewrite-cps-cont cont
(($ $cont (? (cut assq <> fun-elisions)))
;; This cont gets inlined in place of the $fun.
,#f)
- (($ $cont sym src ($ $kargs names syms body))
- (sym src ($kargs names syms ,(visit-term body sym))))
- (($ $cont sym src ($ $kentry self tail clauses))
- (sym src ($kentry self ,tail ,(map visit-cont clauses))))
- (($ $cont sym src ($ $kclause arity body))
- (sym src ($kclause ,arity ,(visit-cont body))))
+ (($ $cont sym ($ $kargs names syms body))
+ (sym ($kargs names syms ,(visit-term body sym))))
+ (($ $cont sym ($ $kentry self tail clauses))
+ (sym ($kentry self ,tail ,(map visit-cont clauses))))
+ (($ $cont sym ($ $kclause arity body))
+ (sym ($kclause ,arity ,(visit-cont body))))
(($ $cont)
,cont)))
(define (visit-term term term-k)
@@ -324,7 +324,7 @@
(((names syms funs) ...)
($letrec names syms (map visit-fun funs)
,(visit-term body term-k)))))
- (($ $continue k exp)
+ (($ $continue k src exp)
(splice-continuations
term-k
(match exp
@@ -335,11 +335,11 @@
(($ $kargs (_) (_) body)
(visit-term body k))))
(else
- (continue k (visit-fun exp)))))
+ (continue k src (visit-fun exp)))))
(($ $call proc args)
- (or (contify-call proc args)
- (continue k exp)))
- (_ (continue k exp)))))))
+ (or (contify-call src proc args)
+ (continue k src exp)))
+ (_ (continue k src exp)))))))
(visit-fun fun))
(define (contify fun)
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index faefcd3..4d38d52 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -73,14 +73,14 @@
print-dfa))
(define (build-cont-table fun)
- (fold-conts (lambda (k src cont table)
+ (fold-conts (lambda (k cont table)
(hashq-set! table k cont)
table)
(make-hash-table)
fun))
(define (build-local-cont-table cont)
- (fold-local-conts (lambda (k src cont table)
+ (fold-local-conts (lambda (k cont table)
(hashq-set! table k cont)
table)
(make-hash-table)
@@ -206,10 +206,10 @@
(reachable-preds k-map block-preds))))
(make-cfa k-map order preds)))
(match fun
- (($ $fun meta free
- ($ $cont kentry src
+ (($ $fun src meta free
+ ($ $cont kentry
(and entry
- ($ $kentry self ($ $cont ktail _ tail) clauses))))
+ ($ $kentry self ($ $cont ktail tail) clauses))))
(if reverse?
(build-cfa ktail block-preds block-succs)
(build-cfa kentry block-succs block-preds)))))
@@ -549,13 +549,13 @@
(map (cut hashq-ref mapping <>)
((block-accessor blocks accessor) k))))
(match fun
- (($ $fun meta free
+ (($ $fun src meta free
(and entry
- ($ $cont kentry src ($ $kentry self ($ $cont ktail _ tail)))))
+ ($ $cont kentry ($ $kentry self ($ $cont ktail tail)))))
(call-with-values (lambda () (make-variable-mapping (dfg-use-maps dfg)))
(lambda (var-map nvars)
(define (fold-all-conts f seed)
- (fold-local-conts (lambda (k src cont seed) (f k seed))
+ (fold-local-conts (lambda (k cont seed) (f k seed))
seed entry))
(let* ((blocks (dfg-blocks dfg))
(order (reverse-post-order ktail
@@ -662,7 +662,7 @@
(define (recur exp)
(visit exp exp-k))
(match exp
- (($ $letk (($ $cont k src cont) ...) body)
+ (($ $letk (($ $cont k cont) ...) body)
;; Set up recursive environment before visiting cont bodies.
(for-each (lambda (cont k)
(declare-block! k cont exp-k))
@@ -688,7 +688,7 @@
(for-each (cut visit-fun <> conts blocks use-maps global?) funs)
(visit body exp-k))
- (($ $continue k exp)
+ (($ $continue k src exp)
(use-k! k)
(match exp
(($ $var sym)
@@ -726,10 +726,10 @@
(_ #f)))))
(match fun
- (($ $fun meta free
- ($ $cont kentry src
+ (($ $fun src meta free
+ ($ $cont kentry
(and entry
- ($ $kentry self ($ $cont ktail _ tail) clauses))))
+ ($ $kentry self ($ $cont ktail tail) clauses))))
(declare-block! kentry entry #f 0)
(add-def! #f self kentry)
@@ -737,8 +737,8 @@
(for-each
(match-lambda
- (($ $cont kclause _
- (and clause ($ $kclause arity ($ $cont kbody _ body))))
+ (($ $cont kclause
+ (and clause ($ $kclause arity ($ $cont kbody body))))
(declare-block! kclause clause kentry)
(link-blocks! kentry kclause)
@@ -811,7 +811,7 @@
(define (call-expression call)
(match call
- (($ $continue k exp) exp)))
+ (($ $continue k src exp) exp)))
(define (find-expression term)
(call-expression (find-call term)))
@@ -827,7 +827,7 @@
(match (find-defining-expression sym dfg)
(($ $const val)
(values #t val))
- (($ $continue k ($ $void))
+ (($ $continue k src ($ $void))
(values #t *unspecified*))
(else
(values #f #f))))
diff --git a/module/language/cps/elide-values.scm
b/module/language/cps/elide-values.scm
index b738b1c..0168ab8 100644
--- a/module/language/cps/elide-values.scm
+++ b/module/language/cps/elide-values.scm
@@ -37,15 +37,15 @@
(define (elide-values fun)
(let ((conts (build-local-cont-table
- (match fun (($ $fun meta free body) body)))))
+ (match fun (($ $fun src meta free body) body)))))
(define (visit-cont cont)
(rewrite-cps-cont cont
- (($ $cont sym src ($ $kargs names syms body))
- (sym src ($kargs names syms ,(visit-term body))))
- (($ $cont sym src ($ $kentry self tail clauses))
- (sym src ($kentry self ,tail ,(map visit-cont clauses))))
- (($ $cont sym src ($ $kclause arity body))
- (sym src ($kclause ,arity ,(visit-cont body))))
+ (($ $cont sym ($ $kargs names syms body))
+ (sym ($kargs names syms ,(visit-term body))))
+ (($ $cont sym ($ $kentry self tail clauses))
+ (sym ($kentry self ,tail ,(map visit-cont clauses))))
+ (($ $cont sym ($ $kclause arity body))
+ (sym ($kclause ,arity ,(visit-cont body))))
(($ $cont)
,cont)))
(define (visit-term term)
@@ -56,27 +56,27 @@
(($ $letrec names syms funs body)
($letrec names syms (map elide-values funs)
,(visit-term body)))
- (($ $continue k ($ $primcall 'values vals))
+ (($ $continue k src ($ $primcall 'values vals))
,(rewrite-cps-term (lookup-cont k conts)
(($ $ktail)
- ($continue k ($values vals)))
+ ($continue k src ($values vals)))
(($ $ktrunc ($ $arity req () rest () #f) kargs)
,(if (or rest (< (length vals) (length req)))
term
(let ((vals (list-head vals (length req))))
(build-cps-term
- ($continue kargs ($values vals))))))
+ ($continue kargs src ($values vals))))))
(($ $kargs args)
,(if (< (length vals) (length args))
term
(let ((vals (list-head vals (length args))))
(build-cps-term
- ($continue k ($values vals))))))))
- (($ $continue k (and fun ($ $fun)))
- ($continue k ,(elide-values fun)))
+ ($continue k src ($values vals))))))))
+ (($ $continue k src (and fun ($ $fun)))
+ ($continue k src ,(elide-values fun)))
(($ $continue)
,term)))
(rewrite-cps-exp fun
- (($ $fun meta free body)
- ($fun meta free ,(visit-cont body))))))
+ (($ $fun src meta free body)
+ ($fun src meta free ,(visit-cont body))))))
diff --git a/module/language/cps/reify-primitives.scm
b/module/language/cps/reify-primitives.scm
index 2b1a101..68de294 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -39,8 +39,8 @@
('name name-sym name)
('public? public?-sym public?)
('bound? bound?-sym bound?))
- ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
- ($continue kbox
+ ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
+ ($continue kbox src
($primcall 'cached-module-box
(module-sym name-sym public?-sym bound?-sym))))))))
@@ -72,63 +72,61 @@
((class-of @slot-ref @slot-set!) '(oop goops))
(else '(guile))))
-(define (primitive-ref name k)
+(define (primitive-ref name k src)
(module-box #f (primitive-module name) name #f #t
(lambda (box)
(build-cps-term
- ($continue k ($primcall 'box-ref (box)))))))
+ ($continue k src ($primcall 'box-ref (box)))))))
-(define (builtin-ref idx k)
+(define (builtin-ref idx k src)
(let-gensyms (idx-sym)
(build-cps-term
($letconst (('idx idx-sym idx))
- ($continue k
+ ($continue k src
($primcall 'builtin-ref (idx-sym)))))))
(define (reify-clause ktail)
(let-gensyms (kclause kbody wna false str eol kthrow throw)
(build-cps-cont
- (kclause #f ($kclause ('() '() #f '() #f)
- (kbody
- #f
- ($kargs () ()
- ($letconst (('wna wna 'wrong-number-of-args)
- ('false false #f)
- ('str str "Wrong number of arguments")
- ('eol eol '()))
- ($letk ((kthrow
- #f
- ($kargs ('throw) (throw)
- ($continue ktail
- ($call throw
- (wna false str eol false))))))
- ,(primitive-ref 'throw kthrow))))))))))
+ (kclause ($kclause ('() '() #f '() #f)
+ (kbody
+ ($kargs () ()
+ ($letconst (('wna wna 'wrong-number-of-args)
+ ('false false #f)
+ ('str str "Wrong number of arguments")
+ ('eol eol '()))
+ ($letk ((kthrow
+ ($kargs ('throw) (throw)
+ ($continue ktail #f
+ ($call throw
+ (wna false str eol false))))))
+ ,(primitive-ref 'throw kthrow #f))))))))))
;; FIXME: Operate on one function at a time, for efficiency.
(define (reify-primitives fun)
(let ((conts (build-cont-table fun)))
(define (visit-fun term)
(rewrite-cps-exp term
- (($ $fun meta free body)
- ($fun meta free ,(visit-cont body)))))
+ (($ $fun src meta free body)
+ ($fun src meta free ,(visit-cont body)))))
(define (visit-cont cont)
(rewrite-cps-cont cont
- (($ $cont sym src ($ $kargs names syms body))
- (sym src ($kargs names syms ,(visit-term body))))
- (($ $cont sym src ($ $kentry self (and tail ($ $cont ktail)) ()))
+ (($ $cont sym ($ $kargs names syms body))
+ (sym ($kargs names syms ,(visit-term body))))
+ (($ $cont sym ($ $kentry self (and tail ($ $cont ktail)) ()))
;; A case-lambda with no clauses. Reify a clause.
- (sym src ($kentry self ,tail (,(reify-clause ktail)))))
- (($ $cont sym src ($ $kentry self tail clauses))
- (sym src ($kentry self ,tail ,(map visit-cont clauses))))
- (($ $cont sym src ($ $kclause arity body))
- (sym src ($kclause ,arity ,(visit-cont body))))
+ (sym ($kentry self ,tail (,(reify-clause ktail)))))
+ (($ $cont sym ($ $kentry self tail clauses))
+ (sym ($kentry self ,tail ,(map visit-cont clauses))))
+ (($ $cont sym ($ $kclause arity body))
+ (sym ($kclause ,arity ,(visit-cont body))))
(($ $cont)
,cont)))
(define (visit-term term)
(rewrite-cps-term term
(($ $letk conts body)
($letk ,(map visit-cont conts) ,(visit-term body)))
- (($ $continue k exp)
+ (($ $continue k src exp)
,(match exp
(($ $prim name)
(match (lookup-cont k conts)
@@ -136,14 +134,14 @@
(cond
((builtin-name->index name)
=> (lambda (idx)
- (builtin-ref idx k)))
- (else (primitive-ref name k))))
- (_ (build-cps-term ($continue k ($void))))))
+ (builtin-ref idx k src)))
+ (else (primitive-ref name k src))))
+ (_ (build-cps-term ($continue k src ($void))))))
(($ $fun)
- (build-cps-term ($continue k ,(visit-fun exp))))
+ (build-cps-term ($continue k src ,(visit-fun exp))))
(($ $primcall 'call-thunk/no-inline (proc))
(build-cps-term
- ($continue k ($call proc ()))))
+ ($continue k src ($call proc ()))))
(($ $primcall name args)
(cond
((or (prim-rtl-instruction name) (branching-primitive? name))
@@ -152,13 +150,13 @@
(else
(let-gensyms (k* v)
(build-cps-term
- ($letk ((k* #f ($kargs (v) (v)
- ($continue k ($call v args)))))
+ ($letk ((k* ($kargs (v) (v)
+ ($continue k src ($call v args)))))
,(cond
((builtin-name->index name)
=> (lambda (idx)
- (builtin-ref idx k*)))
- (else (primitive-ref name k*)))))))))
+ (builtin-ref idx k* src)))
+ (else (primitive-ref name k* src)))))))))
(_ term)))))
(visit-fun fun)))
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index c0d21d9..580d0f9 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -235,7 +235,7 @@ are comparable with eqv?. A tmp slot may be used."
(define nlocals (compute-slot live-slots #f))
(define nargs
(match clause
- (($ $cont _ _ ($ $kclause _ ($ $cont _ _ ($ $kargs names syms))))
+ (($ $cont _ ($ $kclause _ ($ $cont _ ($ $kargs names syms))))
(length syms))))
(define (allocate! sym k hint live-slots)
@@ -310,7 +310,7 @@ are comparable with eqv?. A tmp slot may be used."
live-slots))
(match cont
- (($ $kclause arity ($ $cont k src body))
+ (($ $kclause arity ($ $cont k body))
(visit-cont body k live-slots))
(($ $kargs names syms body)
@@ -328,12 +328,12 @@ are comparable with eqv?. A tmp slot may be used."
(($ $letk conts body)
(let ((live-slots (visit-term body label live-slots)))
(for-each (match-lambda
- (($ $cont k src cont)
+ (($ $cont k cont)
(visit-cont cont k live-slots)))
conts))
live-slots)
- (($ $continue k exp)
+ (($ $continue k src exp)
(visit-exp exp label k live-slots))))
(define (visit-exp exp label k live-slots)
@@ -420,12 +420,12 @@ are comparable with eqv?. A tmp slot may be used."
(_ live-slots)))
(match clause
- (($ $cont k _ body)
+ (($ $cont k body)
(visit-cont body k live-slots)
(hashq-set! allocation k nlocals))))
(match fun
- (($ $fun meta free ($ $cont k _ ($ $kentry self tail clauses)))
+ (($ $fun src meta free ($ $cont k ($ $kentry self tail clauses)))
(let* ((dfa (compute-live-variables fun dfg))
(allocation (make-hash-table))
(slots (make-vector (dfa-var-count dfa) #f))
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index 76fad51..3772f21 100644
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -71,7 +71,7 @@
(define (visit-clause clause k-env v-env)
(match clause
- (($ $cont kclause src*
+ (($ $cont kclause
($ $kclause
($ $arity
((? symbol? req) ...)
@@ -79,9 +79,7 @@
(and rest (or #f (? symbol?)))
(((? keyword? kw) (? symbol? kwname) (? symbol? kwsym)) ...)
(or #f #t))
- ($ $cont kbody src (and body ($ $kargs names syms _)))))
- (check-src src*)
- (check-src src)
+ ($ $cont kbody (and body ($ $kargs names syms _)))))
(for-each (lambda (sym)
(unless (memq sym syms)
(error "bad keyword sym" sym)))
@@ -98,9 +96,9 @@
(define (visit-fun fun k-env v-env)
(match fun
- (($ $fun meta ((? symbol? free) ...)
- ($ $cont kbody src
- ($ $kentry (? symbol? self) ($ $cont ktail _ ($ $ktail))
clauses)))
+ (($ $fun src meta ((? symbol? free) ...)
+ ($ $cont kbody
+ ($ $kentry (? symbol? self) ($ $cont ktail ($ $ktail)) clauses)))
(when (and meta (not (and (list? meta) (and-map pair? meta))))
(error "meta should be alist" meta))
(for-each (cut check-var <> v-env) free)
@@ -142,9 +140,8 @@
(define (visit-term term k-env v-env)
(match term
- (($ $letk (($ $cont (? symbol? k) src cont) ...) body)
+ (($ $letk (($ $cont (? symbol? k) cont) ...) body)
(let ((k-env (add-env k k-env)))
- (for-each check-src src)
(for-each (cut visit-cont-body <> k-env v-env) cont)
(visit-term body k-env v-env)))
@@ -155,8 +152,9 @@
(for-each (cut visit-fun <> k-env v-env) fun)
(visit-term body k-env v-env)))
- (($ $continue k exp)
+ (($ $continue k src exp)
(check-var k k-env)
+ (check-src src)
(visit-expression exp k-env v-env))
(_
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index 493e1e7..c705694 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -81,18 +81,18 @@
(build-cps-term
($letconst (('name name-sym name)
('bound? bound?-sym bound?))
- ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
+ ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
,(match (current-topbox-scope)
(#f
(build-cps-term
- ($continue kbox
+ ($continue kbox src
($primcall 'resolve
(name-sym bound?-sym)))))
(scope
(let-gensyms (scope-sym)
(build-cps-term
($letconst (('scope scope-sym scope))
- ($continue kbox
+ ($continue kbox src
($primcall 'cached-toplevel-box
(scope-sym name-sym bound?-sym)))))))))))))
@@ -103,8 +103,8 @@
('name name-sym name)
('public? public?-sym public?)
('bound? bound?-sym bound?))
- ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
- ($continue kbox
+ ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
+ ($continue kbox src
($primcall 'cached-module-box
(module-sym name-sym public?-sym bound?-sym))))))))
@@ -112,11 +112,11 @@
(let-gensyms (module scope-sym kmodule)
(build-cps-term
($letconst (('scope scope-sym scope))
- ($letk ((kmodule src ($kargs ('module) (module)
- ($continue k
- ($primcall 'cache-current-module!
- (module scope-sym))))))
- ($continue kmodule
+ ($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)
@@ -162,8 +162,8 @@
(let-gensyms (unbound ktest)
(build-cps-term
($letconst (('unbound unbound (pointer->scm (make-pointer
unbound-bits))))
- ($letk ((ktest src ($kif kt kf)))
- ($continue ktest
+ ($letk ((ktest ($kif kt kf)))
+ ($continue ktest src
($primcall 'eq? (sym unbound))))))))
(define (init-default-value name sym subst init body)
@@ -174,19 +174,19 @@
(if box?
(let-gensyms (kbox phi)
(build-cps-term
- ($letk ((kbox src ($kargs (name) (phi)
- ($continue k ($primcall 'box (phi))))))
+ ($letk ((kbox ($kargs (name) (phi)
+ ($continue k src ($primcall 'box (phi))))))
,(make-body kbox))))
(make-body k)))
(let-gensyms (knext kbound kunbound)
(build-cps-term
- ($letk ((knext src ($kargs (name) (subst-sym) ,body)))
+ ($letk ((knext ($kargs (name) (subst-sym) ,body)))
,(maybe-box
knext
(lambda (k)
(build-cps-term
- ($letk ((kbound src ($kargs () () ($continue k ($var sym))))
- (kunbound src ($kargs () () ,(convert init k
subst))))
+ ($letk ((kbound ($kargs () () ($continue k src ($var sym))))
+ (kunbound ($kargs () () ,(convert init k subst))))
,(unbound? src sym kunbound kbound))))))))))))
;; exp k-name alist -> term
@@ -199,16 +199,15 @@
((box #t)
(let-gensyms (kunboxed unboxed)
(build-cps-term
- ($letk ((kunboxed src ($kargs ('unboxed) (unboxed) ,(k
unboxed))))
- ($continue kunboxed ($primcall 'box-ref (box)))))))
+ ($letk ((kunboxed ($kargs ('unboxed) (unboxed) ,(k unboxed))))
+ ($continue kunboxed src ($primcall 'box-ref (box)))))))
((subst #f) (k subst))
(#f (k sym))))
(else
- (let ((src (tree-il-src exp)))
- (let-gensyms (karg arg)
- (build-cps-term
- ($letk ((karg src ($kargs ('arg) (arg) ,(k arg))))
- ,(convert exp karg subst))))))))
+ (let-gensyms (karg arg)
+ (build-cps-term
+ ($letk ((karg ($kargs ('arg) (arg) ,(k arg))))
+ ,(convert exp karg subst)))))))
;; (exp ...) ((v-name ...) -> term) -> term
(define (convert-args exps k)
(match exps
@@ -224,25 +223,25 @@
((box #t)
(let-gensyms (k)
(build-cps-term
- ($letk ((k #f ($kargs (name) (box) ,body)))
- ($continue k ($primcall 'box (sym)))))))
+ ($letk ((k ($kargs (name) (box) ,body)))
+ ($continue k #f ($primcall 'box (sym)))))))
(else body)))
(match exp
(($ <lexical-ref> src name sym)
(match (assq-ref subst sym)
- ((box #t) (build-cps-term ($continue k ($primcall 'box-ref (box)))))
- ((subst #f) (build-cps-term ($continue k ($var subst))))
- (#f (build-cps-term ($continue k ($var sym))))))
+ ((box #t) (build-cps-term ($continue k src ($primcall 'box-ref (box)))))
+ ((subst #f) (build-cps-term ($continue k src ($var subst))))
+ (#f (build-cps-term ($continue k src ($var sym))))))
(($ <void> src)
- (build-cps-term ($continue k ($void))))
+ (build-cps-term ($continue k src ($void))))
(($ <const> src exp)
- (build-cps-term ($continue k ($const exp))))
+ (build-cps-term ($continue k src ($const exp))))
(($ <primitive-ref> src name)
- (build-cps-term ($continue k ($prim name))))
+ (build-cps-term ($continue k src ($prim name))))
(($ <lambda> fun-src meta body)
(let ()
@@ -260,10 +259,8 @@
(let-gensyms (kclause kargs)
(build-cps-cont
(kclause
- src
($kclause ,arity
(kargs
- src
($kargs names gensyms
,(fold-formals
(lambda (name sym init body)
@@ -276,15 +273,13 @@
(if (current-topbox-scope)
(let-gensyms (kentry self ktail)
(build-cps-term
- ($continue k
- ($fun meta '()
- (kentry fun-src
- ($kentry self (ktail #f ($ktail))
- ,(convert-clauses body ktail)))))))
+ ($continue k fun-src
+ ($fun fun-src meta '()
+ (kentry ($kentry self (ktail ($ktail))
+ ,(convert-clauses body ktail)))))))
(let-gensyms (scope kscope)
(build-cps-term
- ($letk ((kscope fun-src
- ($kargs () ()
+ ($letk ((kscope ($kargs () ()
,(parameterize ((current-topbox-scope scope))
(convert exp k subst)))))
,(capture-toplevel-scope fun-src scope kscope)))))))
@@ -293,7 +288,7 @@
(module-box
src mod name public? #t
(lambda (box)
- (build-cps-term ($continue k ($primcall 'box-ref (box)))))))
+ (build-cps-term ($continue k src ($primcall 'box-ref (box)))))))
(($ <module-set> src mod name public? exp)
(convert-arg exp
@@ -301,13 +296,14 @@
(module-box
src mod name public? #f
(lambda (box)
- (build-cps-term ($continue k ($primcall 'box-set! (box val)))))))))
+ (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 ($primcall 'box-ref (box)))))))
+ (build-cps-term ($continue k src ($primcall 'box-ref (box)))))))
(($ <toplevel-set> src name exp)
(convert-arg exp
@@ -315,7 +311,8 @@
(toplevel-box
src name #f
(lambda (box)
- (build-cps-term ($continue k ($primcall 'box-set! (box val)))))))))
+ (build-cps-term
+ ($continue k src ($primcall 'box-set! (box val)))))))))
(($ <toplevel-define> src name exp)
(convert-arg exp
@@ -323,13 +320,13 @@
(let-gensyms (kname name-sym)
(build-cps-term
($letconst (('name name-sym name))
- ($continue k ($primcall 'define! (name-sym val)))))))))
+ ($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 ($call proc args)))))))
+ (build-cps-term ($continue k src ($call proc args)))))))
(($ <primcall> src name args)
(cond
@@ -389,22 +386,21 @@
(match args
(()
(build-cps-term
- ($continue k ($const '()))))
+ ($continue k src ($const '()))))
((arg . args)
(let-gensyms (ktail tail)
(build-cps-term
- ($letk ((ktail src
- ($kargs ('tail) (tail)
+ ($letk ((ktail ($kargs ('tail) (tail)
,(convert-arg arg
(lambda (head)
(build-cps-term
- ($continue k
+ ($continue k src
($primcall 'cons (head tail)))))))))
,(lp args ktail))))))))
(else
(convert-args args
(lambda (args)
- (build-cps-term ($continue k ($primcall name args))))))))
+ (build-cps-term ($continue k src ($primcall name args))))))))
;; Prompts with inline handlers.
(($ <prompt> src escape-only? tag body
@@ -427,42 +423,38 @@
(let ((hnames (append hreq (if hrest (list hrest) '()))))
(let-gensyms (khargs khbody kret kprim prim kpop krest vals kbody)
(build-cps-term
- ($letk* ((khbody hsrc ($kargs hnames hsyms
- ,(fold box-bound-var
- (convert hbody k subst)
- hnames hsyms)))
- (khargs hsrc ($ktrunc hreq hrest khbody))
- (kpop src
- ($kargs ('rest) (vals)
+ ;; FIXME: Attach hsrc to $ktrunc.
+ ($letk* ((khbody ($kargs hnames hsyms
+ ,(fold box-bound-var
+ (convert hbody k subst)
+ hnames hsyms)))
+ (khargs ($ktrunc hreq hrest khbody))
+ (kpop ($kargs ('rest) (vals)
($letk ((kret
- src
($kargs () ()
($letk ((kprim
- src
($kargs ('prim) (prim)
- ($continue k
+ ($continue k src
($primcall 'apply
(prim
vals))))))
- ($continue kprim
+ ($continue kprim src
($prim 'values))))))
- ($continue kret
+ ($continue kret src
($primcall 'unwind ())))))
- (krest src ($ktrunc '() 'rest kpop)))
+ (krest ($ktrunc '() 'rest kpop)))
,(if escape-only?
(build-cps-term
- ($letk ((kbody (tree-il-src body)
- ($kargs () ()
+ ($letk ((kbody ($kargs () ()
,(convert body krest subst))))
- ($continue kbody ($prompt #t tag khargs kpop))))
+ ($continue kbody src ($prompt #t tag khargs kpop))))
(convert-arg body
(lambda (thunk)
(build-cps-term
- ($letk ((kbody (tree-il-src body)
- ($kargs () ()
- ($continue krest
+ ($letk ((kbody ($kargs () ()
+ ($continue krest (tree-il-src
body)
($primcall 'call-thunk/no-inline
(thunk))))))
- ($continue kbody
+ ($continue kbody (tree-il-src body)
($prompt #f tag khargs kpop))))))))))))))
;; Eta-convert prompts without inline handlers.
@@ -503,7 +495,8 @@
(convert-args (cons tag args)
(lambda (args*)
(build-cps-term
- ($continue k ($primcall 'abort-to-prompt args*))))))
+ ($continue k src
+ ($primcall 'abort-to-prompt args*))))))
(($ <abort> src tag args tail)
(convert-args (append (list (make-primitive-ref #f 'abort-to-prompt)
@@ -512,24 +505,24 @@
(list tail))
(lambda (args*)
(build-cps-term
- ($continue k ($primcall 'apply args*))))))
+ ($continue k src ($primcall 'apply args*))))))
(($ <conditional> src test consequent alternate)
(let-gensyms (kif kt kf)
(build-cps-term
- ($letk* ((kt (tree-il-src consequent) ($kargs () ()
- ,(convert consequent k
subst)))
- (kf (tree-il-src alternate) ($kargs () ()
- ,(convert alternate k subst)))
- (kif src ($kif kt kf)))
+ ($letk* ((kt ($kargs () () ,(convert consequent k subst)))
+ (kf ($kargs () () ,(convert alternate k subst)))
+ (kif ($kif kt kf)))
,(match test
(($ <primcall> src (? branching-primitive? name) args)
(convert-args args
(lambda (args)
- (build-cps-term ($continue kif ($primcall name args))))))
+ (build-cps-term
+ ($continue kif src ($primcall name args))))))
(_ (convert-arg test
(lambda (test)
- (build-cps-term ($continue kif ($var test)))))))))))
+ (build-cps-term
+ ($continue kif src ($var test)))))))))))
(($ <lexical-set> src name gensym exp)
(convert-arg exp
@@ -537,14 +530,14 @@
(match (assq-ref subst gensym)
((box #t)
(build-cps-term
- ($continue k ($primcall 'box-set! (box exp)))))))))
+ ($continue k src ($primcall 'box-set! (box exp)))))))))
(($ <seq> src head tail)
(let-gensyms (ktrunc kseq)
(build-cps-term
- ($letk* ((kseq (tree-il-src tail) ($kargs () ()
- ,(convert tail k subst)))
- (ktrunc src ($ktrunc '() #f kseq)))
+ ($letk* ((kseq ($kargs () ()
+ ,(convert tail k subst)))
+ (ktrunc ($ktrunc '() #f kseq)))
,(convert head ktrunc subst)))))
(($ <let> src names syms vals body)
@@ -554,9 +547,9 @@
(((name . names) (sym . syms) (val . vals))
(let-gensyms (klet)
(build-cps-term
- ($letk ((klet src ($kargs (name) (sym)
- ,(box-bound-var name sym
- (lp names syms vals)))))
+ ($letk ((klet ($kargs (name) (sym)
+ ,(box-bound-var name sym
+ (lp names syms vals)))))
,(convert val klet subst))))))))
(($ <fix> src names gensyms funs body)
@@ -568,15 +561,15 @@
gensyms
(map (lambda (fun)
(match (convert fun k subst)
- (($ $continue _ (and fun ($ $fun)))
+ (($ $continue _ _ (and fun ($ $fun)))
fun)))
funs)
,(convert body k subst))))
(let-gensyms (scope kscope)
(build-cps-term
- ($letk ((kscope src ($kargs () ()
- ,(parameterize ((current-topbox-scope
scope))
- (convert exp k subst)))))
+ ($letk ((kscope ($kargs () ()
+ ,(parameterize ((current-topbox-scope scope))
+ (convert exp k subst)))))
,(capture-toplevel-scope src scope kscope))))))
(($ <let-values> src exp
@@ -584,11 +577,11 @@
(let ((names (append req (if rest (list rest) '()))))
(let-gensyms (ktrunc kargs)
(build-cps-term
- ($letk* ((kargs src ($kargs names syms
- ,(fold box-bound-var
- (convert body k subst)
- names syms)))
- (ktrunc src ($ktrunc req rest kargs)))
+ ($letk* ((kargs ($kargs names syms
+ ,(fold box-bound-var
+ (convert body k subst)
+ names syms)))
+ (ktrunc ($ktrunc req rest kargs)))
,(convert exp ktrunc subst))))))))
(define (build-subst exp)
@@ -628,16 +621,14 @@ indicates that the replacement variable is in a box."
(let ((src (tree-il-src exp)))
(let-gensyms (kinit init ktail kclause kbody)
(build-cps-exp
- ($fun '() '()
- (kinit src
- ($kentry init
- (ktail #f ($ktail))
- ((kclause src
- ($kclause ('() '() #f '() #f)
- (kbody src
- ($kargs () ()
- ,(convert exp ktail
- (build-subst exp))))))))))))))
+ ($fun src '() '()
+ (kinit ($kentry init
+ (ktail ($ktail))
+ ((kclause
+ ($kclause ('() '() #f '() #f)
+ (kbody ($kargs () ()
+ ,(convert exp ktail
+ (build-subst exp))))))))))))))
(define *comp-module* (make-fluid))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index f1663c0..d6b417f 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -1638,7 +1638,7 @@ it will be added to the GC roots at runtime."
(define (put-sleb128 port val)
(let lp ((val val))
- (if (<= 0 (+ val 64) 128)
+ (if (<= 0 (+ val 64) 127)
(put-u8 port (logand val #x7f))
(begin
(put-u8 port (logior #x80 (logand val #x7f)))
@@ -1761,15 +1761,18 @@ it will be added to the GC roots at runtime."
;; uleb128 for each of directory the file was found in, the
;; modification time, and the file's size in bytes. We pass
;; zero for the latter three fields.
- (vlist-for-each (match-lambda
- ((file . code)
- (put-bytevector line-port (string->utf8 file))
- (put-u8 line-port 0)
- (put-uleb128 line-port 0) ; directory
- (put-uleb128 line-port 0) ; mtime
- (put-uleb128 line-port 0) ; size
- ))
- files)
+ (vlist-fold-right
+ (lambda (pair seed)
+ (match pair
+ ((file . code)
+ (put-bytevector line-port (string->utf8 file))
+ (put-u8 line-port 0)
+ (put-uleb128 line-port 0) ; directory
+ (put-uleb128 line-port 0) ; mtime
+ (put-uleb128 line-port 0))) ; size
+ seed)
+ #f
+ files)
(put-u8 line-port 0) ; 0 byte terminating file list.
;; Patch prologue length.
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index a0f1122..e5eb9be 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -530,8 +530,16 @@ section of the ELF image. Returns an ELF symbol, or
@code{#f}."
(line-prog-advance prog)))
(lambda (pc file line col)
(if (and pc (< pc high-pc))
- (lp (cons (make-source/dwarf (+ pc base) file line col)
- sources))
+ ;; For the first source, it's probable that the
+ ;; address of the line program is before the
+ ;; low-pc, since the line program is for the
+ ;; entire compilation unit, and there are no
+ ;; redundant "rows" in the line program.
+ ;; Therefore in that case use the addr of low-pc
+ ;; instead of the one we got back.
+ (let ((addr (+ (if (null? sources) low-pc pc) base)))
+ (lp (cons (make-source/dwarf addr file line col)
+ sources)))
(reverse sources))))))
(else '())))))
(else '())))
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index 619b167..ee202b6 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -1,5 +1,5 @@
;;;; compiler.test --- tests for the compiler -*- scheme -*-
-;;;; Copyright (C) 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013 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
@@ -19,8 +19,8 @@
#:use-module (test-suite lib)
#:use-module (test-suite guile-test)
#:use-module (system base compile)
- #:use-module ((system vm program) #:select (make-program
- program-sources source:addr)))
+ #:use-module ((system vm objcode) #:select (load-thunk-from-memory))
+ #:use-module ((system vm program) #:select (program-sources source:addr)))
(define read-and-compile
(@@ (system base compile) read-and-compile))
@@ -97,7 +97,7 @@
#f)
(install-reader!)
this-should-be-ignored")))
- (and (eq? ((make-program (read-and-compile input)))
+ (and (eq? ((load-thunk-from-memory (read-and-compile input)))
'ok)
(eq? r (fluid-ref current-reader)))))
diff --git a/test-suite/tests/dwarf.test b/test-suite/tests/dwarf.test
index b999ab1..2d2a45e 100644
--- a/test-suite/tests/dwarf.test
+++ b/test-suite/tests/dwarf.test
@@ -62,19 +62,21 @@
(pass-if-equal 2 (source-column source)))
(match (find-program-sources (rtl-program-code qux))
- ((s1 s2)
+ ((s1 s2 s3)
(pass-if-equal "foo.scm" (source-file s1))
(pass-if-equal 0 (source-line s1))
(pass-if-equal 1 (source-line-for-user s1))
(pass-if-equal 0 (source-column s1))
- ;; FIXME: For some reason the source location for the + isn't
- ;; getting propagated.
-
(pass-if-equal "foo.scm" (source-file s2))
(pass-if-equal 1 (source-line s2))
(pass-if-equal 2 (source-line-for-user s2))
- (pass-if-equal 8 (source-column s2)))
+ (pass-if-equal 8 (source-column s2))
+
+ (pass-if-equal "foo.scm" (source-file s3))
+ (pass-if-equal 1 (source-line s3))
+ (pass-if-equal 2 (source-line-for-user s3))
+ (pass-if-equal 2 (source-column s3)))
(sources
(error "unexpected sources" sources)))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, wip-rtl-halloween, updated. v2.1.0-340-g4b8d21c,
Andy Wingo <=