cwebber pushed a commit to branch compile-to-js-merge
in repository guile.
commit c2589b5c48da8bdcb4690fc5124e9bb6a54b0b22
Author: Ian Price <[email protected]>
AuthorDate: Tue Jun 20 19:05:59 2017 +0100
Rebuild nested scopes for js continuations
* module/language/cps/compile-js.scm (compile-cont, compile-clause):
Rebuild nested scopes for $kargs, using dominator information.
(compile-fun, compile-clauses): Pass down dominator information.
---
module/language/cps/compile-js.scm | 62 ++++++++++++++++++++++++++------------
1 file changed, 42 insertions(+), 20 deletions(-)
diff --git a/module/language/cps/compile-js.scm
b/module/language/cps/compile-js.scm
index e750935..363814c 100644
--- a/module/language/cps/compile-js.scm
+++ b/module/language/cps/compile-js.scm
@@ -5,6 +5,7 @@
#:use-module ((language js-il)
#:renamer (lambda (x) (if (eqv? x 'make-prompt) 'make-prompt*
x)))
#:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (append-map))
#:export (compile-js))
(define intmap-select (@@ (language cps compile-bytecode) intmap-select))
@@ -27,12 +28,13 @@
(define (compile-fun cps kfun)
+ (define doms (compute-dom-edges (compute-idoms cps kfun)))
(match (intmap-ref cps kfun)
(($ $kfun src meta self tail clause)
(make-function
(make-id self)
(make-kid tail)
- (compile-clauses cps clause self)))))
+ (compile-clauses cps doms clause self)))))
(define (extract-and-compile-conts cps)
@@ -57,22 +59,21 @@
(intmap-fold step cps '()))
-(define (compile-clauses cps clause self)
+(define (compile-clauses cps doms clause self)
;; FIXME: This duplicates all the conts in each clause, and requires
;; the inliner to remove them. A better solution is to change the
;; function type to contain a separate map of conts, but this requires
;; more code changes, and is should constitute a separate commit.
- (define function-conts (extract-and-compile-conts cps))
(let loop ((clause clause))
(match (intmap-ref cps clause)
(($ $kclause arity body #f)
`((,(make-kid clause)
,(arity->params arity self)
- ,(compile-clause cps arity body self function-conts))))
+ ,(compile-clause cps doms arity body self))))
(($ $kclause arity body next)
`((,(make-kid clause)
,(arity->params arity self)
- ,(compile-clause cps arity body self function-conts))
+ ,(compile-clause cps doms arity body self))
. ,(loop next))))))
@@ -91,27 +92,48 @@
allow-other-keys?))))
-(define (compile-clause cps arity body self bindings)
+(define (compile-clause cps doms arity body self)
(match arity
(($ $arity req opt rest ((_ _ kw-syms) ...) _)
(let ((ids (map make-id
(append req opt kw-syms (if rest (list rest) '())))))
(make-continuation
(cons (make-id self) ids)
- (make-local bindings (make-continue (make-kid body) ids)))))))
-
-
-(define (compile-cont cps cont)
- (match (intmap-ref cps cont)
- ;; The term in a $kargs is always a $continue
- (($ $kargs names syms ($ $continue k src exp))
- (make-continuation (map make-id syms) (compile-exp exp k)))
- (($ $kreceive ($ $arity req _ (? symbol? rest) _ _) k2)
- (let ((ids (map make-id (append req (list rest)))))
- (make-continuation ids (make-continue (make-kid k2) ids))))
- (($ $kreceive ($ $arity req _ #f _ _) k2)
- (let ((ids (map make-id req)))
- (make-continuation ids (make-continue (make-kid k2) ids))))))
+ (make-local (list (cons (make-kid body) (compile-cont cps doms body)))
+ (make-continue (make-kid body) ids)))))))
+
+(define (compile-cont cps doms cont)
+ (define (redominate label exp)
+ ;; This ensures that functions which are dominated by a $kargs [e.g.
+ ;; because they need its arguments] are moved into its body, and so
+ ;; we get correct scoping.
+ (define (find&compile-dominated label)
+ (append-map (lambda (label)
+ (match (intmap-ref cps label)
+ (($ $ktail) '()) ; ignore tails
+ (($ $kargs)
+ ;; kargs may bind more arguments
+ (list (cons (make-kid label) (compile label))))
+ (else
+ ;; otherwise, even if it dominates other conts,
+ ;; it doesn't need to contain them
+ (cons (cons (make-kid label) (compile label))
+ (find&compile-dominated label)))))
+ (intmap-ref doms label)))
+ (make-local (find&compile-dominated label) exp))
+ (define (compile cont)
+ (match (intmap-ref cps cont)
+ ;; The term in a $kargs is always a $continue
+ (($ $kargs names syms ($ $continue k src exp))
+ (make-continuation (map make-id syms)
+ (redominate cont (compile-exp exp k))))
+ (($ $kreceive ($ $arity req _ (? symbol? rest) _ _) k2)
+ (let ((ids (map make-id (append req (list rest)))))
+ (make-continuation ids (make-continue (make-kid k2) ids))))
+ (($ $kreceive ($ $arity req _ #f _ _) k2)
+ (let ((ids (map make-id req)))
+ (make-continuation ids (make-continue (make-kid k2) ids))))))
+ (compile cont))
(define (compile-exp exp k)
(match exp
