mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 17:20:29 +02:00
Code Activity

Handle case-lambda via a jump table

Browse source
This commit is contained in:
Ian Price 2015-06-09 17:08:09 +01:00
parent 30afdcd976
commit 44e04eae0a
3 changed files with 97 additions and 28 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -30,29 +30,47 @@
(define (compile-fun fun)
(match fun
(($ $cont k ($ $kfun src meta self ($ $cont tail ($ $ktail)) clause))
(make-var k (compile-clause clause self tail)))))
(($ $cont k ($ $kfun _ _ self ($ $cont tail ($ $ktail)) clause))
(call-with-values
(lambda ()
(extract-clauses self clause))
(lambda (jump-table clauses)
(make-var
k
(make-function
(list self tail)
(make-local (map (lambda (clause)
(compile-clause clause self tail))
clauses)
(make-jump-table jump-table)))))))))
(define (extract-clauses self clause)
(let loop ((clause clause) (specs '()) (clauses '()))
(match clause
(($ $cont k ($ $kclause ($ $arity req _ rest _ _) _ #f))
(values (reverse (cons (cons (make-params self req rest) k) specs))
(reverse (cons clause clauses))))
(($ $cont k ($ $kclause ($ $arity req _ rest _ _) _ alternate))
(loop alternate
(cons (cons (make-params self req rest) k) specs)
(cons clause clauses))))))
(define (compile-clause clause self tail)
(match clause
(($ $cont k ($ $kclause ($ $arity req opt rest kw allow-other-keys?)
body alternate))
;; add function argument prelude
(unless (null? opt)
(not-supported "optional arguments are not supported" clause))
(unless (or (null? kw) allow-other-keys?)
(not-supported "keyword arguments are not supported" clause))
(when alternate
(not-supported "alternate continuations are not supported" clause))
(make-function (make-params self (cons tail req) rest)
(match body
(($ $cont k ($ $kargs () () exp))
(compile-term exp))
(($ $cont k _)
(make-local (list (compile-cont body))
(make-continue
k
(map make-id (append req (if rest (list rest) '())))))))))))
(($ $cont k ($ $kclause ($ $arity req _ rest _) body _))
(make-var
k
(make-continuation
(append (list self)
req (if rest (list rest) '()))
(match body
(($ $cont k ($ $kargs () () exp))
(compile-term exp))
(($ $cont k _)
(make-local (list (compile-cont body))
(make-continue
k
(map make-id (append req (if rest (list rest) '()))))))))))))
(define (not-supported msg clause)
(error 'not-supported msg clause))

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

@ -4,6 +4,7 @@
#: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
@ -50,6 +51,7 @@
(define-js-type program entry body)
(define-js-type function params body)
(define-js-type jump-table spec)
(define-js-type params self req rest)
(define-js-type continuation params body)
(define-js-type local bindings body) ; local scope
@ -69,8 +71,14 @@
`(program ,(unparse-js entry) . ,(map unparse-js body)))
(($ continuation params body)
`(continuation ,params ,(unparse-js body)))
(($ function ($ params self req opt) body)
`(function ,(append (list self) req (if opt (list opt) '())) ,(unparse-js body)))
(($ function args body)
`(function ,args ,(unparse-js body)))
(($ jump-table body)
`(jump-table ,@(map (lambda (p)
`(,(unparse-js (car p)) . ,(cdr p)))
body)))
(($ params self req rest)
`(params ,self ,req ,rest))
(($ local bindings body)
`(local ,(map unparse-js bindings) ,(unparse-js body)))
(($ var id exp)

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

@ -1,4 +1,5 @@
(define-module (language js-il compile-javascript)
#:use-module ((srfi srfi-1) #:select (fold-right))
#:use-module (ice-9 match)
#:use-module ((language js-il) #:renamer (symbol-prefix-proc 'il:))
#:use-module (language javascript)
@ -81,13 +82,11 @@
(($ il:continuation params body)
(make-function (map rename params) (list (compile-exp body))))
(($ il:function ($ il:params self req #f) body)
(make-function (map rename (cons self req)) (list (compile-exp body))))
(($ il:function params body)
(make-function (map rename params) (list (compile-exp body))))
(($ il:function ($ il:params self req rest) body)
(make-function (map rename (cons self req))
(list (bind-rest-args rest (length (cons self req)))
(compile-exp body))))
(($ il:jump-table specs)
(compile-jump-table specs))
(($ il:local bindings body)
(make-block (append (map compile-exp bindings) (list (compile-exp body)))))
@ -125,6 +124,50 @@
(($ il:id name)
(name->id name))))
(define (compile-jump-table specs)
(define offset 2) ; closure & continuation
(define (compile-test params)
(match params
(($ il:params self req #f)
(make-binop '=
(make-refine (make-id "arguments")
(make-const "length"))
(make-const (+ offset (length req)))))
(($ il:params self req rest)
(make-binop '>=
(make-refine (make-id "arguments")
(make-const "length"))
(make-const (+ offset (length req)))))))
(define (compile-jump params k)
(match params
(($ il:params self req #f)
(list
(make-return
(make-call (name->id k)
(cons (name->id self)
(map (lambda (idx)
(make-refine (make-id "arguments")
(make-const (+ offset idx))))
(iota (length req))))))))
(($ il:params self req rest)
(list
(bind-rest-args rest (+ offset (length req)))
(make-return
(make-call (name->id k)
(append (list (name->id self))
(map (lambda (idx)
(make-refine (make-id "arguments")
(make-const (+ offset idx))))
(iota (length req)))
(list (name->id rest)))))))))
(fold-right (lambda (a d)
(make-branch (compile-test (car a))
(compile-jump (car a) (cdr a))
(list d)))
;; FIXME: should throw an error
(make-return (make-id "undefined"))
specs))
(define (compile-const c)
(cond ((number? c)
(make-const c))