[Guile-commits] 33/99: Change program type representation

[Christopher Allan Webber]

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

commit a7b2dfa5810a8e027dfc149c1c173b3023dcc0ec
Author: Ian Price <ianprice90@googlemail.com>
AuthorDate: Sat Jun 20 22:41:24 2015 +0100

    Change program type representation
---
 module/language/cps/compile-js.scm           | 25 +++++++++++++------------
 module/language/js-il.scm                    |  9 ++++++---
 module/language/js-il/compile-javascript.scm | 14 +++++++++++---
 module/language/js-il/inlining.scm           | 24 ++++++++++++------------
 4 files changed, 42 insertions(+), 30 deletions(-)

diff --git a/module/language/cps/compile-js.scm 
b/module/language/cps/compile-js.scm
index 69cb91c..c1de2bc 100644
--- a/module/language/cps/compile-js.scm
+++ b/module/language/cps/compile-js.scm
@@ -18,32 +18,33 @@
   (set! exp (reify-primitives exp))
   (set! exp (renumber exp))
   (match exp
-    (($ $program funs)
+    (($ $program (($ $cont ks funs) ...))
      ;; TODO: I should special case the compilation for the initial fun,
      ;; as this is the entry point for the program, and shouldn't get a
      ;; "self" argument, for now, I add "undefined" as the first
      ;; argument in the call to it.
      ;; see compile-exp in (language js-il compile-javascript)
-     (values (make-program (compile-fun (car funs))
-                           (map compile-fun (cdr funs)))
+     (values (make-program
+              (map (lambda (k fun)
+                     (cons (make-kid k) (compile-fun fun)))
+                   ks
+                   funs))
              env
              env))))
 
 (define (compile-fun fun)
   (match fun
-    (($ $cont k ($ $kfun _ _ self ($ $cont tail ($ $ktail)) clause))
+    (($ $kfun _ _ self ($ $cont tail ($ $ktail)) clause)
      (call-with-values
          (lambda ()
            (extract-clauses self clause))
        (lambda (jump-table clauses)
-         (make-var
-          (make-kid k)
-          (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)
+          (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?)
diff --git a/module/language/js-il.scm b/module/language/js-il.scm
index 31b4749..8eb26a3 100644
--- a/module/language/js-il.scm
+++ b/module/language/js-il.scm
@@ -51,7 +51,7 @@
 (define (print-js exp port)
   (format port "#<js-il ~S>" (unparse-js exp)))
 
-(define-js-type program entry body)
+(define-js-type program 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?)
@@ -71,8 +71,11 @@
 
 (define (unparse-js exp)
   (match exp
-    (($ program entry body)
-     `(program ,(unparse-js entry) . ,(map unparse-js body)))
+    (($ program body)
+     `(program . ,(map (match-lambda
+                        ((($ kid k) . fun)
+                         (cons k (unparse-js fun))))
+                       body)))
     (($ continuation params body)
      `(continuation ,(map unparse-js params) ,(unparse-js body)))
     (($ function self tail body)
diff --git a/module/language/js-il/compile-javascript.scm 
b/module/language/js-il/compile-javascript.scm
index 44384c6..7d9140d 100644
--- a/module/language/js-il/compile-javascript.scm
+++ b/module/language/js-il/compile-javascript.scm
@@ -118,15 +118,23 @@
 (define (compile-exp exp)
   ;; TODO: handle ids for js
   (match exp
-    (($ il:program (and entry ($ il:var name _)) body)
+    (($ il:program ((name . fun) (names . funs) ...))
      (let ((entry-call
             (make-return
              (make-call (compile-id name)
                         (list
                          (make-id "undefined")
                          (make-refine *scheme* (make-const 
"initial_cont")))))))
-       (make-call (make-function '() (append (map compile-exp body)
-                                           (list (compile-exp entry) 
entry-call)))
+       (make-call (make-function
+                   '()
+                   (append
+                    (map (lambda (id f)
+                           (make-var (rename-id id)
+                                     (compile-exp f)))
+                         (cons name names)
+                         (cons fun funs))
+
+                    (list entry-call)))
                   '())))
 
     (($ il:continuation params body)
diff --git a/module/language/js-il/inlining.scm 
b/module/language/js-il/inlining.scm
index f042966..14e25bd 100644
--- a/module/language/js-il/inlining.scm
+++ b/module/language/js-il/inlining.scm
@@ -20,9 +20,8 @@
               arg-list))
   (define (analyse exp)
     (match exp
-      (($ program entry body)
-       (analyse entry)
-       (for-each analyse body))
+      (($ program ((ids . funs) ...))
+       (for-each analyse funs))
 
       (($ function self tail body)
        (analyse body))
@@ -192,14 +191,15 @@
                 (make-var id (make-continuation params (inline body '()))))))
            bindings))
     (match fun
-      (($ var id ($ function self tail ($ local bindings ($ jump-table spec))))
-       (make-var id
-                 (make-function self
-                                tail
-                                (make-local (handle-bindings bindings)
-                                            (make-jump-table spec)))))))
+      (($ function self tail ($ local bindings ($ jump-table spec)))
+       (make-function self
+                      tail
+                      (make-local (handle-bindings bindings)
+                                  (make-jump-table spec))))))
 
   (match exp
-    (($ program entry body)
-     (make-program (handle-function entry)
-                   (map handle-function body)))))
+    (($ program ((ids . funs) ...))
+     (make-program (map (lambda (id fun)
+                          (cons id (handle-function fun)))
+                        ids
+                        funs)))))