mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
05c57a6a66
* module/Makefile.am: * module/language/cps/compile-js.scm: * module/language/cps/spec.scm: * module/language/javascript.scm: * module/language/javascript/spec.scm: * module/language/js-il.scm: * module/language/js-il/compile-javascript.scm: * module/language/js-il/inlining.scm: * module/language/js-il/runtime.js: Update copyright headers
430 lines
16 KiB
Scheme
430 lines
16 KiB
Scheme
;;; 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))))
|