mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
343 lines
12 KiB
Scheme
343 lines
12 KiB
Scheme
(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)
|
|
#:use-module (language javascript simplify)
|
|
#:use-module (language js-il inlining)
|
|
#:use-module (system foreign)
|
|
#:export (compile-javascript))
|
|
|
|
(define (undefined? obj)
|
|
(define tc8-iflag 4)
|
|
(define unbound-val 9)
|
|
(define unbound-bits (logior (ash unbound-val 8) tc8-iflag))
|
|
(eqv? obj (pointer->scm (make-pointer unbound-bits))))
|
|
|
|
(define (compile-javascript exp env opts)
|
|
(set! exp (inline-single-calls exp))
|
|
(set! exp (compile-exp exp))
|
|
(set! exp (flatten-blocks exp))
|
|
(values exp env env))
|
|
|
|
(define *scheme* (make-id "scheme"))
|
|
(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)
|
|
(make-id (rename name)))
|
|
|
|
(define (rename id)
|
|
(cond ((and (integer? id) (>= id 0))
|
|
(format #f "v_~a" id))
|
|
((symbol? id)
|
|
(js-id (symbol->string id)))
|
|
((string? id)
|
|
(js-id id))
|
|
(else
|
|
(throw 'bad-id id))))
|
|
|
|
(define (js-id name)
|
|
(call-with-output-string
|
|
(lambda (port)
|
|
(display "v_" port)
|
|
(string-for-each
|
|
(lambda (c)
|
|
(if (or (and (char<=? #\a c) (char<=? c #\z))
|
|
(and (char<=? #\A c) (char<=? c #\Z))
|
|
(and (char<=? #\0 c) (char<=? c #\9)))
|
|
(display c port)
|
|
(case c
|
|
((#\-) (display "_h" port))
|
|
((#\_) (display "_u" port))
|
|
((#\?) (display "_p" port))
|
|
((#\!) (display "_x" port))
|
|
((#\<) (display "_l" port))
|
|
((#\>) (display "_g" port))
|
|
((#\=) (display "_e" port))
|
|
((#\*) (display "_s" port))
|
|
((#\+) (display "_a" port))
|
|
((#\\) (display "_b" port))
|
|
((#\/) (display "_f" port))
|
|
(else
|
|
(throw 'bad-id-char c)))))
|
|
name))))
|
|
|
|
(define (bind-rest-args rest num-drop)
|
|
(define (ref i l)
|
|
(if (null? l)
|
|
i
|
|
(ref (make-refine i (make-const (car l)))
|
|
(cdr l))))
|
|
(define this (rename-id rest))
|
|
(make-var this
|
|
(make-call (ref *scheme* (list "list" "apply"))
|
|
(list
|
|
(ref *scheme* (list "list"))
|
|
(make-call (ref (make-id "Array") (list "prototype" "slice" "call"))
|
|
(list (make-id "arguments") (make-const num-drop)))))))
|
|
|
|
(define (bind-opt-args opts num-drop)
|
|
(map (lambda (opt idx)
|
|
(make-var (rename-id opt)
|
|
(make-binop 'or
|
|
(make-refine (make-id "arguments")
|
|
(make-const (+ num-drop idx)))
|
|
(make-refine *scheme* (make-const "UNDEFINED")))))
|
|
opts
|
|
(iota (length opts))))
|
|
|
|
(define (bind-kw-args kws ids num-drop)
|
|
(define lookup (make-refine *utils* (make-const "keyword_ref")))
|
|
(map (lambda (kw id)
|
|
(make-var (rename-id id)
|
|
(make-call lookup
|
|
(list (compile-const kw)
|
|
(make-id "arguments")
|
|
(compile-const num-drop)
|
|
(make-refine *scheme* (make-const "UNDEFINED"))))))
|
|
kws
|
|
ids))
|
|
|
|
|
|
(define (compile-exp exp)
|
|
;; TODO: handle ids for js
|
|
(match exp
|
|
(($ il:program ((name . fun) (names . funs) ...))
|
|
(let ((entry-call
|
|
(make-return
|
|
(make-call (compile-id name)
|
|
(list
|
|
(make-id "undefined")
|
|
(make-refine *scheme* (make-const "initial_cont")))))))
|
|
(make-call (make-function
|
|
'()
|
|
(append
|
|
(map (lambda (id f)
|
|
(make-var (rename-id id)
|
|
(compile-exp f)))
|
|
(cons name names)
|
|
(cons fun funs))
|
|
|
|
(list entry-call)))
|
|
'())))
|
|
|
|
(($ il:continuation params body)
|
|
(make-function (map rename-id params) (list (compile-exp body))))
|
|
|
|
(($ il:function self tail clauses)
|
|
(make-function (list (rename-id self) (rename-id tail))
|
|
(append
|
|
(map (match-lambda
|
|
((id _ body)
|
|
(make-var (rename-id id) (compile-exp body))))
|
|
clauses)
|
|
(list (compile-jump-table clauses)))))
|
|
|
|
(($ 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))))
|
|
|
|
(($ il:branch test then else)
|
|
(make-branch (make-call (make-refine *scheme* (make-const "is_true"))
|
|
(list (compile-exp test)))
|
|
(list (compile-exp then))
|
|
(list (compile-exp else))))
|
|
|
|
(($ il:const c)
|
|
(compile-const c))
|
|
|
|
(($ il:primcall name args)
|
|
(make-call (make-refine (make-refine *scheme* (make-const "primitives"))
|
|
(make-const (symbol->string name)))
|
|
(map compile-id args)))
|
|
|
|
(($ il:call name k args)
|
|
(make-return
|
|
(make-call (make-refine (compile-id name) (make-const "fun"))
|
|
(cons* (compile-id name)
|
|
(compile-id k)
|
|
(map compile-id args)))))
|
|
|
|
(($ il:closure label nfree)
|
|
(make-new
|
|
(make-call (make-refine *scheme* (make-const "Closure"))
|
|
(list (compile-id label) (make-const nfree)))))
|
|
|
|
(($ il:prompt escape? tag handler)
|
|
;; never a tailcall
|
|
(make-call (make-refine (make-refine *scheme* (make-const "primitives"))
|
|
(make-const "prompt"))
|
|
(list (compile-const escape?) (compile-id tag) (compile-id handler))))
|
|
|
|
(($ il:seq body)
|
|
(make-block (map compile-exp body)))
|
|
|
|
(($ il:id name)
|
|
(name->id name))
|
|
|
|
(($ il:kid name)
|
|
(kont->id name))))
|
|
|
|
(define (compile-jump-table specs)
|
|
(define offset 2) ; closure & continuation
|
|
(define (compile-test params)
|
|
(match params
|
|
(($ il:params self req '() #f '() #f)
|
|
(make-binop '=
|
|
(make-refine (make-id "arguments")
|
|
(make-const "length"))
|
|
(make-const (+ offset (length req)))))
|
|
(($ il:params self req '() rest '() #f)
|
|
(make-binop '>=
|
|
(make-refine (make-id "arguments")
|
|
(make-const "length"))
|
|
(make-const (+ offset (length req)))))
|
|
(($ il:params self req opts #f '() #f)
|
|
(make-binop 'and
|
|
(make-binop '<=
|
|
(make-const (+ offset (length req)))
|
|
(make-refine (make-id "arguments")
|
|
(make-const "length")))
|
|
(make-binop '<=
|
|
(make-refine (make-id "arguments")
|
|
(make-const "length"))
|
|
(make-const (+ offset (length req) (length opts))))))
|
|
;; FIXME: need to handle allow-other-keys? and testing for actual keywords
|
|
(($ il:params self req opts #f kwargs _)
|
|
(make-binop '<=
|
|
(make-const (+ offset (length req)))
|
|
(make-refine (make-id "arguments")
|
|
(make-const "length"))))
|
|
))
|
|
(define (compile-jump params k)
|
|
(match params
|
|
(($ il:params self req '() #f '() #f)
|
|
(list
|
|
(make-return
|
|
(make-call (compile-id k)
|
|
(cons (compile-id self)
|
|
(map (lambda (idx)
|
|
(make-refine (make-id "arguments")
|
|
(make-const (+ offset idx))))
|
|
(iota (length req))))))))
|
|
(($ il:params self req '() rest '() #f)
|
|
(list
|
|
(bind-rest-args rest (+ offset (length req)))
|
|
(make-return
|
|
(make-call (compile-id k)
|
|
(append (list (compile-id self))
|
|
(map (lambda (idx)
|
|
(make-refine (make-id "arguments")
|
|
(make-const (+ offset idx))))
|
|
(iota (length req)))
|
|
(list (compile-id rest)))))))
|
|
(($ il:params self req opts #f '() #f)
|
|
(append
|
|
(bind-opt-args opts (+ offset (length req)))
|
|
(list
|
|
(make-return
|
|
(make-call (compile-id k)
|
|
(append (list (compile-id self))
|
|
(map (lambda (idx)
|
|
(make-refine (make-id "arguments")
|
|
(make-const (+ offset idx))))
|
|
(iota (length req)))
|
|
(map compile-id opts)))))))
|
|
(($ il:params self req opts #f ((kws names ids) ...) _)
|
|
(append
|
|
(bind-opt-args opts (+ offset (length req)))
|
|
(bind-kw-args kws names (+ offset (length req)))
|
|
(list
|
|
(make-return
|
|
(make-call (compile-id k)
|
|
(append (list (compile-id self))
|
|
(map (lambda (idx)
|
|
(make-refine (make-id "arguments")
|
|
(make-const (+ offset idx))))
|
|
(iota (length req)))
|
|
(map compile-id opts)
|
|
(map compile-id names)))))))
|
|
))
|
|
(fold-right (lambda (a d)
|
|
(match a
|
|
((id params _)
|
|
(make-branch (compile-test params)
|
|
(compile-jump params id)
|
|
(list d)))))
|
|
;; FIXME: should throw an error
|
|
(make-return (make-id "undefined"))
|
|
specs))
|
|
|
|
(define (compile-const c)
|
|
(cond ((number? c)
|
|
(make-const c))
|
|
((eqv? c #t)
|
|
(make-refine *scheme* (make-const "TRUE")))
|
|
((eqv? c #f)
|
|
(make-refine *scheme* (make-const "FALSE")))
|
|
((eqv? c '())
|
|
(make-refine *scheme* (make-const "EMPTY")))
|
|
((unspecified? c)
|
|
(make-refine *scheme* (make-const "UNSPECIFIED")))
|
|
((symbol? c)
|
|
(make-new
|
|
(make-call
|
|
(make-refine *scheme* (make-const "Symbol"))
|
|
(list (make-const (symbol->string c))))))
|
|
((list? c)
|
|
(make-call
|
|
(make-refine *scheme* (make-const "list"))
|
|
(map compile-const c)))
|
|
((string? c)
|
|
(make-new
|
|
(make-call
|
|
(make-refine *scheme* (make-const "String"))
|
|
(list (make-const c)))))
|
|
((pair? c)
|
|
(make-new
|
|
(make-call
|
|
(make-refine *scheme* (make-const "Pair"))
|
|
(list (compile-const (car c))
|
|
(compile-const (cdr c))))))
|
|
((vector? c)
|
|
(make-new
|
|
(make-call
|
|
(make-refine *scheme* (make-const "Vector"))
|
|
(map compile-const (vector->list c)))))
|
|
((char? c)
|
|
(make-new
|
|
(make-call
|
|
(make-refine *scheme* (make-const "Char"))
|
|
(list (make-const (string c))))))
|
|
((keyword? c)
|
|
(make-new
|
|
(make-call
|
|
(make-refine *scheme* (make-const "Keyword"))
|
|
(list (make-const (symbol->string (keyword->symbol c)))))))
|
|
((undefined? c)
|
|
(make-refine *scheme* (make-const "UNDEFINED")))
|
|
(else
|
|
(throw 'uncompilable-const c))))
|