summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/cps/compile-js.scm53
1 files changed, 40 insertions, 13 deletions
diff --git a/module/language/cps/compile-js.scm b/module/language/cps/compile-js.scm
index 03e9e7d66..e7509359f 100644
--- a/module/language/cps/compile-js.scm
+++ b/module/language/cps/compile-js.scm
@@ -35,17 +35,45 @@
(compile-clauses cps clause self)))))
+(define (extract-and-compile-conts cps)
+ (define (step id body accum)
+ (match body
+ ;; The term in a $kargs is always a $continue
+ (($ $kargs names syms ($ $continue k src exp))
+ (acons (make-kid id)
+ (make-continuation (map make-id syms) (compile-exp exp k))
+ accum))
+ (($ $kreceive ($ $arity req _ (? symbol? rest) _ _) k2)
+ (let ((ids (map make-id (append req (list rest)))))
+ (acons (make-kid id)
+ (make-continuation ids (make-continue (make-kid k2) ids))
+ accum)))
+ (($ $kreceive ($ $arity req _ #f _ _) k2)
+ (let ((ids (map make-id req)))
+ (acons (make-kid id)
+ (make-continuation ids (make-continue (make-kid k2) ids))
+ accum)))
+ (else accum)))
+ (intmap-fold step cps '()))
+
+
(define (compile-clauses cps clause self)
- (match (intmap-ref cps clause)
- (($ $kclause arity body #f)
- `((,(make-kid clause)
- ,(arity->params arity self)
- ,(compile-clause cps arity body self))))
- (($ $kclause arity body next)
- `((,(make-kid clause)
- ,(arity->params arity self)
- ,(compile-clause cps arity body self))
- . ,(compile-clauses cps next 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))))
+ (($ $kclause arity body next)
+ `((,(make-kid clause)
+ ,(arity->params arity self)
+ ,(compile-clause cps arity body self function-conts))
+ . ,(loop next))))))
(define (arity->params arity self)
@@ -63,15 +91,14 @@
allow-other-keys?))))
-(define (compile-clause cps arity body self)
+(define (compile-clause cps arity body self bindings)
(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 `((,(make-kid body) . ,(compile-cont cps body)))
- (make-continue (make-kid body) ids)))))))
+ (make-local bindings (make-continue (make-kid body) ids)))))))
(define (compile-cont cps cont)