[Guile-commits] 35/99: Change local type representation and remove var type

[Christopher Allan Webber]

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

commit a680a4cb9d14c705a9248b1281614d1caded5881
Author: Ian Price <ianprice90@googlemail.com>
AuthorDate: Sun Jun 21 01:56:01 2015 +0100

    Change local type representation and remove var type
---
 module/language/cps/compile-js.scm           | 38 +++++++++++++---------------
 module/language/js-il.scm                    | 11 ++++----
 module/language/js-il/compile-javascript.scm | 12 +++++----
 module/language/js-il/inlining.scm           | 20 +++++++--------
 4 files changed, 39 insertions(+), 42 deletions(-)

diff --git a/module/language/cps/compile-js.scm 
b/module/language/cps/compile-js.scm
index e67652e..34b1ffe 100644
--- a/module/language/cps/compile-js.scm
+++ b/module/language/cps/compile-js.scm
@@ -74,36 +74,32 @@
        (make-continuation
         (cons (make-id self) ids)
         (match body
-          (($ $cont k _)
-           (make-local (list (compile-cont body))
+          (($ $cont k cont)
+           (make-local `((,(make-kid k) . ,(compile-cont cont)))
                        (make-continue (make-kid k) ids)))))))))
 
 (define (compile-term term)
   (match term
-    (($ $letk conts body)
-     (make-local (map compile-cont conts) (compile-term body)))
+    (($ $letk (($ $cont ks conts) ...) body)
+     (make-local (map (lambda (k cont)
+                        (cons (make-kid k)
+                              (compile-cont cont)))
+                      ks
+                      conts)
+                 (compile-term body)))
     (($ $continue k src exp)
      (compile-exp exp k))))
 
 (define (compile-cont cont)
   (match cont
-    (($ $cont k ($ $kargs names syms body))
-     ;; use the name part?
-     (make-var (make-kid k)
-               (make-continuation (map make-id syms)
-                                  (compile-term body))))
-    (($ $cont k ($ $kreceive ($ $arity req _ (? symbol? rest) _ _) k2))
-     (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 (make-kid k)
-               (make-continuation (map make-id req)
-                                  (make-continue (make-kid k2)
-                                                 (map make-id req)))))))
+    (($ $kargs names syms body)
+     (make-continuation (map make-id syms) (compile-term body)))
+    (($ $kreceive ($ $arity req _ (? symbol? rest) _ _) k2)
+     (let ((ids (map make-id (append req (list rest)))))
+       (make-continuation ids (make-continue (make-kid k2) ids))))
+    (($ $kreceive ($ $arity req _ #f _ _) k2)
+     (let ((ids (map make-id req)))
+       (make-continuation ids (make-continue (make-kid k2) ids))))))
 
 (define (compile-exp exp k)
  (match exp
diff --git a/module/language/js-il.scm b/module/language/js-il.scm
index d83faf5..e5fe196 100644
--- a/module/language/js-il.scm
+++ b/module/language/js-il.scm
@@ -7,7 +7,6 @@
             make-params params
             make-continuation continuation
             make-local local
-            make-var var
             make-continue continue
             make-const const
             make-primcall primcall
@@ -55,7 +54,6 @@
 (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
-(define-js-type var id exp)
 (define-js-type continue cont args)
 (define-js-type const value)
 (define-js-type primcall name args)
@@ -96,9 +94,12 @@
                     kws)
               ,allow-other-keys?))
     (($ local bindings body)
-     `(local ,(map unparse-js bindings) ,(unparse-js body)))
-    (($ var id exp)
-     `(var ,id ,(unparse-js exp)))
+     `(local ,(map (match-lambda
+                    ((a . d)
+                     (cons (unparse-js a)
+                           (unparse-js d))))
+                   bindings)
+             ,(unparse-js body)))
     (($ continue ($ kid k) args)
      `(continue ,k ,(map unparse-js args)))
     (($ branch test then else)
diff --git a/module/language/js-il/compile-javascript.scm 
b/module/language/js-il/compile-javascript.scm
index 3aa2e5b..3ef9a95 100644
--- a/module/language/js-il/compile-javascript.scm
+++ b/module/language/js-il/compile-javascript.scm
@@ -149,11 +149,13 @@
                           clauses)
                      (list (compile-jump-table clauses)))))
 
-    (($ il:local bindings body)
-     (make-block (append (map compile-exp bindings) (list (compile-exp 
body)))))
-
-    (($ il:var id exp)
-     (make-var (rename-id id) (compile-exp exp)))
+    (($ il:local ((ids . bindings) ...) body)
+     (make-block
+      (append (map (lambda (id binding)
+                     (make-var (rename-id id) (compile-exp binding)))
+                   ids
+                   bindings)
+              (list (compile-exp body)))))
 
     (($ il:continue k exps)
      (make-return (make-call (compile-id k) (map compile-exp exps))))
diff --git a/module/language/js-il/inlining.scm 
b/module/language/js-il/inlining.scm
index c2a33db..72df222 100644
--- a/module/language/js-il/inlining.scm
+++ b/module/language/js-il/inlining.scm
@@ -31,12 +31,11 @@
        (analyse body))
 
       (($ local bindings body)
-       (for-each analyse bindings)
+       (for-each (match-lambda
+                  ((i . b) (analyse b)))
+                 bindings)
        (analyse body))
 
-      (($ var id exp)
-       (analyse exp))
-
       (($ continue ($ kid cont) args)
        (count-inc! cont)
        (for-each analyse args))
@@ -103,12 +102,12 @@
 
   (define (split-inlinable bindings)
     (partition (match-lambda
-                (($ var ($ kid id) _) (inlinable? id)))
+                ((($ kid id) . _) (inlinable? id)))
                bindings))
 
   (define (lookup kont substs)
     (match substs
-      ((($ var ($ kid id) exp) . rest)
+      (((($ kid id) . exp) . rest)
        (if (= id kont)
            exp
            (lookup kont rest)))
@@ -140,7 +139,7 @@
          (($ continuation kargs body)
           (if (not (= (length args) (length kargs)))
               (throw 'args-dont-match cont args kargs)
-              (make-local (map make-var kargs args)
+              (make-local (map cons kargs args)
                           ;; gah, this doesn't work
                           ;; identifiers need to be separated earlier
                           ;; not just as part of compilation
@@ -162,13 +161,12 @@
              (split-inlinable bindings))
          (lambda (new-substs uninlinable-bindings)
            (define substs* (append new-substs substs))
-           (make-local (map (lambda (x) (inline x substs*))
+           (make-local (map (match-lambda
+                             ((id . val)
+                              `(,id . ,(inline val substs*))))
                             uninlinable-bindings)
                        (inline body substs*)))))
 
-      (($ var id exp)
-       (make-var id (inline exp substs)))
-
       (($ seq body)
        (make-seq (map (lambda (x) (inline x substs))
                       body)))