summaryrefslogtreecommitdiff
path: root/module/language/js-il/compile-javascript.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/js-il/compile-javascript.scm')
-rw-r--r--module/language/js-il/compile-javascript.scm430
1 files changed, 430 insertions, 0 deletions
diff --git a/module/language/js-il/compile-javascript.scm b/module/language/js-il/compile-javascript.scm
new file mode 100644
index 000000000..a6c399451
--- /dev/null
+++ b/module/language/js-il/compile-javascript.scm
@@ -0,0 +1,430 @@
+;;; JavaScript Intermediate Language (JS-IL) to Javascript Compiler
+
+;; Copyright (C) 2015, 2017 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(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)
+ #:use-module (system syntax internal)
+ #: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)
+ (match (memq #:js-inline? opts)
+ ((#:js-inline? #f _ ...) #f)
+ (_ (set! exp (inline-single-calls exp))))
+ (set! exp (compile-exp exp))
+ (match (memq #:js-flatten? opts)
+ ((#:js-flatten? #f _ ...) #f)
+ (_ (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))
+ ((#\%) (display "_c" port))
+ ((#\$) (display "_d" port))
+ ((#\~) (display "_t" port))
+ ((#\^) (display "_i" port))
+ ((#\&) (display "_j" port))
+ ((#\:) (display "_k" port))
+ ((#\@) (display "_m" port))
+ ;; unused: noqrvxy
+ (else
+ (display "_z" port)
+ (display (char->integer c) port)))))
+ 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)
+ (let ((arg (make-refine (make-id "arguments")
+ (make-const (+ num-drop idx)))))
+ (make-ternary (make-binop '===
+ (make-prefix 'typeof arg)
+ (make-id "undefined"))
+ (make-refine *scheme* (make-const "UNDEFINED"))
+ arg))))
+ 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 (bind-opt-kw-args opts kws ids num-drop)
+ ;; FIXME: what we really need is a rewrite of all the complex argument
+ ;; handling , not another special case.
+ ;; NB: our generated IDs will not clash since they are not prefixed
+ ;; with k_ or v_
+ (define skip? (make-id "skip"))
+ (define skip-idx (make-id "skip_idx"))
+ (define (bind-opt-args opts num-drop)
+ (map (lambda (opt idx)
+ (make-var (rename-id opt)
+ (let ((arg (make-refine (make-id "arguments")
+ (make-const (+ num-drop idx)))))
+ (make-ternary (make-binop 'or
+ skip?
+ (make-binop '===
+ (make-prefix 'typeof arg)
+ (make-id "undefined")))
+ (make-refine *scheme* (make-const "UNDEFINED"))
+ (make-ternary (make-binop 'instanceof
+ arg
+ (make-refine *scheme* (make-const "Keyword")))
+ (make-binop 'begin
+ (make-assign "skip" (compile-const #t))
+ (make-refine *scheme* (make-const "UNDEFINED")))
+ (make-binop 'begin
+ (make-assign "skip_idx" (make-binop '+ skip-idx (make-const 1)))
+ arg))))))
+ opts
+ (iota (length opts))))
+ (define (bind-kw-args kws ids)
+ (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")
+ skip-idx
+ (make-refine *scheme* (make-const "UNDEFINED"))))))
+ kws
+ ids))
+ (append (list (make-var "skip" (compile-const #f))
+ (make-var "skip_idx" (compile-const num-drop)))
+ (bind-opt-args opts num-drop)
+ (bind-kw-args 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-id "unit_cont"))))))
+ (make-function
+ (list "unit_cont")
+ (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-kw-args opts 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")))
+ ((syntax? c)
+ (make-call
+ (make-refine *scheme* (make-const "Syntax"))
+ (map compile-const
+ (list (syntax-expression c)
+ (syntax-wrap c)
+ (syntax-module c)))))
+ (else
+ (throw 'uncompilable-const c))))