[Guile-commits] 34/99: Change function type representation

[Christopher Allan Webber]

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

commit e9f37e6a311c0b9fa1ef78b24cbe901e160db2b5
Author: Ian Price <ianprice90@googlemail.com>
AuthorDate: Sun Jun 21 00:45:09 2015 +0100

    Change function type representation
---
 module/language/cps/compile-js.scm           | 87 ++++++++++++----------------
 module/language/js-il.scm                    | 19 +++---
 module/language/js-il/compile-javascript.scm | 20 ++++---
 module/language/js-il/inlining.scm           | 24 +++-----
 4 files changed, 68 insertions(+), 82 deletions(-)

diff --git a/module/language/cps/compile-js.scm 
b/module/language/cps/compile-js.scm
index c1de2bc..e67652e 100644
--- a/module/language/cps/compile-js.scm
+++ b/module/language/cps/compile-js.scm
@@ -35,61 +35,48 @@
 (define (compile-fun fun)
   (match fun
     (($ $kfun _ _ self ($ $cont tail ($ $ktail)) clause)
-     (call-with-values
-         (lambda ()
-           (extract-clauses self clause))
-       (lambda (jump-table clauses)
-         (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)
+      (compile-clauses clause self)))))
 
-(define (extract-clauses self clause)
-  (define (make-params* self req opts rest kw allow-other-keys?)
-    (make-params (make-id self)
+(define (compile-clauses clause self)
+  (match clause
+    (($ $cont k ($ $kclause arity body #f))
+     `((,(make-kid k)
+        ,(arity->params arity self)
+        ,(compile-clause arity body self))))
+    (($ $cont k ($ $kclause arity body next))
+     `((,(make-kid k)
+        ,(arity->params arity self)
+        ,(compile-clause arity body self))
+       . ,(compile-clauses next self)))))
+
+(define (arity->params arity self)
+  (match arity
+    (($ $arity req opts rest ((kws names kw-syms) ...) 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 (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
-             (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
-      (make-kid k)
-      (make-continuation
-       (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
-                       (make-kid k)
-                       (map make-id (append req opt kw-syms (if rest (list 
rest) '()))))))))))))
+                  (map (lambda (kw name kw-sym)
+                         (list kw (make-id name) (make-id kw-sym)))
+                       kws
+                       names
+                       kw-syms)
+                  allow-other-keys?))))
 
-(define (not-supported msg clause)
-  (error 'not-supported msg clause))
+(define (compile-clause arity body self)
+  (match arity
+    (($ $arity req opt rest ((_ _ kw-syms) ...) _)
+     (let ((ids (map make-id
+                     (append req opt kw-syms (if rest (list rest) '())))))
+       (make-continuation
+        (cons (make-id self) ids)
+        (match body
+          (($ $cont k _)
+           (make-local (list (compile-cont body))
+                       (make-continue (make-kid k) ids)))))))))
 
 (define (compile-term term)
   (match term
diff --git a/module/language/js-il.scm b/module/language/js-il.scm
index 8eb26a3..d83faf5 100644
--- a/module/language/js-il.scm
+++ b/module/language/js-il.scm
@@ -4,7 +4,6 @@
   #:use-module (ice-9 match)
   #:export (make-program program
             make-function function
-            make-jump-table jump-table
             make-params params
             make-continuation continuation
             make-local local
@@ -52,8 +51,7 @@
   (format port "#<js-il ~S>" (unparse-js exp)))
 
 (define-js-type program body)
-(define-js-type function self tail body)
-(define-js-type jump-table spec)
+(define-js-type function self tail clauses)
 (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
@@ -78,12 +76,15 @@
                        body)))
     (($ continuation params 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)))
+    (($ function ($ id self) ($ kid tail) clauses)
+     `(function ,self
+                ,tail
+                ,@(map (match-lambda
+                        ((($ kid id) params kont)
+                         (list id
+                               (unparse-js params)
+                               (unparse-js kont))))
+                       clauses)))
     (($ params ($ id self) req opt rest kws allow-other-keys?)
      `(params ,self
               ,(map unparse-js req)
diff --git a/module/language/js-il/compile-javascript.scm 
b/module/language/js-il/compile-javascript.scm
index 7d9140d..3aa2e5b 100644
--- a/module/language/js-il/compile-javascript.scm
+++ b/module/language/js-il/compile-javascript.scm
@@ -140,12 +140,14 @@
     (($ il:continuation params body)
      (make-function (map rename-id params) (list (compile-exp body))))
 
-    (($ il:function self tail body)
+    (($ il:function self tail clauses)
      (make-function (list (rename-id self) (rename-id tail))
-                    (list (compile-exp body))))
-
-    (($ il:jump-table specs)
-     (compile-jump-table specs))
+                    (append
+                     (map (match-lambda
+                           ((id _ body)
+                            (make-var (rename-id id) (compile-exp body))))
+                          clauses)
+                     (list (compile-jump-table clauses)))))
 
     (($ il:local bindings body)
      (make-block (append (map compile-exp bindings) (list (compile-exp 
body)))))
@@ -278,9 +280,11 @@
                              (map compile-id names)))))))
       ))
   (fold-right (lambda (a d)
-                (make-branch (compile-test (car a))
-                             (compile-jump (car a) (cdr a))
-                             (list d)))
+                (match a
+                  ((id params _)
+                   (make-branch (compile-test params)
+                                (compile-jump params id)
+                                (list d)))))
               ;; FIXME: should throw an error
               (make-return (make-id "undefined"))
               specs))
diff --git a/module/language/js-il/inlining.scm 
b/module/language/js-il/inlining.scm
index 14e25bd..c2a33db 100644
--- a/module/language/js-il/inlining.scm
+++ b/module/language/js-il/inlining.scm
@@ -23,12 +23,9 @@
       (($ program ((ids . funs) ...))
        (for-each analyse funs))
 
-      (($ function self tail body)
-       (analyse body))
-
-      (($ jump-table spec)
-       (for-each (lambda (p) (analyse (cdr p)))
-                 spec))
+      (($ function self tail ((($ kid ids) _ bodies) ...))
+       (for-each count-inc! ids) ;; count-inf! ?
+       (for-each analyse bodies))
 
       (($ continuation params body)
        (analyse body))
@@ -184,18 +181,15 @@
       (exp exp)))
 
   (define (handle-function fun)
-    (define (handle-bindings bindings)
-      (map (lambda (binding)
-             (match binding
-               (($ var id ($ continuation params body))
-                (make-var id (make-continuation params (inline body '()))))))
-           bindings))
     (match fun
-      (($ function self tail ($ local bindings ($ jump-table spec)))
+      (($ function self tail ((ids params bodies) ...))
        (make-function self
                       tail
-                      (make-local (handle-bindings bindings)
-                                  (make-jump-table spec))))))
+                      (map (lambda (id param body)
+                             (list id param (inline body '())))
+                           ids
+                           params
+                           bodies)))))
 
   (match exp
     (($ program ((ids . funs) ...))