summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorIan Price <ianprice90@googlemail.com>2015-06-21 01:56:01 +0100
committerIan Price <ianprice90@googlemail.com>2015-06-22 16:18:18 +0100
commita680a4cb9d14c705a9248b1281614d1caded5881 (patch)
tree9882a39dcae00dc0c5a2ce1f58d6a9f27e47613c
parente9f37e6a311c0b9fa1ef78b24cbe901e160db2b5 (diff)
downloadguile-a680a4cb9d14c705a9248b1281614d1caded5881.tar.gz
Change local type representation and remove var type
-rw-r--r--module/language/cps/compile-js.scm38
-rw-r--r--module/language/js-il.scm11
-rw-r--r--module/language/js-il/compile-javascript.scm12
-rw-r--r--module/language/js-il/inlining.scm20
4 files changed, 39 insertions, 42 deletions
diff --git a/module/language/cps/compile-js.scm b/module/language/cps/compile-js.scm
index e67652eed..34b1ffe56 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 d83faf5cc..e5fe19683 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 3aa2e5b74..3ef9a950e 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 c2a33db9f..72df2226b 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)))