cwebber pushed a commit to branch compile-to-js-merge
in repository guile.
commit a680a4cb9d14c705a9248b1281614d1caded5881
Author: Ian Price <[email protected]>
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)))
