mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 04:10:18 +02:00
Code Activity

Different types for Continuation and Variable identifiers

Browse source
This commit is contained in:
Ian Price 2015-06-18 11:02:05 +01:00
parent 78cacbe450
commit 2e10f55426
4 changed files with 127 additions and 72 deletions
Download patch file Download diff file Expand all files Collapse all files

71
module/language/cps/compile-js.scm
View file

@ -37,39 +37,54 @@
(extract-clauses self clause)) (extract-clauses self clause))
(lambda (jump-table clauses) (lambda (jump-table clauses)
(make-var (make-var
k (make-kid k)
(make-function (make-function
(list self tail) (make-id self) (make-kid tail)
(make-local (map (lambda (clause) (make-local (map (lambda (clause)
(compile-clause clause self tail)) (compile-clause clause self tail))
clauses) clauses)
(make-jump-table jump-table))))))))) (make-jump-table jump-table)))))))))
(define (extract-clauses self clause) (define (extract-clauses self clause)
(define (make-params* self req opts rest kw 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 '())) (let loop ((clause clause) (specs '()) (clauses '()))
(match clause (match clause
(($ $cont k ($ $kclause ($ $arity req opts rest kw allow-other-keys?) _ #f)) (($ $cont k ($ $kclause ($ $arity req opts rest kw allow-other-keys?) _ #f))
(values (reverse (cons (cons (make-params self req opts rest kw allow-other-keys?) k) specs)) (values (reverse (acons (make-params* self req opts rest kw allow-other-keys?)
(make-kid k)
specs))
(reverse (cons clause clauses)))) (reverse (cons clause clauses))))
(($ $cont k ($ $kclause ($ $arity req opts rest kw allow-other-keys?) _ alternate)) (($ $cont k ($ $kclause ($ $arity req opts rest kw allow-other-keys?) _ alternate))
(loop alternate (loop alternate
(cons (cons (make-params self req opts rest kw allow-other-keys?) k) specs) (acons (make-params* self req opts rest kw allow-other-keys?)
(make-kid k)
specs)
(cons clause clauses)))))) (cons clause clauses))))))
(define (compile-clause clause self tail) (define (compile-clause clause self tail)
(match clause (match clause
(($ $cont k ($ $kclause ($ $arity req opt rest ((_ _ kw-syms) ...) _) body _)) (($ $cont k ($ $kclause ($ $arity req opt rest ((_ _ kw-syms) ...) _) body _))
(make-var (make-var
k (make-kid k)
(make-continuation (make-continuation
(append (list self) req opt kw-syms (if rest (list rest) '())) (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 (match body
(($ $cont k ($ $kargs () () exp)) (($ $cont k ($ $kargs () () exp))
(compile-term exp)) (compile-term exp))
(($ $cont k _) (($ $cont k _)
(make-local (list (compile-cont body)) (make-local (list (compile-cont body))
(make-continue (make-continue
k (make-kid k)
(map make-id (append req opt kw-syms (if rest (list rest) '())))))))))))) (map make-id (append req opt kw-syms (if rest (list rest) '()))))))))))))
(define (not-supported msg clause) (define (not-supported msg clause)
@ -86,43 +101,53 @@
(match cont (match cont
(($ $cont k ($ $kargs names syms body)) (($ $cont k ($ $kargs names syms body))
;; use the name part? ;; use the name part?
(make-var k (make-continuation syms (compile-term body)))) (make-var (make-kid k)
(make-continuation (map make-id syms)
(compile-term body))))
(($ $cont k ($ $kreceive ($ $arity req _ (? symbol? rest) _ _) k2)) (($ $cont k ($ $kreceive ($ $arity req _ (? symbol? rest) _ _) k2))
(make-var k (make-var
(make-continuation (append req (list rest)) (make-kid k)
(make-continue k2 (make-continuation (append (map make-id req) (list (make-id rest)))
(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)) (($ $cont k ($ $kreceive ($ $arity req _ #f _ _) k2))
(make-var k (make-continuation req (make-continue k2 (map make-id req))))))) (make-var (make-kid k)
(make-continuation (map make-id req)
(make-continue (make-kid k2)
(map make-id req)))))))
(define (compile-exp exp k) (define (compile-exp exp k)
(match exp (match exp
(($ $branch kt exp) (($ $branch kt exp)
(compile-test exp kt k)) (compile-test exp (make-kid kt) (make-kid k)))
(($ $primcall 'return (arg)) (($ $primcall 'return (arg))
(make-continue k (list (make-id arg)))) (make-continue (make-kid k) (list (make-id arg))))
(($ $call name args) (($ $call name args)
(make-call name (cons k args))) (make-call (make-id name) (make-kid k) (map make-id args)))
(($ $callk label proc args) (($ $callk label proc args)
(make-continue label (map make-id (cons* proc k args)))) (make-continue (make-kid label)
(cons* (make-id proc)
(make-kid k)
(map make-id args))))
(($ $values values) (($ $values values)
(make-continue k (map make-id values))) (make-continue (make-kid k) (map make-id values)))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
(make-seq (make-seq
(list (list
(make-prompt* escape? tag handler) (make-prompt* escape? (make-id tag) (make-kid handler))
(make-continue k '())))) (make-continue (make-kid k) '()))))
(_ (_
(make-continue k (list (compile-exp* exp)))))) (make-continue (make-kid k) (list (compile-exp* exp))))))
(define (compile-exp* exp) (define (compile-exp* exp)
(match exp (match exp
(($ $const val) (($ $const val)
(make-const val)) (make-const val))
(($ $primcall name args) (($ $primcall name args)
(make-primcall name args)) (make-primcall name (map make-id args)))
(($ $closure label nfree) (($ $closure label nfree)
(make-closure label nfree)) (make-closure (make-kid label) nfree))
(($ $values (val)) (($ $values (val))
;; FIXME: ;; FIXME:
;; may happen if a test branch of a conditional compiles to values ;; may happen if a test branch of a conditional compiles to values

42
module/language/js-il.scm
View file

@ -15,8 +15,8 @@
make-call call make-call call
make-closure closure make-closure closure
make-branch branch make-branch branch
make-return return
make-id id make-id id
make-kid kid
make-seq seq make-seq seq
make-prompt prompt make-prompt prompt
)) ))
@ -52,7 +52,7 @@
(format port "#<js-il ~S>" (unparse-js exp))) (format port "#<js-il ~S>" (unparse-js exp)))
(define-js-type program entry body) (define-js-type program entry body)
(define-js-type function params body) (define-js-type function self tail body)
(define-js-type jump-table spec) (define-js-type jump-table spec)
(define-js-type params self req opt rest kw allow-other-keys?) (define-js-type params self req opt rest kw allow-other-keys?)
(define-js-type continuation params body) (define-js-type continuation params body)
@ -61,11 +61,11 @@
(define-js-type continue cont args) (define-js-type continue cont args)
(define-js-type const value) (define-js-type const value)
(define-js-type primcall name args) (define-js-type primcall name args)
(define-js-type call name args) (define-js-type call name k args)
(define-js-type closure label num-free) (define-js-type closure label num-free)
(define-js-type branch test consequence alternate) (define-js-type branch test consequence alternate)
(define-js-type id name) (define-js-type id name)
(define-js-type return val) (define-js-type kid name)
(define-js-type seq body) (define-js-type seq body)
(define-js-type prompt escape? tag handler) (define-js-type prompt escape? tag handler)
@ -74,32 +74,40 @@
(($ program entry body) (($ program entry body)
`(program ,(unparse-js entry) . ,(map unparse-js body))) `(program ,(unparse-js entry) . ,(map unparse-js body)))
(($ continuation params body) (($ continuation params body)
`(continuation ,params ,(unparse-js body))) `(continuation ,(map unparse-js params) ,(unparse-js body)))
(($ function args body) (($ function self tail body)
`(function ,args ,(unparse-js body))) `(function ,self ,tail ,(unparse-js body)))
(($ jump-table body) (($ jump-table body)
`(jump-table ,@(map (lambda (p) `(jump-table ,@(map (lambda (p)
`(,(unparse-js (car p)) . ,(cdr p))) `(,(unparse-js (car p)) . ,(cdr p)))
body))) body)))
(($ params self req opt rest kw allow-other-keys?) (($ params ($ id self) req opt rest kws allow-other-keys?)
`(params ,self ,req ,opt ,rest ,kw ,allow-other-keys?)) `(params ,self
,(map unparse-js req)
,(map unparse-js opt)
,(and rest (unparse-js rest))
,(map (match-lambda
((kw ($ id name) ($ id sym))
(list kw name sym)))
kws)
,allow-other-keys?))
(($ local bindings body) (($ local bindings body)
`(local ,(map unparse-js bindings) ,(unparse-js body))) `(local ,(map unparse-js bindings) ,(unparse-js body)))
(($ var id exp) (($ var id exp)
`(var ,id ,(unparse-js exp))) `(var ,id ,(unparse-js exp)))
(($ continue k args) (($ continue ($ kid k) args)
`(continue ,k ,(map unparse-js args))) `(continue ,k ,(map unparse-js args)))
(($ branch test then else) (($ branch test then else)
`(if ,(unparse-js test) ,(unparse-js then) ,(unparse-js else))) `(if ,(unparse-js test) ,(unparse-js then) ,(unparse-js else)))
(($ const c) (($ const c)
`(const ,c)) `(const ,c))
(($ primcall name args) (($ primcall name args)
`(primcall ,name , args)) `(primcall ,name ,(map unparse-js args)))
(($ call name args) (($ call ($ id name) ($ kid k) args)
`(call ,name , args)) `(call ,name ,k ,(map unparse-js args)))
(($ closure label nfree) (($ closure ($ kid label) nfree)
`(closure ,label ,nfree)) `(closure ,label ,nfree))
(($ return val)
`(return . ,(unparse-js val)))
(($ id name) (($ id name)
`(id . ,name)))) `(id . ,name))
(($ kid name)
`(kid . ,name))))

82
module/language/js-il/compile-javascript.scm
View file

@ -23,12 +23,28 @@
(define *scheme* (make-id "scheme")) (define *scheme* (make-id "scheme"))
(define *utils* (make-refine *scheme* (make-const "utils"))) (define *utils* (make-refine *scheme* (make-const "utils")))
(define (rename-id i)
(match i
(($ il:id i)
(rename i))
(($ il:kid i)
(rename-kont i))))
(define (compile-id i)
(make-id (rename-id i)))
(define (kont->id name)
(make-id (rename-kont name)))
(define (rename-kont name)
(format #f "k_~a" name))
(define (name->id name) (define (name->id name)
(make-id (rename name))) (make-id (rename name)))
(define (rename id) (define (rename id)
(cond ((and (integer? id) (>= id 0)) (cond ((and (integer? id) (>= id 0))
(format #f "k_~a" id)) (format #f "v_~a" id))
((symbol? id) ((symbol? id)
(js-id (symbol->string id))) (js-id (symbol->string id)))
((string? id) ((string? id)
@ -39,7 +55,7 @@
(define (js-id name) (define (js-id name)
(call-with-output-string (call-with-output-string
(lambda (port) (lambda (port)
(display "k_" port) (display "v_" port)
(string-for-each (string-for-each
(lambda (c) (lambda (c)
(if (or (and (char<=? #\a c) (char<=? c #\z)) (if (or (and (char<=? #\a c) (char<=? c #\z))
@ -68,7 +84,7 @@
i i
(ref (make-refine i (make-const (car l))) (ref (make-refine i (make-const (car l)))
(cdr l)))) (cdr l))))
(define this (rename rest)) (define this (rename-id rest))
(make-var this (make-var this
(make-call (ref *scheme* (list "list" "apply")) (make-call (ref *scheme* (list "list" "apply"))
(list (list
@ -78,7 +94,7 @@
(define (bind-opt-args opts num-drop) (define (bind-opt-args opts num-drop)
(map (lambda (opt idx) (map (lambda (opt idx)
(make-var (rename opt) (make-var (rename-id opt)
(make-binop 'or (make-binop 'or
(make-refine (make-id "arguments") (make-refine (make-id "arguments")
(make-const (+ num-drop idx))) (make-const (+ num-drop idx)))
@ -89,7 +105,7 @@
(define (bind-kw-args kws ids num-drop) (define (bind-kw-args kws ids num-drop)
(define lookup (make-refine *utils* (make-const "keyword_ref"))) (define lookup (make-refine *utils* (make-const "keyword_ref")))
(map (lambda (kw id) (map (lambda (kw id)
(make-var (rename id) (make-var (rename-id id)
(make-call lookup (make-call lookup
(list (compile-const kw) (list (compile-const kw)
(make-id "arguments") (make-id "arguments")
@ -105,7 +121,7 @@
(($ il:program (and entry ($ il:var name _)) body) (($ il:program (and entry ($ il:var name _)) body)
(let ((entry-call (let ((entry-call
(make-return (make-return
(make-call (name->id name) (make-call (compile-id name)
(list (list
(make-id "undefined") (make-id "undefined")
(make-refine *scheme* (make-const "initial_cont"))))))) (make-refine *scheme* (make-const "initial_cont")))))))
@ -114,10 +130,11 @@
'()))) '())))
(($ il:continuation params body) (($ il:continuation params body)
(make-function (map rename params) (list (compile-exp body)))) (make-function (map rename-id params) (list (compile-exp body))))
(($ il:function params body) (($ il:function self tail body)
(make-function (map rename params) (list (compile-exp body)))) (make-function (list (rename-id self) (rename-id tail))
(list (compile-exp body))))
(($ il:jump-table specs) (($ il:jump-table specs)
(compile-jump-table specs)) (compile-jump-table specs))
@ -126,10 +143,10 @@
(make-block (append (map compile-exp bindings) (list (compile-exp body))))) (make-block (append (map compile-exp bindings) (list (compile-exp body)))))
(($ il:var id exp) (($ il:var id exp)
(make-var (rename id) (compile-exp exp))) (make-var (rename-id id) (compile-exp exp)))
(($ il:continue k exps) (($ il:continue k exps)
(make-return (make-call (name->id k) (map compile-exp exps)))) (make-return (make-call (compile-id k) (map compile-exp exps))))
(($ il:branch test then else) (($ il:branch test then else)
(make-branch (make-call (make-refine *scheme* (make-const "is_true")) (make-branch (make-call (make-refine *scheme* (make-const "is_true"))
@ -143,29 +160,34 @@
(($ il:primcall name args) (($ il:primcall name args)
(make-call (make-refine (make-refine *scheme* (make-const "primitives")) (make-call (make-refine (make-refine *scheme* (make-const "primitives"))
(make-const (symbol->string name))) (make-const (symbol->string name)))
(map name->id args))) (map compile-id args)))
(($ il:call name args) (($ il:call name k args)
(make-return (make-return
(make-call (make-refine (name->id name) (make-const "fun")) (make-call (make-refine (compile-id name) (make-const "fun"))
(map name->id (cons name args))))) (cons* (compile-id name)
(compile-id k)
(map compile-id args)))))
(($ il:closure label nfree) (($ il:closure label nfree)
(make-new (make-new
(make-call (make-refine *scheme* (make-const "Closure")) (make-call (make-refine *scheme* (make-const "Closure"))
(list (name->id label) (make-const nfree))))) (list (compile-id label) (make-const nfree)))))
(($ il:prompt escape? tag handler) (($ il:prompt escape? tag handler)
;; never a tailcall ;; never a tailcall
(make-call (make-refine (make-refine *scheme* (make-const "primitives")) (make-call (make-refine (make-refine *scheme* (make-const "primitives"))
(make-const "prompt")) (make-const "prompt"))
(list (compile-const escape?) (name->id tag) (name->id handler)))) (list (compile-const escape?) (compile-id tag) (compile-id handler))))
(($ il:seq body) (($ il:seq body)
(make-block (map compile-exp body))) (make-block (map compile-exp body)))
(($ il:id name) (($ il:id name)
(name->id name)))) (name->id name))
(($ il:kid name)
(kont->id name))))
(define (compile-jump-table specs) (define (compile-jump-table specs)
(define offset 2) ; closure & continuation (define offset 2) ; closure & continuation
@ -203,8 +225,8 @@
(($ il:params self req '() #f '() #f) (($ il:params self req '() #f '() #f)
(list (list
(make-return (make-return
(make-call (name->id k) (make-call (compile-id k)
(cons (name->id self) (cons (compile-id self)
(map (lambda (idx) (map (lambda (idx)
(make-refine (make-id "arguments") (make-refine (make-id "arguments")
(make-const (+ offset idx)))) (make-const (+ offset idx))))
@ -213,39 +235,39 @@
(list (list
(bind-rest-args rest (+ offset (length req))) (bind-rest-args rest (+ offset (length req)))
(make-return (make-return
(make-call (name->id k) (make-call (compile-id k)
(append (list (name->id self)) (append (list (compile-id self))
(map (lambda (idx) (map (lambda (idx)
(make-refine (make-id "arguments") (make-refine (make-id "arguments")
(make-const (+ offset idx)))) (make-const (+ offset idx))))
(iota (length req))) (iota (length req)))
(list (name->id rest))))))) (list (compile-id rest)))))))
(($ il:params self req opts #f '() #f) (($ il:params self req opts #f '() #f)
(append (append
(bind-opt-args opts (+ offset (length req))) (bind-opt-args opts (+ offset (length req)))
(list (list
(make-return (make-return
(make-call (name->id k) (make-call (compile-id k)
(append (list (name->id self)) (append (list (compile-id self))
(map (lambda (idx) (map (lambda (idx)
(make-refine (make-id "arguments") (make-refine (make-id "arguments")
(make-const (+ offset idx)))) (make-const (+ offset idx))))
(iota (length req))) (iota (length req)))
(map name->id opts))))))) (map compile-id opts)))))))
(($ il:params self req opts #f ((kws names ids) ...) _) (($ il:params self req opts #f ((kws names ids) ...) _)
(append (append
(bind-opt-args opts (+ offset (length req))) (bind-opt-args opts (+ offset (length req)))
(bind-kw-args kws names (+ offset (length req))) (bind-kw-args kws names (+ offset (length req)))
(list (list
(make-return (make-return
(make-call (name->id k) (make-call (compile-id k)
(append (list (name->id self)) (append (list (compile-id self))
(map (lambda (idx) (map (lambda (idx)
(make-refine (make-id "arguments") (make-refine (make-id "arguments")
(make-const (+ offset idx)))) (make-const (+ offset idx))))
(iota (length req))) (iota (length req)))
(map name->id opts) (map compile-id opts)
(map name->id names))))))) (map compile-id names)))))))
)) ))
(fold-right (lambda (a d) (fold-right (lambda (a d)
(make-branch (compile-test (car a)) (make-branch (compile-test (car a))

4
module/language/js-il/direct.scm
View file

@ -12,8 +12,8 @@
(($ continuation params body) (($ continuation params body)
(make-continuation params (remove-immediate-calls body))) (make-continuation params (remove-immediate-calls body)))
(($ function params body) (($ function self tail body)
(make-function params (remove-immediate-calls body))) (make-function self tail (remove-immediate-calls body)))
(($ local (($ local
(($ var id ($ continuation () body))) (($ var id ($ continuation () body)))