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

Change function type representation

Browse source
This commit is contained in:
Ian Price 2015-06-21 00:45:09 +01:00
parent a7b2dfa581
commit e9f37e6a31
4 changed files with 68 additions and 82 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -35,61 +35,48 @@
(define (compile-fun fun) (define (compile-fun fun)
(match fun (match fun
(($ $kfun _ _ self ($ $cont tail ($ $ktail)) clause) (($ $kfun _ _ self ($ $cont tail ($ $ktail)) clause)
(call-with-values (make-function
(lambda () (make-id self)
(extract-clauses self clause)) (make-kid tail)
(lambda (jump-table clauses) (compile-clauses clause self)))))
(make-function
(make-id self) (make-kid tail)
(make-local (map (lambda (clause)
(compile-clause clause self tail))
clauses)
(make-jump-table jump-table))))))))
(define (extract-clauses self clause) (define (compile-clauses clause self)
(define (make-params* self req opts rest kw allow-other-keys?) (match clause
(make-params (make-id self) (($ $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 req)
(map make-id opts) (map make-id opts)
(and rest (make-id rest)) (and rest (make-id rest))
(map make-id kw) (map (lambda (kw name kw-sym)
allow-other-keys?)) (list kw (make-id name) (make-id kw-sym)))
(let loop ((clause clause) (specs '()) (clauses '())) kws
(match clause names
(($ $cont k ($ $kclause ($ $arity req opts rest kw allow-other-keys?) _ #f)) kw-syms)
(values (reverse (acons (make-params* self req opts rest kw allow-other-keys?) 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) (define (compile-clause arity body self)
(match clause (match arity
(($ $cont k ($ $kclause ($ $arity req opt rest ((_ _ kw-syms) ...) _) body _)) (($ $arity req opt rest ((_ _ kw-syms) ...) _)
(make-var (let ((ids (map make-id
(make-kid k) (append req opt kw-syms (if rest (list rest) '())))))
(make-continuation (make-continuation
(append (list (make-id self)) (cons (make-id self) ids)
(map make-id req) (match body
(map make-id opt) (($ $cont k _)
(map make-id kw-syms) (make-local (list (compile-cont body))
(if rest (list (make-id rest)) '())) (make-continue (make-kid k) ids)))))))))
(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) '()))))))))))))
(define (not-supported msg clause)
(error 'not-supported msg clause))
(define (compile-term term) (define (compile-term term)
(match term (match term

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

@ -4,7 +4,6 @@
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:export (make-program program #:export (make-program program
make-function function make-function function
make-jump-table jump-table
make-params params make-params params
make-continuation continuation make-continuation continuation
make-local local make-local local
@ -52,8 +51,7 @@
(format port "#<js-il ~S>" (unparse-js exp))) (format port "#<js-il ~S>" (unparse-js exp)))
(define-js-type program body) (define-js-type program body)
(define-js-type function self tail body) (define-js-type function self tail clauses)
(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)
(define-js-type local bindings body) ; local scope (define-js-type local bindings body) ; local scope
@ -78,12 +76,15 @@
body))) body)))
(($ continuation params body) (($ continuation params body)
`(continuation ,(map unparse-js params) ,(unparse-js body))) `(continuation ,(map unparse-js params) ,(unparse-js body)))
(($ function self tail body) (($ function ($ id self) ($ kid tail) clauses)
`(function ,self ,tail ,(unparse-js body))) `(function ,self
(($ jump-table body) ,tail
`(jump-table ,@(map (lambda (p) ,@(map (match-lambda
`(,(unparse-js (car p)) . ,(cdr p))) ((($ kid id) params kont)
body))) (list id
(unparse-js params)
(unparse-js kont))))
clauses)))
(($ params ($ id self) req opt rest kws allow-other-keys?) (($ params ($ id self) req opt rest kws allow-other-keys?)
`(params ,self `(params ,self
,(map unparse-js req) ,(map unparse-js req)

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

@ -140,12 +140,14 @@
(($ il:continuation params body) (($ il:continuation params body)
(make-function (map rename-id params) (list (compile-exp 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)) (make-function (list (rename-id self) (rename-id tail))
(list (compile-exp body)))) (append
(map (match-lambda
(($ il:jump-table specs) ((id _ body)
(compile-jump-table specs)) (make-var (rename-id id) (compile-exp body))))
clauses)
(list (compile-jump-table clauses)))))
(($ il:local bindings body) (($ il:local bindings body)
(make-block (append (map compile-exp bindings) (list (compile-exp body))))) (make-block (append (map compile-exp bindings) (list (compile-exp body)))))
@ -278,9 +280,11 @@
(map compile-id names))))))) (map compile-id names)))))))
)) ))
(fold-right (lambda (a d) (fold-right (lambda (a d)
(make-branch (compile-test (car a)) (match a
(compile-jump (car a) (cdr a)) ((id params _)
(list d))) (make-branch (compile-test params)
(compile-jump params id)
(list d)))))
;; FIXME: should throw an error ;; FIXME: should throw an error
(make-return (make-id "undefined")) (make-return (make-id "undefined"))
specs)) specs))

24
module/language/js-il/inlining.scm
View file

@ -23,12 +23,9 @@
(($ program ((ids . funs) ...)) (($ program ((ids . funs) ...))
(for-each analyse funs)) (for-each analyse funs))
(($ function self tail body) (($ function self tail ((($ kid ids) _ bodies) ...))
(analyse body)) (for-each count-inc! ids) ;; count-inf! ?
(for-each analyse bodies))
(($ jump-table spec)
(for-each (lambda (p) (analyse (cdr p)))
spec))
(($ continuation params body) (($ continuation params body)
(analyse body)) (analyse body))
@ -184,18 +181,15 @@
(exp exp))) (exp exp)))
(define (handle-function fun) (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 (match fun
(($ function self tail ($ local bindings ($ jump-table spec))) (($ function self tail ((ids params bodies) ...))
(make-function self (make-function self
tail tail
(make-local (handle-bindings bindings) (map (lambda (id param body)
(make-jump-table spec)))))) (list id param (inline body '())))
ids
params
bodies)))))
(match exp (match exp
(($ program ((ids . funs) ...)) (($ program ((ids . funs) ...))