Merge branch 'compile-to-js-2017' into compile-to-js-rebase

module/Makefile.am

@@ -29,6 +29,7 @@ $(VM_TARGETS): $(top_builddir)/libguile/vm-operations.h
 
 ice-9/boot-9.go: ice-9/boot-9.scm ice-9/quasisyntax.scm ice-9/r6rs-libraries.scm ice-9/r7rs-libraries.scm ice-9/read.scm
 ice-9/match.go: ice-9/match.scm ice-9/match.upstream.scm
+
 srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm
 $(nobase_ccache_DATA): ../bootstrap/ice-9/eval.go
 
@@ -179,6 +180,42 @@ SOURCES =					\
   language/bytecode.scm				\
   language/bytecode/spec.scm			\
 						\
+  language/cps.scm				\
+  language/cps/closure-conversion.scm		\
+  language/cps/compile-bytecode.scm		\
+  language/cps/compile-js.scm			\
+  language/cps/constructors.scm			\
+  language/cps/contification.scm		\
+  language/cps/cse.scm				\
+  language/cps/dce.scm				\
+  language/cps/effects-analysis.scm		\
+  language/cps/elide-values.scm			\
+  language/cps/handle-interrupts.scm		\
+  language/cps/intmap.scm			\
+  language/cps/intset.scm			\
+  language/cps/licm.scm				\
+  language/cps/optimize.scm			\
+  language/cps/peel-loops.scm			\
+  language/cps/primitives.scm			\
+  language/cps/prune-bailouts.scm		\
+  language/cps/prune-top-level-scopes.scm	\
+  language/cps/reify-primitives.scm		\
+  language/cps/renumber.scm			\
+  language/cps/rotate-loops.scm			\
+  language/cps/self-references.scm		\
+  language/cps/simplify.scm			\
+  language/cps/slot-allocation.scm		\
+  language/cps/spec.scm				\
+  language/cps/specialize-primcalls.scm		\
+  language/cps/specialize-numbers.scm		\
+  language/cps/split-rec.scm			\
+  language/cps/type-checks.scm			\
+  language/cps/type-fold.scm			\
+  language/cps/types.scm			\
+  language/cps/utils.scm			\
+  language/cps/verify.scm			\
+  language/cps/with-cps.scm			\
+						\
   language/ecmascript/tokenize.scm		\
   language/ecmascript/parse.scm			\
   language/ecmascript/impl.scm			\
@@ -198,6 +235,16 @@ SOURCES =					\
   language/elisp/runtime/value-slot.scm		\
   language/elisp/spec.scm			\
 						\
+  language/javascript.scm			\
+  language/javascript/simplify.scm		\
+  language/javascript/spec.scm			\
+						\
+  language/js-il.scm				\
+  language/js-il/inlining.scm			\
+  language/js-il/compile-javascript.scm		\
+  language/js-il/runtime.js			\
+  language/js-il/spec.scm			\
+						\
   language/scheme/compile-tree-il.scm		\
   language/scheme/decompile-tree-il.scm		\
   language/scheme/spec.scm			\
@@ -265,6 +312,7 @@ SOURCES =					\
   scripts/frisk.scm				\
   scripts/generate-autoload.scm			\
   scripts/help.scm				\
+  scripts/jslink.scm				\
   scripts/lint.scm				\
   scripts/list.scm				\
   scripts/punify.scm				\

module/language/cps/compile-js.scm

@@ -0,0 +1,201 @@
+;;; Continuation-passing style (CPS) to JS-IL 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 cps compile-js)
+  #:use-module (language cps)
+  #:use-module (language cps intmap)
+  #:use-module (language cps utils)
+  #:use-module ((language js-il)
+                #:renamer (lambda (x) (if (eqv? x 'make-prompt) 'make-prompt* x)))
+  #:use-module (ice-9 match)
+  #:use-module ((srfi srfi-1) #:select (append-map))
+  #:export (compile-js))
+
+(define intmap-select (@@ (language cps compile-bytecode) intmap-select))
+(define lower-cps (@@ (language cps compile-bytecode) lower-cps))
+
+(define (compile-js exp env opts)
+  ;; TODO: I should special case the compilation for the initial fun,
+  ;; as this is the entry point for the program, and shouldn't get a
+  ;; "self" argument, for now, I add "undefined" as the first
+  ;; argument in the call to it.
+  ;; see compile-exp in (language js-il compile-javascript)
+  (define (intmap->program map)
+    (intmap-fold-right (lambda (kfun body accum)
+                         (acons (make-kid kfun)
+                                (compile-fun (intmap-select map body) kfun)
+                                accum))
+                       (compute-reachable-functions map 0)
+                       '()))
+  (values (make-program (intmap->program (lower-cps exp opts))) env env))
+
+
+(define (compile-fun cps kfun)
+  (define doms (compute-dom-edges (compute-idoms cps kfun)))
+  (match (intmap-ref cps kfun)
+    (($ $kfun src meta self tail clause)
+     (make-function
+      (make-id self)
+      (make-kid tail)
+      (compile-clauses cps doms clause self)))))
+
+
+(define (extract-and-compile-conts cps)
+  (define (step id body accum)
+    (match body
+      ;; The term in a $kargs is always a $continue
+      (($ $kargs names syms ($ $continue k src exp))
+       (acons (make-kid id)
+              (make-continuation (map make-id syms) (compile-exp exp k))
+              accum))
+      (($ $kreceive ($ $arity req _ (? symbol? rest) _ _) k2)
+       (let ((ids (map make-id (append req (list rest)))))
+         (acons (make-kid id)
+                (make-continuation ids (make-continue (make-kid k2) ids))
+                accum)))
+      (($ $kreceive ($ $arity req _ #f _ _) k2)
+       (let ((ids (map make-id req)))
+         (acons (make-kid id)
+                (make-continuation ids (make-continue (make-kid k2) ids))
+                accum)))
+      (else accum)))
+  (intmap-fold step cps '()))
+
+
+(define (compile-clauses cps doms clause self)
+  ;; FIXME: This duplicates all the conts in each clause, and requires
+  ;; the inliner to remove them. A better solution is to change the
+  ;; function type to contain a separate map of conts, but this requires
+  ;; more code changes, and is should constitute a separate commit.
+  (let loop ((clause clause))
+   (match (intmap-ref cps clause)
+     (($ $kclause arity body #f)
+      `((,(make-kid clause)
+         ,(arity->params arity self)
+         ,(compile-clause cps doms arity body self))))
+     (($ $kclause arity body next)
+      `((,(make-kid clause)
+         ,(arity->params arity self)
+         ,(compile-clause cps doms arity body self))
+        . ,(loop next))))))
+
+
+(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 opts)
+                  (and rest (make-id rest))
+                  (map (lambda (kw name kw-sym)
+                         (list kw (make-id name) (make-id kw-sym)))
+                       kws
+                       names
+                       kw-syms)
+                  allow-other-keys?))))
+
+
+(define (compile-clause cps doms arity body self)
+  (match arity
+    (($ $arity req opt rest ((_ _ kw-syms) ...) _)
+     (let ((ids (map make-id
+                     (append req opt kw-syms (if rest (list rest) '())))))
+       (make-continuation
+        (cons (make-id self) ids)
+        (make-local (list (cons (make-kid body) (compile-cont cps doms body)))
+                    (make-continue (make-kid body) ids)))))))
+
+(define (compile-cont cps doms cont)
+  (define (redominate label exp)
+    ;; This ensures that functions which are dominated by a $kargs [e.g.
+    ;; because they need its arguments] are moved into its body, and so
+    ;; we get correct scoping.
+    (define (find&compile-dominated label)
+      (append-map (lambda (label)
+                    (match (intmap-ref cps label)
+                      (($ $ktail) '()) ; ignore tails
+                      (($ $kargs)
+                       ;; kargs may bind more arguments
+                       (list (cons (make-kid label) (compile label))))
+                      (else
+                       ;; otherwise, even if it dominates other conts,
+                       ;; it doesn't need to contain them
+                       (cons (cons (make-kid label) (compile label))
+                             (find&compile-dominated label)))))
+                  (intmap-ref doms label)))
+    (make-local (find&compile-dominated label) exp))
+  (define (compile cont)
+    (match (intmap-ref cps cont)
+      ;; The term in a $kargs is always a $continue
+      (($ $kargs names syms ($ $continue k src exp))
+       (make-continuation (map make-id syms)
+                          (redominate cont (compile-exp exp k))))
+      (($ $kreceive ($ $arity req _ (? symbol? rest) _ _) k2)
+       (let ((ids (map make-id (append req (list rest)))))
+         (make-continuation ids (make-continue (make-kid k2) ids))))
+      (($ $kreceive ($ $arity req _ #f _ _) k2)
+       (let ((ids (map make-id req)))
+         (make-continuation ids (make-continue (make-kid k2) ids))))))
+  (compile cont))
+
+(define (compile-exp exp k)
+ (match exp
+    (($ $branch kt exp)
+     (compile-test exp (make-kid kt) (make-kid k)))
+    (($ $primcall 'return (arg))
+     (make-continue (make-kid k) (list (make-id arg))))
+    (($ $call name args)
+     (make-call (make-id name) (make-kid k) (map make-id args)))
+    (($ $callk label proc args)
+     (make-continue (make-kid label)
+                    (cons* (make-id proc)
+                           (make-kid k)
+                           (map make-id args))))
+    (($ $values values)
+     (make-continue (make-kid k) (map make-id values)))
+    (($ $prompt escape? tag handler)
+     (make-seq
+      (list
+       (make-prompt* escape? (make-id tag) (make-kid handler))
+       (make-continue (make-kid k) '()))))
+    (_
+     (make-continue (make-kid k) (list (compile-exp* exp))))))
+
+(define (compile-exp* exp)
+  (match exp
+    (($ $const val)
+     (make-const val))
+    (($ $primcall name args)
+     (make-primcall name (map make-id args)))
+    (($ $closure label nfree)
+     (make-closure (make-kid label) nfree))
+    (($ $values (val))
+     ;; FIXME:
+     ;; may happen if a test branch of a conditional compiles to values
+     ;; placeholder till I learn if multiple values could be returned.
+     (make-id val))))
+
+(define (compile-test exp kt kf)
+  ;; TODO: find out if the expression is always simple enough that I
+  ;; don't need to create a new continuation (which will require extra
+  ;; arguments being passed through)
+  (make-branch (compile-exp* exp)
+               (make-continue kt '())
+               (make-continue kf '())))

module/language/cps/spec.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2015 Free Software Foundation, Inc.
+;; 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
@@ -25,6 +25,7 @@
   #:use-module (language cps intmap)
   #:use-module (language cps optimize)
   #:use-module (language cps compile-bytecode)
+  #:use-module (language cps compile-js)
   #:export (cps))
 
 (define (read-cps port env)
@@ -47,6 +48,7 @@
   #:title	"CPS Intermediate Language"
   #:reader	read-cps
   #:printer	write-cps
-  #:compilers   `((bytecode . ,compile-bytecode))
+  #:compilers   `((bytecode . ,compile-bytecode)
+                  (js-il . ,compile-js))
   #:for-humans? #f
   #:lowerer     make-cps-lowerer)

module/language/javascript.scm

@@ -0,0 +1,274 @@
+;;; JavaScript Language
+
+;; 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:
+
+;; Only has enough of the ecmascript language for compilation from cps
+(define-module (language javascript)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:export (
+            make-assign assign
+            make-const const
+            make-function function
+            make-return return
+            make-call call
+            make-block block
+            make-new new
+            make-id id
+            make-refine refine
+            make-branch branch
+            make-var var
+            make-binop binop
+            make-ternary ternary
+            make-prefix prefix
+
+            print-statement))
+
+;; Copied from (language cps)
+;; Should put in a srfi 99 module
+(define-syntax define-record-type*
+  (lambda (x)
+    (define (id-append ctx . syms)
+      (datum->syntax ctx (apply symbol-append (map syntax->datum syms))))
+    (syntax-case x ()
+      ((_ name field ...)
+       (and (identifier? #'name) (and-map identifier? #'(field ...)))
+       (with-syntax ((cons (id-append #'name #'make- #'name))
+                     (pred (id-append #'name #'name #'?))
+                     ((getter ...) (map (lambda (f)
+                                          (id-append f #'name #'- f))
+                                        #'(field ...))))
+         #'(define-record-type name
+             (cons field ...)
+             pred
+             (field getter)
+             ...))))))
+
+;; TODO: add type predicates to fields so I can only construct valid
+;; objects
+(define-syntax-rule (define-js-type name field ...)
+  (begin
+    (define-record-type* name field ...)
+    (set-record-type-printer! name print-js)))
+
+(define (print-js exp port)
+  (format port "#<js ~S>" (unparse-js exp)))
+
+(define-js-type assign id exp)
+(define-js-type const c)
+(define-js-type function args body)
+(define-js-type return exp)
+(define-js-type call function args)
+(define-js-type block statements)
+(define-js-type new expr)
+(define-js-type id name)
+(define-js-type refine id field)
+(define-js-type branch test then else)
+(define-js-type var id exp)
+(define-js-type binop op arg1 arg2)
+(define-js-type ternary test then else)
+(define-js-type prefix op expr)
+
+(define (unparse-js exp)
+  (match exp
+    (($ assign id exp)
+     `(assign ,id ,(unparse-js exp)))
+    (($ const c)
+     `(const ,c))
+    (($ function args body)
+     `(function ,args ,@(map unparse-js body)))
+    (($ return exp)
+     `(return ,(unparse-js exp)))
+    (($ call function args)
+     `(call ,(unparse-js function) ,@(map unparse-js args)))
+    (($ block statements)
+     `(block ,@(map unparse-js statements)))
+    (($ new expr)
+     `(new ,(unparse-js expr)))
+    (($ id name)
+     `(id ,name))
+    (($ refine id field)
+     `(refine ,(unparse-js id) ,(unparse-js field)))
+    (($ branch test then else)
+     `(if ,(unparse-js test)
+          (block ,@(map unparse-js then))
+          (block ,@(map unparse-js else))))
+    (($ var id exp)
+     `(var ,id ,(unparse-js exp)))
+    (($ binop op arg1 arg2)
+     `(binop ,op ,(unparse-js arg1) ,(unparse-js arg2)))
+    (($ ternary test then else)
+     `(ternary ,(unparse-js test) ,(unparse-js then) ,(unparse-js else)))
+    (($ prefix op expr)
+     `(prefix ,op ,(unparse-js expr)))
+    ))
+
+(define (print-exp exp port)
+  (match exp
+
+    (($ assign id exp)
+     (print-id id port)
+     (format port " = ")
+     (display "(" port)
+     (print-exp exp port)
+     (display ")" port))
+
+    (($ const c)
+     (print-const c port))
+
+    (($ id name)
+     (print-id name port))
+
+    (($ call (and ($ function _ _) fun) args)
+     (format port "(")
+     (print-exp fun port)
+     (format port ")(")
+     (print-separated args print-exp "," port)
+     (format port ")"))
+
+    (($ call fun args)
+     (print-exp fun port)
+     (format port "(")
+     (print-separated args print-exp "," port)
+     (format port ")"))
+
+
+    (($ refine expr field)
+     (print-exp expr port)
+     (format port "[")
+     (print-exp field port)
+     (format port "]"))
+
+    (($ function params body)
+     (format port "function (")
+     (print-separated params print-id "," port)
+     (format port ")")
+     (print-block body port))
+
+    (($ block stmts)
+     (print-block stmts port))
+
+    (($ new expr)
+     (format port "new ")
+     (print-exp expr port))
+
+    (($ binop op arg1 arg2)
+     (display "(" port)
+     (print-exp arg1 port)
+     (display ")" port)
+     (print-binop op port)
+     (display "(" port)
+     (print-exp arg2 port)
+     (display ")" port))
+
+    (($ ternary test then else)
+     (display "(" port)
+     (print-exp test port)
+     (display ") ? (" port)
+     (print-exp then port)
+     (display ") : (" port)
+     (print-exp else port)
+     (display ")" port))
+
+    (($ prefix op exp)
+     (print-prefix op port)
+     (display "(" port)
+     (print-exp exp port)
+     (display ")" port))
+    ))
+
+(define (print-binop op port)
+  (case op
+    ((or) (display "||" port))
+    ((and) (display "&&" port))
+    ((=) (display "==" port))
+    ((begin) (display "," port))
+    ((+ - < <= > >= === instanceof) (format port "~a" op))
+    (else
+     (throw 'unprintable-binop op))))
+
+(define (print-prefix op port)
+  (case op
+    ((not) (display "!" port))
+    ((typeof + -)
+     (format port "~a" op))
+    (else
+     (throw 'unprintable-prefix op))))
+
+(define (print-statement stmt port)
+  (match stmt
+    (($ var id exp)
+     (format port "var ")
+     (print-id id port)
+     (format port " = ")
+     (print-exp exp port)
+     (format port ";"))
+
+    (($ branch test then else)
+     (format port "if (")
+     (print-exp test port)
+     (format port ") {")
+     (print-block then port)
+     (format port "} else {")
+     (print-block else port)
+     (format port "}"))
+
+    (($ return expr)
+     (format port "return ")
+     (print-exp expr port)
+     (format port ";"))
+
+    (expr
+     (print-exp expr port)
+     (format port ";"))))
+
+(define (print-id id port)
+  (display id port))
+
+(define (print-block stmts port)
+  (format port "{")
+  (print-statements stmts port)
+  (format port "}"))
+
+(define (print-statements stmts port)
+  (for-each (lambda (stmt)
+              (print-statement stmt port))
+            stmts))
+
+(define (print-const c port)
+  (cond ((string? c)
+         ;; FIXME:
+         ;; Scheme strings and JS Strings are different, and not just in
+         ;; terms of mutability
+         (write c port))
+        ((number? c)
+         (write c port))
+        (else
+         (throw 'unprintable-const c))))
+
+(define (print-separated args printer separator port)
+  (unless (null? args)
+    (let ((first (car args))
+          (rest  (cdr args)))
+      (printer first port)
+      (for-each (lambda (x)
+                  (display separator port)
+                  (printer x port))
+                rest))))

module/language/javascript/simplify.scm

@@ -0,0 +1,58 @@
+(define-module (language javascript simplify)
+  #:use-module (language javascript)
+  #:use-module (ice-9 match)
+  #:use-module ((srfi srfi-1) #:select (fold-right))
+  #:export (flatten-blocks))
+
+(define (flatten-blocks exp)
+  (define (flatten exp rest)
+    (match exp
+      (($ block statements)
+       (fold-right flatten rest statements))
+      (else
+       (cons (flatten-exp exp) rest))))
+  (define (flatten-block stmts)
+    (fold-right flatten '() stmts))
+  (define (flatten-exp exp)
+    (match exp
+      (($ assign id exp)
+       (make-assign id (flatten-exp exp)))
+      (($ const c) exp)
+      (($ new exp)
+       (make-new (flatten-exp exp)))
+      (($ return exp)
+       (make-return (flatten-exp exp)))
+      (($ id name) exp)
+      (($ var id exp)
+       (make-var id (flatten-exp exp)))
+      (($ refine id field)
+       (make-refine (flatten-exp id)
+                    (flatten-exp field)))
+      (($ binop op arg1 arg2)
+       (make-binop op
+                   (flatten-exp arg1)
+                   (flatten-exp arg2)))
+      (($ function args body)
+       (make-function args (flatten-block body)))
+      (($ block statements)
+       (maybe-make-block (flatten-block statements)))
+      (($ branch test then else)
+       (make-branch (flatten-exp test)
+                    (flatten-block then)
+                    (flatten-block else)))
+      (($ call function args)
+       (make-call (flatten-exp function)
+                  (map flatten-exp args)))
+
+      (($ ternary test then else)
+       (make-ternary (flatten-exp test)
+                     (flatten-exp then)
+                     (flatten-exp else)))
+      (($ prefix op exp)
+       (make-prefix op (flatten-exp exp)))
+      ))
+  (define (maybe-make-block exp)
+    (match exp
+      ((exp) exp)
+      (exps (make-block exps))))
+  (maybe-make-block (flatten exp '())))

module/language/javascript/spec.scm

@@ -0,0 +1,33 @@
+;;; JavaScript Language
+
+;; Copyright (C) 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:
+
+;; in future, this should be merged with ecmacript
+
+(define-module (language javascript spec)
+  #:use-module (system base language)
+  #:use-module (language javascript)
+  #:export (javascript))
+
+(define-language javascript
+  #:title	"Javascript"
+  #:reader      #f
+  #:printer	print-statement
+  #:for-humans? #f
+  )

module/language/js-il.scm

@@ -0,0 +1,138 @@
+;;; JavaScript Intermediate Language (JS-IL)
+
+;; 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)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (ice-9 match)
+  #:export (make-program program
+            make-function function
+            make-params params
+            make-continuation continuation
+            make-local local
+            make-continue continue
+            make-const const
+            make-primcall primcall
+            make-call call
+            make-closure closure
+            make-branch branch
+            make-id id
+            make-kid kid
+            make-seq seq
+            make-prompt prompt
+            ))
+
+;; Copied from (language cps)
+;; Should put in a srfi 99 module
+(define-syntax define-record-type*
+  (lambda (x)
+    (define (id-append ctx . syms)
+      (datum->syntax ctx (apply symbol-append (map syntax->datum syms))))
+    (syntax-case x ()
+      ((_ name field ...)
+       (and (identifier? #'name) (and-map identifier? #'(field ...)))
+       (with-syntax ((cons (id-append #'name #'make- #'name))
+                     (pred (id-append #'name #'name #'?))
+                     ((getter ...) (map (lambda (f)
+                                          (id-append f #'name #'- f))
+                                        #'(field ...))))
+         #'(define-record-type name
+             (cons field ...)
+             pred
+             (field getter)
+             ...))))))
+
+;; TODO: add type predicates to fields so I can only construct valid
+;; objects
+(define-syntax-rule (define-js-type name field ...)
+  (begin
+    (define-record-type* name field ...)
+    (set-record-type-printer! name print-js)))
+
+(define (print-js exp port)
+  (format port "#<js-il ~S>" (unparse-js exp)))
+
+(define-js-type program body)
+(define-js-type function self tail clauses)
+(define-js-type params self req opt rest kw allow-other-keys?)
+(define-js-type continuation params body)
+(define-js-type local bindings body) ; local scope
+(define-js-type continue cont args)
+(define-js-type const value)
+(define-js-type primcall name args)
+(define-js-type call name k args)
+(define-js-type closure label num-free)
+(define-js-type branch test consequence alternate)
+(define-js-type id name)
+(define-js-type kid name)
+(define-js-type seq body)
+(define-js-type prompt escape? tag handler)
+
+(define (unparse-js exp)
+  (match exp
+    (($ program body)
+     `(program . ,(map (match-lambda
+                        ((($ kid k) . fun)
+                         (cons k (unparse-js fun))))
+                       body)))
+    (($ continuation params body)
+     `(continuation ,(map unparse-js params) ,(unparse-js body)))
+    (($ function ($ id self) ($ kid tail) clauses)
+     `(function ,self
+                ,tail
+                ,@(map (match-lambda
+                        ((($ kid id) params kont)
+                         (list id
+                               (unparse-js params)
+                               (unparse-js kont))))
+                       clauses)))
+    (($ params ($ id self) req opt rest kws allow-other-keys?)
+     `(params ,self
+              ,(map unparse-js req)
+              ,(map unparse-js opt)
+              ,(and rest (unparse-js rest))
+              ,(map (match-lambda
+                     ((kw ($ id name) ($ id sym))
+                      (list kw name sym)))
+                    kws)
+              ,allow-other-keys?))
+    (($ local bindings body)
+     `(local ,(map (match-lambda
+                    ((a . d)
+                     (cons (unparse-js a)
+                           (unparse-js d))))
+                   bindings)
+             ,(unparse-js body)))
+    (($ continue ($ kid k) args)
+     `(continue ,k ,(map unparse-js args)))
+    (($ branch test then else)
+     `(if ,(unparse-js test) ,(unparse-js then) ,(unparse-js else)))
+    (($ const c)
+     `(const ,c))
+    (($ primcall name args)
+     `(primcall ,name ,(map unparse-js args)))
+    (($ call ($ id name) ($ kid k) args)
+     `(call ,name ,k ,(map unparse-js args)))
+    (($ closure ($ kid label) nfree)
+     `(closure ,label ,nfree))
+    (($ id name)
+     `(id . ,name))
+    (($ kid name)
+     `(kid . ,name))))

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))))

module/language/js-il/inlining.scm

@@ -0,0 +1,230 @@
+;;; JavaScript Intermediate Language (JS-IL) Inliner
+
+;; 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:
+
+;; FIXME: It is currently wrong to think of inlining as an optimisation
+;; since in the cps-soup world we need inlining to rebuild the scope
+;; tree for variables.
+;; FIXME: since *all* conts are passed to each clause, there can be
+;; "dead" conts thare are included in a clause
+
+(define-module (language js-il inlining)
+  #:use-module ((srfi srfi-1) #:select (partition))
+  #:use-module (ice-9 match)
+  #:use-module (language js-il)
+  #:export (count-calls
+            inline-single-calls
+            ))
+
+(define (count-calls exp)
+  (define counts (make-hash-table))
+  (define (count-inc! key)
+    (hashv-set! counts key (+ 1 (hashv-ref counts key 0))))
+  (define (count-inf! key)
+    (hashv-set! counts key +inf.0))
+  (define (analyse-args arg-list)
+    (for-each (match-lambda
+               (($ kid name)
+                (count-inf! name))
+               (($ id name) #f))
+              arg-list))
+  (define (analyse exp)
+    (match exp
+      (($ program ((ids . funs) ...))
+       (for-each analyse funs))
+
+      (($ function self tail ((($ kid ids) _ bodies) ...))
+       (for-each count-inc! ids) ;; count-inf! ?
+       (for-each analyse bodies))
+
+      (($ continuation params body)
+       (analyse body))
+
+      (($ local bindings body)
+       (for-each (match-lambda
+                  ((i . b) (analyse b)))
+                 bindings)
+       (analyse body))
+
+      (($ continue ($ kid cont) args)
+       (count-inc! cont)
+       (for-each analyse args))
+
+      (($ primcall name args)
+       (analyse-args args))
+
+      (($ call name ($ kid k) args)
+       (count-inf! k)
+       (analyse-args args))
+
+      (($ closure ($ kid label) num-free)
+       (count-inf! label))
+
+      (($ branch test consequence alternate)
+       (analyse test)
+       (analyse consequence)
+       (analyse alternate))
+
+      (($ kid name)
+       (count-inf! name))
+
+      (($ seq body)
+       (for-each analyse body))
+
+      (($ prompt escape? tag ($ kid handler))
+       (count-inf! handler))
+
+      (else #f)))
+  (analyse exp)
+  counts)
+
+(define no-values-primitives
+  '(
+    cache-current-module!
+    set-cdr!
+    set-car!
+    vector-set!
+    free-set!
+    vector-set!/immediate
+    box-set!
+    struct-set!
+    struct-set!/immediate
+    wind
+    unwind
+    push-fluid
+    pop-fluid
+    handle-interrupts
+    push-dynamic-state
+    pop-dynamic-state
+    fluid-set!
+    ))
+
+(define no-values-primitive?
+  (let ((h (make-hash-table)))
+    (for-each (lambda (prim)
+                (hashv-set! h prim #t))
+              no-values-primitives)
+    (lambda (prim)
+      (hashv-ref h prim))))
+
+
+(define (inline-single-calls exp)
+  (define (handle-function fun)
+    (match fun
+      (($ function self tail ((ids params bodies) ...))
+       (make-function self
+                      tail
+                      (map (lambda (id param body)
+                             (list id param (inline-clause body)))
+                           ids
+                           params
+                           bodies)))))
+  (match exp
+    (($ program ((ids . funs) ...))
+     (make-program (map (lambda (id fun)
+                          (cons id (handle-function fun)))
+                        ids
+                        funs)))))
+
+(define (inline-clause exp)
+
+  (define calls (count-calls exp))
+
+  (define (inlinable? k)
+    (eqv? 1 (hashv-ref calls k)))
+
+  (define (split-inlinable bindings)
+    (partition (match-lambda
+                ((($ kid id) . _) (inlinable? id)))
+               bindings))
+
+  (define (lookup kont substs)
+    (match substs
+      (((($ kid id) . exp) . rest)
+       (if (= id kont)
+           exp
+           (lookup kont rest)))
+      (() kont)
+      (else
+       (throw 'lookup-failed kont))))
+
+  (define (inline exp substs)
+    (match exp
+
+      ;; FIXME: This hacks around the fact that define doesn't return
+      ;; arguments to the continuation. This should be handled when
+      ;; converting to js-il, not here.
+      (($ continue
+          ($ kid (? inlinable? cont))
+          (($ primcall (? no-values-primitive? prim) args)))
+       (match (lookup cont substs)
+         (($ continuation () body)
+          (make-seq
+           (list
+            (make-primcall prim args)
+            (inline body substs))))
+         (else
+          ;; inlinable but not locally bound
+          exp)))
+
+      (($ continue ($ kid (? inlinable? cont)) args)
+       (match (lookup cont substs)
+         (($ continuation kargs body)
+          (if (not (= (length args) (length kargs)))
+              (throw 'args-dont-match cont args kargs)
+              (make-local (map cons kargs args)
+                          ;; gah, this doesn't work
+                          ;; identifiers need to be separated earlier
+                          ;; not just as part of compilation
+                          (inline body substs))))
+         (else
+          ;; inlinable but not locally bound
+          ;; FIXME: This handles tail continuations, but only by accident
+          exp)))
+
+      (($ continue cont args)
+       exp)
+
+      (($ continuation params body)
+       (make-continuation params (inline body substs)))
+
+      (($ local bindings body)
+       (call-with-values
+           (lambda ()
+             (split-inlinable bindings))
+         (lambda (new-substs uninlinable-bindings)
+           (define substs* (append new-substs substs))
+           (make-local (map (match-lambda
+                             ((id . val)
+                              `(,id . ,(inline val substs*))))
+                            uninlinable-bindings)
+                       (inline body substs*)))))
+
+      (($ seq body)
+       (make-seq (map (lambda (x) (inline x substs))
+                      body)))
+
+      (($ branch test consequence alternate)
+       (make-branch test
+                    (inline consequence substs)
+                    (inline alternate substs)))
+
+      (exp exp)))
+
+  (inline exp '()))

module/language/js-il/spec.scm

@@ -0,0 +1,31 @@
+;;; JavaScript Intermediate Language (JS-IL)
+
+;; Copyright (C) 2015 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 spec)
+  #:use-module (system base language)
+  #:use-module (language js-il compile-javascript)
+  #:export (js-il))
+
+(define-language js-il
+  #:title	"Javascript Intermediate Language"
+  #:reader      #f
+  #:compilers   `((javascript . ,compile-javascript))
+  #:printer	#f
+  #:for-humans? #f)

module/scripts/jslink.scm

@@ -0,0 +1,215 @@
+;;; jslink --- Link Together JS Modules
+
+;; Copyright 2017 Free Software Foundation, Inc.
+;;
+;; This program 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, or
+;; (at your option) any later version.
+;;
+;; This program 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 software; see the file COPYING.LESSER.  If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Ian Price <ianprice90@gmail.com>
+
+;;; Commentary:
+
+;; Usage: jslink [ARGS]
+;;
+;; A command-line tool for linking together compiled JS modules.
+
+;;; Code:
+
+(define-module (scripts jslink)
+  #:use-module (system base compile)
+  #:use-module (system base language)
+  #:use-module (language javascript)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-37)
+  #:use-module (ice-9 format)
+  #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 binary-ports)
+  #:export (jslink))
+
+(define %summary "Link a JS module.")
+
+(define* (copy-port from #:optional (to (current-output-port)) #:key (buffer-size 1024))
+  (define bv (make-bytevector buffer-size))
+  (let loop ()
+    (let ((num-read (get-bytevector-n! from bv 0 buffer-size)))
+      (unless (eof-object? num-read)
+        (put-bytevector to bv 0 num-read)
+        (loop)))))
+
+(define boot-dependencies
+  '(("ice-9/posix" . #f)
+    ("ice-9/ports" . (ice-9 ports))
+    ("ice-9/threads" . (ice-9 threads))
+    ("srfi/srfi-4" . (srfi srfi-4))
+
+    ("ice-9/deprecated" . #t)
+    ("ice-9/boot-9" . #t)
+    ;; FIXME: needs to be at end, or I get strange errors
+    ("ice-9/psyntax-pp" . #t)
+    ))
+
+(define (fail . messages)
+  (format (current-error-port) "error: ~{~a~}~%" messages)
+  (exit 1))
+
+(define %options
+  (list (option '(#\h "help") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'help? #t result)))
+
+        (option '("version") #f #f
+                (lambda (opt name arg result)
+                  (show-version)
+                  (exit 0)))
+
+        (option '(#\o "output") #t #f
+                (lambda (opt name arg result)
+                  (if (assoc-ref result 'output-file)
+                      (fail "`-o' option cannot be specified more than once")
+                      (alist-cons 'output-file arg result))))
+
+        (option '(#\d "depends") #t #f
+                (lambda (opt name arg result)
+                  (define (read-from-string s)
+                    (call-with-input-string s read))
+                  (let ((depends (assoc-ref result 'depends)))
+                    (alist-cons 'depends (cons (read-from-string arg) depends)
+                                result))))
+
+        (option '("no-boot") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'no-boot? #t result)))
+        ))
+
+(define (parse-args args)
+  "Parse argument list @var{args} and return an alist with all the relevant
+options."
+  (args-fold args %options
+             (lambda (opt name arg result)
+               (format (current-error-port) "~A: unrecognized option" name)
+               (exit 1))
+             (lambda (file result)
+               (let ((input-files (assoc-ref result 'input-files)))
+                 (alist-cons 'input-files (cons file input-files)
+                             result)))
+
+             ;; default option values
+             '((input-files)
+               (depends)
+               (no-boot? . #f)
+               )))
+
+(define (show-version)
+  (format #t "compile (GNU Guile) ~A~%" (version))
+  (format #t "Copyright (C) 2017 Free Software Foundation, Inc.
+License LGPLv3+: GNU LGPL version 3 or later <http://gnu.org/licenses/lgpl.html>.
+This is free software: you are free to change and redistribute it.
+There is NO WARRANTY, to the extent permitted by law.~%"))
+
+(define (show-help)
+  (format #t "Usage: jslink [OPTION] FILE
+Link Javascript FILE with all its dependencies
+
+  -h, --help           print this help message
+  -v, --version        show version information
+  -o, --output=OFILE   write output to OFILE
+  -d, --depends=DEP    add dependency on DEP
+      --no-boot        link without boot-9 & its dependencies
+
+Report bugs to <~A>.~%"
+          %guile-bug-report-address))
+
+(define* (link-file file #:key (extra-dependencies '()) output-file no-boot?)
+  (let ((dependencies (if no-boot?
+                          extra-dependencies
+                          ;; FIXME: extra-dependencies need to come before psyntax
+                          (append extra-dependencies boot-dependencies)))
+        (output-file (or output-file "main.js")) ;; FIXME: changeable
+        )
+    (with-output-to-file output-file
+      (lambda ()
+        (format #t "(function () {\n")
+        (link-runtime)
+        (format #t "/* ---------- end of runtime ---------- */\n")
+        (for-each (lambda (x)
+                    (let ((path (car x))
+                          (file (cdr x)))
+                      (link-dependency path file))
+                    (format #t "/* ---------- */\n"))
+                  dependencies)
+        (format #t "/* ---------- end of dependencies ---------- */\n")
+        (link-main file no-boot?)
+        (format #t "})();")
+        output-file))))
+
+(define *runtime-file* (%search-load-path "language/js-il/runtime.js"))
+
+(define (link-runtime)
+  (call-with-input-file *runtime-file* copy-port))
+
+(define (link-dependency path file)
+  (define (compile-dependency file)
+    (call-with-input-file file
+      (lambda (in)
+        ((language-printer (lookup-language 'javascript))
+         (read-and-compile in
+                           #:from 'scheme
+                           #:to 'javascript
+                           #:env (default-environment (lookup-language 'scheme)))
+         (current-output-port)))))
+  (format #t "boot_modules[~s] =\n" path)
+  (cond ((string? file)
+         (compile-dependency file))
+        ((list? file)
+         (print-statement (compile `(define-module ,file)
+                                   #:from 'scheme #:to 'javascript)
+                          (current-output-port))
+         (newline))
+        (file (compile-dependency (%search-load-path path)))
+        (else
+         (format #t "function (cont) { return cont(scheme.UNDEFINED); };")))
+  (newline))
+
+(define (link-main file no-boot?)
+  ;; FIXME: continuation should be changeable with a switch
+  (call-with-input-file file
+    (lambda (in)
+      (format #t "var main =\n")
+      (copy-port in)
+      (newline)
+      (if no-boot?
+          (format #t "main(scheme.initial_cont);\n")
+          (format #t "boot_modules[\"ice-9/boot-9\"](function() {return main((function (x) {console.log(x); return x; }));});"))))) ; scheme.initial_cont
+
+(define (jslink . args)
+  (let* ((options      (parse-args args))
+         (help?        (assoc-ref options 'help?))
+         (dependencies (assoc-ref options 'depends))
+         (input-files  (assoc-ref options 'input-files))
+         (output-file  (assoc-ref options 'output-file))
+         (no-boot?     (assoc-ref options 'no-boot?)))
+
+    (if (or help? (null? input-files))
+        (begin (show-help) (exit 0)))
+
+    (unless (null? (cdr input-files))
+      (fail "can only link one file at a time"))
+    (format #t "wrote `~A'\n"
+            (link-file (car input-files)
+                       #:extra-dependencies dependencies
+                       #:output-file output-file
+                       #:no-boot? no-boot?))))
+
+(define main jslink)