From 2e10f55426ded4ab89693cd9c206afbefe9dde50 Mon Sep 17 00:00:00 2001 From: Ian Price Date: Thu, 18 Jun 2015 11:02:05 +0100 Subject: [PATCH] Different types for Continuation and Variable identifiers --- module/language/cps/compile-js.scm | 71 +++++++++++------ module/language/js-il.scm | 42 ++++++---- module/language/js-il/compile-javascript.scm | 82 +++++++++++++------- module/language/js-il/direct.scm | 4 +- 4 files changed, 127 insertions(+), 72 deletions(-) diff --git a/module/language/cps/compile-js.scm b/module/language/cps/compile-js.scm index e990d1ff9..69cb91c03 100644 --- a/module/language/cps/compile-js.scm +++ b/module/language/cps/compile-js.scm @@ -37,39 +37,54 @@ (extract-clauses self clause)) (lambda (jump-table clauses) (make-var - k + (make-kid k) (make-function - (list self tail) + (make-id self) (make-kid tail) (make-local (map (lambda (clause) (compile-clause clause self tail)) clauses) (make-jump-table jump-table))))))))) (define (extract-clauses self clause) + (define (make-params* self req opts rest kw 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 (cons (cons (make-params self req opts rest kw allow-other-keys?) k) specs)) + (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 - (cons (cons (make-params self req opts rest kw allow-other-keys?) k) specs) + (acons (make-params* self req opts rest kw allow-other-keys?) + (make-kid k) + specs) (cons clause clauses)))))) (define (compile-clause clause self tail) (match clause (($ $cont k ($ $kclause ($ $arity req opt rest ((_ _ kw-syms) ...) _) body _)) (make-var - k + (make-kid k) (make-continuation - (append (list self) req opt kw-syms (if rest (list rest) '())) + (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 - k + (make-kid k) (map make-id (append req opt kw-syms (if rest (list rest) '())))))))))))) (define (not-supported msg clause) @@ -86,43 +101,53 @@ (match cont (($ $cont k ($ $kargs names syms body)) ;; use the name part? - (make-var k (make-continuation syms (compile-term body)))) + (make-var (make-kid k) + (make-continuation (map make-id syms) + (compile-term body)))) (($ $cont k ($ $kreceive ($ $arity req _ (? symbol? rest) _ _) k2)) - (make-var k - (make-continuation (append req (list rest)) - (make-continue k2 - (append (map make-id req) (list (make-id rest))))))) + (make-var + (make-kid k) + (make-continuation (append (map make-id req) (list (make-id rest))) + (make-continue (make-kid k2) + (append (map make-id req) + (list (make-id rest))))))) (($ $cont k ($ $kreceive ($ $arity req _ #f _ _) k2)) - (make-var k (make-continuation req (make-continue k2 (map make-id req))))))) + (make-var (make-kid k) + (make-continuation (map make-id req) + (make-continue (make-kid k2) + (map make-id req))))))) (define (compile-exp exp k) (match exp (($ $branch kt exp) - (compile-test exp kt k)) + (compile-test exp (make-kid kt) (make-kid k))) (($ $primcall 'return (arg)) - (make-continue k (list (make-id arg)))) + (make-continue (make-kid k) (list (make-id arg)))) (($ $call name args) - (make-call name (cons k args))) + (make-call (make-id name) (make-kid k) (map make-id args))) (($ $callk label proc args) - (make-continue label (map make-id (cons* proc k args)))) + (make-continue (make-kid label) + (cons* (make-id proc) + (make-kid k) + (map make-id args)))) (($ $values values) - (make-continue k (map make-id values))) + (make-continue (make-kid k) (map make-id values))) (($ $prompt escape? tag handler) (make-seq (list - (make-prompt* escape? tag handler) - (make-continue k '())))) + (make-prompt* escape? (make-id tag) (make-kid handler)) + (make-continue (make-kid k) '())))) (_ - (make-continue k (list (compile-exp* exp)))))) + (make-continue (make-kid k) (list (compile-exp* exp)))))) (define (compile-exp* exp) (match exp (($ $const val) (make-const val)) (($ $primcall name args) - (make-primcall name args)) + (make-primcall name (map make-id args))) (($ $closure label nfree) - (make-closure label nfree)) + (make-closure (make-kid label) nfree)) (($ $values (val)) ;; FIXME: ;; may happen if a test branch of a conditional compiles to values diff --git a/module/language/js-il.scm b/module/language/js-il.scm index ae5932ce6..31b47497e 100644 --- a/module/language/js-il.scm +++ b/module/language/js-il.scm @@ -15,8 +15,8 @@ make-call call make-closure closure make-branch branch - make-return return make-id id + make-kid kid make-seq seq make-prompt prompt )) @@ -52,7 +52,7 @@ (format port "#" (unparse-js exp))) (define-js-type program entry body) -(define-js-type function params body) +(define-js-type function self tail body) (define-js-type jump-table spec) (define-js-type params self req opt rest kw allow-other-keys?) (define-js-type continuation params body) @@ -61,11 +61,11 @@ (define-js-type continue cont args) (define-js-type const value) (define-js-type primcall name args) -(define-js-type call name args) +(define-js-type call name k args) (define-js-type closure label num-free) (define-js-type branch test consequence alternate) (define-js-type id name) -(define-js-type return val) +(define-js-type kid name) (define-js-type seq body) (define-js-type prompt escape? tag handler) @@ -74,32 +74,40 @@ (($ program entry body) `(program ,(unparse-js entry) . ,(map unparse-js body))) (($ continuation params body) - `(continuation ,params ,(unparse-js body))) - (($ function args body) - `(function ,args ,(unparse-js 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))) - (($ params self req opt rest kw allow-other-keys?) - `(params ,self ,req ,opt ,rest ,kw ,allow-other-keys?)) + (($ params ($ id self) req opt rest kws allow-other-keys?) + `(params ,self + ,(map unparse-js req) + ,(map unparse-js opt) + ,(and rest (unparse-js rest)) + ,(map (match-lambda + ((kw ($ id name) ($ id sym)) + (list kw name sym))) + kws) + ,allow-other-keys?)) (($ local bindings body) `(local ,(map unparse-js bindings) ,(unparse-js body))) (($ var id exp) `(var ,id ,(unparse-js exp))) - (($ continue k args) + (($ continue ($ kid k) args) `(continue ,k ,(map unparse-js args))) (($ branch test then else) `(if ,(unparse-js test) ,(unparse-js then) ,(unparse-js else))) (($ const c) `(const ,c)) (($ primcall name args) - `(primcall ,name , args)) - (($ call name args) - `(call ,name , args)) - (($ closure label nfree) + `(primcall ,name ,(map unparse-js args))) + (($ call ($ id name) ($ kid k) args) + `(call ,name ,k ,(map unparse-js args))) + (($ closure ($ kid label) nfree) `(closure ,label ,nfree)) - (($ return val) - `(return . ,(unparse-js val))) (($ id name) - `(id . ,name)))) + `(id . ,name)) + (($ kid name) + `(kid . ,name)))) diff --git a/module/language/js-il/compile-javascript.scm b/module/language/js-il/compile-javascript.scm index 05327c74a..d269ab6b0 100644 --- a/module/language/js-il/compile-javascript.scm +++ b/module/language/js-il/compile-javascript.scm @@ -23,12 +23,28 @@ (define *scheme* (make-id "scheme")) (define *utils* (make-refine *scheme* (make-const "utils"))) +(define (rename-id i) + (match i + (($ il:id i) + (rename i)) + (($ il:kid i) + (rename-kont i)))) + +(define (compile-id i) + (make-id (rename-id i))) + +(define (kont->id name) + (make-id (rename-kont name))) + +(define (rename-kont name) + (format #f "k_~a" name)) + (define (name->id name) (make-id (rename name))) (define (rename id) (cond ((and (integer? id) (>= id 0)) - (format #f "k_~a" id)) + (format #f "v_~a" id)) ((symbol? id) (js-id (symbol->string id))) ((string? id) @@ -39,7 +55,7 @@ (define (js-id name) (call-with-output-string (lambda (port) - (display "k_" port) + (display "v_" port) (string-for-each (lambda (c) (if (or (and (char<=? #\a c) (char<=? c #\z)) @@ -68,7 +84,7 @@ i (ref (make-refine i (make-const (car l))) (cdr l)))) - (define this (rename rest)) + (define this (rename-id rest)) (make-var this (make-call (ref *scheme* (list "list" "apply")) (list @@ -78,7 +94,7 @@ (define (bind-opt-args opts num-drop) (map (lambda (opt idx) - (make-var (rename opt) + (make-var (rename-id opt) (make-binop 'or (make-refine (make-id "arguments") (make-const (+ num-drop idx))) @@ -89,7 +105,7 @@ (define (bind-kw-args kws ids num-drop) (define lookup (make-refine *utils* (make-const "keyword_ref"))) (map (lambda (kw id) - (make-var (rename id) + (make-var (rename-id id) (make-call lookup (list (compile-const kw) (make-id "arguments") @@ -105,7 +121,7 @@ (($ il:program (and entry ($ il:var name _)) body) (let ((entry-call (make-return - (make-call (name->id name) + (make-call (compile-id name) (list (make-id "undefined") (make-refine *scheme* (make-const "initial_cont"))))))) @@ -114,10 +130,11 @@ '()))) (($ il:continuation params body) - (make-function (map rename params) (list (compile-exp body)))) + (make-function (map rename-id params) (list (compile-exp body)))) - (($ il:function params body) - (make-function (map rename params) (list (compile-exp body)))) + (($ il:function self tail body) + (make-function (list (rename-id self) (rename-id tail)) + (list (compile-exp body)))) (($ il:jump-table specs) (compile-jump-table specs)) @@ -126,10 +143,10 @@ (make-block (append (map compile-exp bindings) (list (compile-exp body))))) (($ il:var id exp) - (make-var (rename id) (compile-exp exp))) + (make-var (rename-id id) (compile-exp exp))) (($ il:continue k exps) - (make-return (make-call (name->id k) (map compile-exp exps)))) + (make-return (make-call (compile-id k) (map compile-exp exps)))) (($ il:branch test then else) (make-branch (make-call (make-refine *scheme* (make-const "is_true")) @@ -143,29 +160,34 @@ (($ il:primcall name args) (make-call (make-refine (make-refine *scheme* (make-const "primitives")) (make-const (symbol->string name))) - (map name->id args))) + (map compile-id args))) - (($ il:call name args) + (($ il:call name k args) (make-return - (make-call (make-refine (name->id name) (make-const "fun")) - (map name->id (cons name args))))) + (make-call (make-refine (compile-id name) (make-const "fun")) + (cons* (compile-id name) + (compile-id k) + (map compile-id args))))) (($ il:closure label nfree) (make-new (make-call (make-refine *scheme* (make-const "Closure")) - (list (name->id label) (make-const nfree))))) + (list (compile-id label) (make-const nfree))))) (($ il:prompt escape? tag handler) ;; never a tailcall (make-call (make-refine (make-refine *scheme* (make-const "primitives")) (make-const "prompt")) - (list (compile-const escape?) (name->id tag) (name->id handler)))) + (list (compile-const escape?) (compile-id tag) (compile-id handler)))) (($ il:seq body) (make-block (map compile-exp body))) (($ il:id name) - (name->id name)))) + (name->id name)) + + (($ il:kid name) + (kont->id name)))) (define (compile-jump-table specs) (define offset 2) ; closure & continuation @@ -203,8 +225,8 @@ (($ il:params self req '() #f '() #f) (list (make-return - (make-call (name->id k) - (cons (name->id self) + (make-call (compile-id k) + (cons (compile-id self) (map (lambda (idx) (make-refine (make-id "arguments") (make-const (+ offset idx)))) @@ -213,39 +235,39 @@ (list (bind-rest-args rest (+ offset (length req))) (make-return - (make-call (name->id k) - (append (list (name->id self)) + (make-call (compile-id k) + (append (list (compile-id self)) (map (lambda (idx) (make-refine (make-id "arguments") (make-const (+ offset idx)))) (iota (length req))) - (list (name->id rest))))))) + (list (compile-id rest))))))) (($ il:params self req opts #f '() #f) (append (bind-opt-args opts (+ offset (length req))) (list (make-return - (make-call (name->id k) - (append (list (name->id self)) + (make-call (compile-id k) + (append (list (compile-id self)) (map (lambda (idx) (make-refine (make-id "arguments") (make-const (+ offset idx)))) (iota (length req))) - (map name->id opts))))))) + (map compile-id opts))))))) (($ il:params self req opts #f ((kws names ids) ...) _) (append (bind-opt-args opts (+ offset (length req))) (bind-kw-args kws names (+ offset (length req))) (list (make-return - (make-call (name->id k) - (append (list (name->id self)) + (make-call (compile-id k) + (append (list (compile-id self)) (map (lambda (idx) (make-refine (make-id "arguments") (make-const (+ offset idx)))) (iota (length req))) - (map name->id opts) - (map name->id names))))))) + (map compile-id opts) + (map compile-id names))))))) )) (fold-right (lambda (a d) (make-branch (compile-test (car a)) diff --git a/module/language/js-il/direct.scm b/module/language/js-il/direct.scm index e43164963..589e76506 100644 --- a/module/language/js-il/direct.scm +++ b/module/language/js-il/direct.scm @@ -12,8 +12,8 @@ (($ continuation params body) (make-continuation params (remove-immediate-calls body))) - (($ function params body) - (make-function params (remove-immediate-calls body))) + (($ function self tail body) + (make-function self tail (remove-immediate-calls body))) (($ local (($ var id ($ continuation () body)))