[Guile-commits] 31/99: Different types for Continuation and Variable identifiers

[Christopher Allan Webber]

cwebber pushed a commit to branch compile-to-js-merge
in repository guile.

commit 2e10f55426ded4ab89693cd9c206afbefe9dde50
Author: Ian Price <ianprice90@googlemail.com>
AuthorDate: Thu Jun 18 11:02:05 2015 +0100

    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 e990d1f..69cb91c 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 ae5932c..31b4749 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 "#<js-il ~S>" (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 05327c7..d269ab6 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 e431649..589e765 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)))