diff --git a/module/language/cps/compile-js.scm b/module/language/cps/compile-js.scm index c1de2bc6e..e67652eed 100644 --- a/module/language/cps/compile-js.scm +++ b/module/language/cps/compile-js.scm @@ -35,61 +35,48 @@ (define (compile-fun fun) (match fun (($ $kfun _ _ self ($ $cont tail ($ $ktail)) clause) - (call-with-values - (lambda () - (extract-clauses self clause)) - (lambda (jump-table clauses) - (make-function - (make-id self) (make-kid tail) - (make-local (map (lambda (clause) - (compile-clause clause self tail)) - clauses) - (make-jump-table jump-table)))))))) + (make-function + (make-id self) + (make-kid tail) + (compile-clauses clause self))))) -(define (extract-clauses self clause) - (define (make-params* self req opts rest kw allow-other-keys?) - (make-params (make-id self) +(define (compile-clauses clause self) + (match clause + (($ $cont k ($ $kclause arity body #f)) + `((,(make-kid k) + ,(arity->params arity self) + ,(compile-clause arity body self)))) + (($ $cont k ($ $kclause arity body next)) + `((,(make-kid k) + ,(arity->params arity self) + ,(compile-clause arity body self)) + . ,(compile-clauses next self))))) + +(define (arity->params arity self) + (match arity + (($ $arity req opts rest ((kws names kw-syms) ...) allow-other-keys?) + (make-params (make-id self) (map make-id req) (map make-id opts) (and rest (make-id rest)) - (map make-id kw) - allow-other-keys?)) - (let loop ((clause clause) (specs '()) (clauses '())) - (match clause - (($ $cont k ($ $kclause ($ $arity req opts rest kw allow-other-keys?) _ #f)) - (values (reverse (acons (make-params* self req opts rest kw allow-other-keys?) - (make-kid k) - specs)) - (reverse (cons clause clauses)))) - (($ $cont k ($ $kclause ($ $arity req opts rest kw allow-other-keys?) _ alternate)) - (loop alternate - (acons (make-params* self req opts rest kw allow-other-keys?) - (make-kid k) - specs) - (cons clause clauses)))))) + (map (lambda (kw name kw-sym) + (list kw (make-id name) (make-id kw-sym))) + kws + names + kw-syms) + allow-other-keys?)))) -(define (compile-clause clause self tail) - (match clause - (($ $cont k ($ $kclause ($ $arity req opt rest ((_ _ kw-syms) ...) _) body _)) - (make-var - (make-kid k) - (make-continuation - (append (list (make-id self)) - (map make-id req) - (map make-id opt) - (map make-id kw-syms) - (if rest (list (make-id rest)) '())) - (match body - (($ $cont k ($ $kargs () () exp)) - (compile-term exp)) - (($ $cont k _) - (make-local (list (compile-cont body)) - (make-continue - (make-kid k) - (map make-id (append req opt kw-syms (if rest (list rest) '())))))))))))) - -(define (not-supported msg clause) - (error 'not-supported msg clause)) +(define (compile-clause 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) + (match body + (($ $cont k _) + (make-local (list (compile-cont body)) + (make-continue (make-kid k) ids))))))))) (define (compile-term term) (match term diff --git a/module/language/js-il.scm b/module/language/js-il.scm index 8eb26a326..d83faf5cc 100644 --- a/module/language/js-il.scm +++ b/module/language/js-il.scm @@ -4,7 +4,6 @@ #:use-module (ice-9 match) #:export (make-program program make-function function - make-jump-table jump-table make-params params make-continuation continuation make-local local @@ -52,8 +51,7 @@ (format port "#" (unparse-js exp))) (define-js-type program body) -(define-js-type function self tail body) -(define-js-type jump-table spec) +(define-js-type function self tail clauses) (define-js-type params self req opt rest kw allow-other-keys?) (define-js-type continuation params body) (define-js-type local bindings body) ; local scope @@ -78,12 +76,15 @@ body))) (($ continuation params body) `(continuation ,(map unparse-js params) ,(unparse-js body))) - (($ function self tail body) - `(function ,self ,tail ,(unparse-js body))) - (($ jump-table body) - `(jump-table ,@(map (lambda (p) - `(,(unparse-js (car p)) . ,(cdr p))) - body))) + (($ function ($ id self) ($ kid tail) clauses) + `(function ,self + ,tail + ,@(map (match-lambda + ((($ kid id) params kont) + (list id + (unparse-js params) + (unparse-js kont)))) + clauses))) (($ params ($ id self) req opt rest kws allow-other-keys?) `(params ,self ,(map unparse-js req) diff --git a/module/language/js-il/compile-javascript.scm b/module/language/js-il/compile-javascript.scm index 7d9140d08..3aa2e5b74 100644 --- a/module/language/js-il/compile-javascript.scm +++ b/module/language/js-il/compile-javascript.scm @@ -140,12 +140,14 @@ (($ il:continuation params body) (make-function (map rename-id params) (list (compile-exp body)))) - (($ il:function self tail body) + (($ il:function self tail clauses) (make-function (list (rename-id self) (rename-id tail)) - (list (compile-exp body)))) - - (($ il:jump-table specs) - (compile-jump-table specs)) + (append + (map (match-lambda + ((id _ body) + (make-var (rename-id id) (compile-exp body)))) + clauses) + (list (compile-jump-table clauses))))) (($ il:local bindings body) (make-block (append (map compile-exp bindings) (list (compile-exp body))))) @@ -278,9 +280,11 @@ (map compile-id names))))))) )) (fold-right (lambda (a d) - (make-branch (compile-test (car a)) - (compile-jump (car a) (cdr a)) - (list d))) + (match a + ((id params _) + (make-branch (compile-test params) + (compile-jump params id) + (list d))))) ;; FIXME: should throw an error (make-return (make-id "undefined")) specs)) diff --git a/module/language/js-il/inlining.scm b/module/language/js-il/inlining.scm index 14e25bde4..c2a33db9f 100644 --- a/module/language/js-il/inlining.scm +++ b/module/language/js-il/inlining.scm @@ -23,12 +23,9 @@ (($ program ((ids . funs) ...)) (for-each analyse funs)) - (($ function self tail body) - (analyse body)) - - (($ jump-table spec) - (for-each (lambda (p) (analyse (cdr p))) - spec)) + (($ function self tail ((($ kid ids) _ bodies) ...)) + (for-each count-inc! ids) ;; count-inf! ? + (for-each analyse bodies)) (($ continuation params body) (analyse body)) @@ -184,18 +181,15 @@ (exp exp))) (define (handle-function fun) - (define (handle-bindings bindings) - (map (lambda (binding) - (match binding - (($ var id ($ continuation params body)) - (make-var id (make-continuation params (inline body '())))))) - bindings)) (match fun - (($ function self tail ($ local bindings ($ jump-table spec))) + (($ function self tail ((ids params bodies) ...)) (make-function self tail - (make-local (handle-bindings bindings) - (make-jump-table spec)))))) + (map (lambda (id param body) + (list id param (inline body '()))) + ids + params + bodies))))) (match exp (($ program ((ids . funs) ...))