[Guile-commits] 05/99: separate js-il functions into actual functions and those for continuations

[Christopher Allan Webber]

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

commit 54ce470cf870dd0c8bacd7d9b5bda2e0d24c36ea
Author: Ian Price <ianprice90@googlemail.com>
AuthorDate: Sat Jun 6 20:10:57 2015 +0100

    separate js-il functions into actual functions and those for continuations
---
 module/language/cps/compile-js.scm           |  20 +++--
 module/language/js-il.scm                    | 128 ++-------------------------
 module/language/js-il/compile-javascript.scm |   3 +-
 3 files changed, 20 insertions(+), 131 deletions(-)

diff --git a/module/language/cps/compile-js.scm 
b/module/language/cps/compile-js.scm
index 6d1edb8..1d50c89 100644
--- a/module/language/cps/compile-js.scm
+++ b/module/language/cps/compile-js.scm
@@ -51,7 +51,7 @@
        (not-supported "keyword arguments are not supported" clause))
      (when alternate
        (not-supported "alternate continuations are not supported" clause))
-     (make-function self ;; didn't think this js pattern would come in handy
+     (make-function self
                     (cons tail req)
                     (match body
                       (($ $cont k ($ $kargs () () exp))
@@ -76,11 +76,14 @@
   (match cont
     (($ $cont k ($ $kargs names syms body))
      ;; use the name part?
-     (make-var k (make-function syms (compile-term body))))
-    (($ $cont k ($ $kreceive ($ $arity (arg) _ (? symbol? rest) _ _) k2))
-     (make-var k (make-function (list arg rest) (make-continue k2 (list 
(make-id arg) (make-id rest))))))
-    (($ $cont k ($ $kreceive ($ $arity (arg) _ #f _ _) k2))
-     (make-var k (make-function (list arg) (make-continue k2 (list (make-id 
arg))))))
+     (make-var k (make-continuation 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)))))))
+    (($ $cont k ($ $kreceive ($ $arity req _ #f _ _) k2))
+     (make-var k (make-continuation req (make-continue k2 (map make-id req)))))
     (_
      `(cont:todo: ,cont))
     ))
@@ -108,6 +111,11 @@
      (make-primcall name args))
     (($ $closure label nfree)
      (make-closure label nfree))
+    (($ $values (val))
+     ;; FIXME:
+     ;; may happen if a test branch of a conditional compiles to values
+     ;; placeholder till I learn if multiple values could be returned.
+     (make-id val))
     (_
      `(exp:todo: ,exp))))
 
diff --git a/module/language/js-il.scm b/module/language/js-il.scm
index 946a1c0..02a99d5 100644
--- a/module/language/js-il.scm
+++ b/module/language/js-il.scm
@@ -3,7 +3,8 @@
   #:use-module (srfi srfi-9 gnu)
   #:use-module (ice-9 match)
   #:export (make-program program
-            (make-function* . make-function) function
+            make-function function
+            make-continuation continuation
             make-local local
             make-var var
             make-continue continue ; differ from conts
@@ -49,14 +50,7 @@
 
 (define-js-type program entry body)
 (define-js-type function name params body)
-
-(define make-function*
-  (case-lambda
-    ((name params body)
-     (make-function name params body))
-    ((params body)
-     (make-function #f params body))))
-
+(define-js-type continuation params body)
 (define-js-type local bindings body) ; local scope
 (define-js-type var id exp)
 (define-js-type continue cont args)
@@ -72,6 +66,8 @@
   (match exp
     (($ program entry body)
      `(program ,(unparse-js entry) . ,(map unparse-js body)))
+    (($ continuation params body)
+     `(continuation ,params ,(unparse-js body)))
     (($ function name params body)
      `(function ,name ,params ,(unparse-js body)))
     (($ local bindings body)
@@ -99,117 +95,3 @@
      ;(error "unexpected js" exp)
      (pk 'unexpected exp)
      exp)))
-#|
-(define (print-js exp port)
-  ;; could be much nicer with foof's fmt
-  (match exp
-    (($ program (and entry ($ var name _)) body)
-     ;; TODO: I should probably put call to entry in js-il
-     (format port "(function(){\n")
-     (print-js entry port) (display ";\n" port)
-     (print-terminated body print-js ";\n" port)
-     ;; call to entry point
-     (format port "return ~a(scheme.initial_cont);" (lookup-cont name))
-     (format port "})();\n"))
-    (($ function #f params body)
-     (format port "function(")
-     (print-separated params print-var "," port)
-     (format port "){\n")
-     (print-js body port)(display ";" port)
-     (format port "}"))
-    ;; TODO: clean this code up
-    (($ function name params body)
-     (format port "function (~a," (lookup-cont name))
-     (print-separated params print-var "," port)
-     (format port "){\n")
-     (print-js body port)(display ";" port)
-     (format port "}"))
-    (($ local bindings body)
-     (display "{" port)
-     (print-terminated bindings print-js ";\n" port)
-     (print-js body port)
-     (display ";\n")
-     (display "}" port))
-    (($ var id exp)
-     (format port "var ~a = " (lookup-cont id))
-     (print-js exp port))
-    (($ continue k args)
-     (format port "return ~a(" (lookup-cont k))
-     (print-js exp port)
-     (display ")" port))
-    (($ branch test then else)
-     (display "if (scheme.is_true(" port)
-     (print-js test port)
-     (display ")) {\n" port)
-     (print-js then port)
-     (display ";} else {\n" port)
-     (print-js else port)
-     (display ";}" port))
-    ;; values
-    (($ const c)
-     (print-const c port))
-    (($ primcall name args)
-     (format port "scheme.primitives[\"~s\"](" name)
-     (print-separated args print-var "," port)
-     (format port ")"))
-    (($ call name args)
-     ;; TODO: need to also add closure env
-     (format port "return ~a.fun(~a," (lookup-cont name) (lookup-cont name))
-     (print-separated args print-var "," port)
-     (format port ")"))
-    (($ jscall name args)
-     (format port "return ~a(" (lookup-cont name))
-     (print-separated args print-var "," port)
-     (format port ")"))
-    (($ closure label nfree)
-     (format port "new scheme.Closure(~a,~a)" (lookup-cont label) nfree))
-    (($ values vals)
-     (display "new scheme.Values(" port)
-     (print-separated vals print-var "," port)
-     (display ")" port))
-    ;; (($ return val)
-    ;;  (display "return " port)
-    ;;  (print-js val port))
-    (($ id name)
-     (print-var name port))
-    (_
-     (error "print: unexpected js" exp))))
-
-(define (print-var var port)
-  (if (number? var)
-      (display (lookup-cont var) port)
-      (display var port)))
-
-(define (lookup-cont k)
-  (format #f "kont_~s" k))
-
-(define (print-separated args printer separator port)
-  (unless (null? args)
-    (let ((first (car args))
-          (rest  (cdr args)))
-      (printer first port)
-      (for-each (lambda (x)
-                  (display separator port)
-                  (printer x port))
-                rest))))
-
-(define (print-terminated args printer terminator port)
-  (for-each (lambda (x)
-              (printer x port)
-              (display terminator port))
-            args))
-
-(define (print-const c port)
-  (cond ((number? c) (display c port))
-        ((eqv? c #t) (display "scheme.TRUE" port))
-        ((eqv? c #f) (display "scheme.FALSE" port))
-        ((eqv? c '()) (display "scheme.EMPTY" port))
-        ((unspecified? c) (display "scheme.UNSPECIFIED" port))
-        ((symbol? c) (format port "new scheme.Symbol(\"~s\")" c))
-        ((list? c)
-         (display "scheme.list(" port)
-         (print-separated c print-const "," port)
-         (display ")" port))
-        (else
-         (throw 'not-implemented))))
-|#
diff --git a/module/language/js-il/compile-javascript.scm 
b/module/language/js-il/compile-javascript.scm
index 790ac7c..fb5ed5e 100644
--- a/module/language/js-il/compile-javascript.scm
+++ b/module/language/js-il/compile-javascript.scm
@@ -29,11 +29,10 @@
                                            (list (compile-exp entry) 
entry-call)))
                   '())))
 
-    (($ il:function #f params body)
+    (($ il:continuation params body)
      (make-function (map rename params) (list (compile-exp body))))
 
     (($ il:function name params body)
-     ;; TODO: split il:function into closure (with self) and cont types
      (make-function (map rename (cons name params)) (list (compile-exp body))))
 
     (($ il:local bindings body)