[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 05/05: Add baseline compiler
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 05/05: Add baseline compiler |
|
Date: |
Mon, 4 May 2020 09:25:23 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 121ab14439a77872a0d1deeb9c0be44c47fbcf25
Author: Andy Wingo <address@hidden>
AuthorDate: Mon May 4 15:09:18 2020 +0200
Add baseline compiler
* module/language/tree-il/compile-bytecode.scm: New file.
* module/Makefile.am (SOURCES):
* am/bootstrap.am (SOURCES): Add new file.
---
am/bootstrap.am | 1 +
module/Makefile.am | 1 +
module/language/tree-il/compile-bytecode.scm | 1357 ++++++++++++++++++++++++++
3 files changed, 1359 insertions(+)
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 1ab39f1..43f0f04 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -61,6 +61,7 @@ SOURCES = \
\
language/tree-il.scm \
language/tree-il/analyze.scm \
+ language/tree-il/compile-bytecode.scm \
language/tree-il/compile-cps.scm \
language/tree-il/cps-primitives.scm \
language/tree-il/debug.scm \
diff --git a/module/Makefile.am b/module/Makefile.am
index 9beae24..7d3f328 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -185,6 +185,7 @@ SOURCES = \
\
language/tree-il.scm \
language/tree-il/analyze.scm \
+ language/tree-il/compile-bytecode.scm \
language/tree-il/compile-cps.scm \
language/tree-il/cps-primitives.scm \
language/tree-il/debug.scm \
diff --git a/module/language/tree-il/compile-bytecode.scm
b/module/language/tree-il/compile-bytecode.scm
new file mode 100644
index 0000000..616aa11
--- /dev/null
+++ b/module/language/tree-il/compile-bytecode.scm
@@ -0,0 +1,1357 @@
+;;; Lightweight compiler directly from Tree-IL to bytecode
+
+;; Copyright (C) 2020 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
+
+;;; Commentary:
+;;;
+;;; This pass converts Tree-IL directly to bytecode. Whereas first
+;;; compiling to CPS will yield better-quality bytecode if the optimizer
+;;; is on, this approach is much faster and less memory-hungry. It's
+;;; useful if it's more important to reduce time spent in the compiler
+;;; than to have a fast program.
+;;;
+;;; Code:
+
+;; FIXME: Add handle-interrupts, instrument-entry, and instrument-loop.
+
+;; FIXME: Verify that all SCM values on the stack will be marked.
+
+;; FIXME: Verify that the stack marker will never misinterpret an
+;; unboxed temporary (u64 or otherwise) as a SCM.
+
+;; FIXME: Verify that the debugger will never misinterpret an unboxed
+;; temporary as a SCM.
+
+;; FIXME: Add debugging source-location info.
+
+;; FIXME: Add debugging variable name info.
+
+(define-module (language tree-il compile-bytecode)
+ #:use-module (ice-9 match)
+ #:use-module (language bytecode)
+ #:use-module (language tree-il)
+ #:use-module (language tree-il analyze)
+ #:use-module (language tree-il optimize)
+ #:use-module ((srfi srfi-1) #:select (filter-map
+ fold
+ lset-union lset-difference))
+ #:use-module (srfi srfi-9)
+ #:use-module (system base types internal)
+ #:use-module (system vm assembler)
+ #:export (compile-bytecode))
+
+(define (u6? x) (and (exact-integer? x) (<= 0 x #x3f)))
+(define (u8? x) (and (exact-integer? x) (<= 0 x #xff)))
+(define (u12? x) (and (exact-integer? x) (<= 0 x #xfff)))
+
+(define (emit-box asm dst src)
+ (cond
+ ((= src dst)
+ (emit-mov asm 1 src)
+ (emit-box asm dst 1))
+ (else
+ (let ((tmp 0))
+ (emit-allocate-words/immediate asm dst 2)
+ (emit-load-u64 asm tmp %tc7-variable)
+ (emit-word-set!/immediate asm dst 0 tmp)
+ (emit-word-set!/immediate asm dst 1 src)))))
+(define (emit-box-set! asm loc val)
+ (emit-word-set!/immediate asm loc 1 val))
+(define (emit-cons asm dst car cdr)
+ (cond
+ ((= car dst)
+ (emit-mov asm 1 car)
+ (emit-cons asm dst 1 (if (= cdr dst) 1 dst)))
+ ((= cdr dst)
+ (emit-mov asm 1 cdr)
+ (emit-cons asm dst car 1))
+ (else
+ (emit-allocate-words/immediate asm dst 2)
+ (emit-scm-set!/immediate asm dst 0 car)
+ (emit-scm-set!/immediate asm dst 1 cdr))))
+
+(define (emit-cached-module-box asm dst mod name public? tmp)
+ (define key (cons mod name))
+ (define cached (gensym "cached"))
+ (emit-cache-ref asm dst key)
+ (emit-heap-object? asm dst)
+ (emit-je asm cached)
+ (emit-load-constant asm dst mod)
+ (emit-resolve-module asm dst dst public?)
+ (emit-load-constant asm tmp name)
+ (emit-lookup asm dst dst tmp)
+ (emit-cache-set! asm key dst)
+ (emit-label asm cached))
+(define (emit-cached-toplevel-box asm dst scope name tmp)
+ (define key (cons scope name))
+ (define cached (gensym "cached"))
+ (emit-cache-ref asm dst key)
+ (emit-heap-object? asm dst)
+ (emit-je asm cached)
+ (emit-cache-ref asm dst scope)
+ (emit-load-constant asm tmp name)
+ (emit-lookup asm dst dst tmp)
+ (emit-cache-set! asm key dst)
+ (emit-label asm cached))
+(define (emit-toplevel-box asm dst name tmp)
+ (emit-current-module asm dst)
+ (emit-load-constant asm tmp name)
+ (emit-lookup asm dst dst tmp))
+
+(define closure-header-words 2)
+(define (emit-allocate-closure asm dst nfree label tmp)
+ (let ((nwords (+ nfree closure-header-words)))
+ (cond
+ ((u12? nwords)
+ (emit-allocate-words/immediate asm dst nwords))
+ (else
+ (emit-load-u64 asm tmp nwords)
+ (emit-allocate-words asm dst tmp)))
+ (emit-load-u64 asm tmp (+ %tc7-program (ash nfree 16)))
+ (emit-word-set!/immediate asm dst 0 tmp)
+ (emit-load-label asm tmp label)
+ (emit-word-set!/immediate asm dst 1 tmp)))
+(define (emit-maybe-allocate-closure asm dst nfree label tmp)
+ (if (zero? nfree)
+ (emit-load-static-procedure asm dst label)
+ (emit-allocate-closure asm dst nfree label tmp)))
+(define (emit-load-free-variable asm dst src idx tmp)
+ (let ((idx (+ idx closure-header-words)))
+ (cond
+ ((u8? idx)
+ (emit-scm-ref/immediate asm dst src idx))
+ (else
+ (emit-load-u64 asm tmp idx)
+ (emit-scm-ref asm dst src tmp)))))
+(define (emit-init-free-variable asm closure idx val tmp)
+ (let ((idx (+ idx closure-header-words)))
+ (cond
+ ((u8? idx)
+ (emit-scm-set!/immediate asm closure idx val))
+ (else
+ (emit-load-u64 asm tmp idx)
+ (emit-scm-set! asm closure tmp val)))))
+
+(define vector-header-words 1)
+(define (emit-allocate-vector asm dst len tmp)
+ (let ((nwords (+ len vector-header-words)))
+ (cond
+ ((u12? nwords)
+ (emit-allocate-words/immediate asm dst nwords))
+ (else
+ (emit-load-u64 asm tmp nwords)
+ (emit-allocate-words asm dst tmp)))
+ (emit-load-u64 asm tmp (+ %tc7-vector (ash len 8)))
+ (emit-word-set!/immediate asm dst 0 tmp)))
+(define (emit-vector-init! asm v idx val tmp)
+ (let ((idx (+ idx vector-header-words)))
+ (cond
+ ((u8? idx)
+ (emit-scm-set!/immediate asm v idx val))
+ (else
+ (emit-load-u64 asm tmp idx)
+ (emit-scm-set! asm v tmp val)))))
+
+(define struct-header-words 1)
+(define (emit-struct-init! asm s idx val tmp)
+ (let ((idx (+ idx struct-header-words)))
+ (cond
+ ((u8? idx)
+ (emit-scm-set!/immediate asm s idx val))
+ (else
+ (emit-load-u64 asm tmp idx)
+ (emit-scm-set! asm s tmp val)))))
+
+(define-syntax-rule (define-record-type/keywords rtd
+ make-rtd pred (field getter init) ...)
+ (begin
+ (define-record-type rtd (%make-rtd field ...) pred (field getter) ...)
+ (define* (make-rtd #:key (field init) ...)
+ (%make-rtd field ...))))
+
+(define-record-type/keywords <primitive>
+ make-primitive
+ primitive?
+ (name primitive-name (error "name required"))
+ (nargs primitive-nargs (error "nargs required"))
+ (has-result? primitive-has-result? #f)
+ (predicate? primitive-predicate? #f)
+ (emit primitive-emitter (error "emitter required"))
+ (immediate-in-range? primitive-immediate-in-range-predicate #f)
+ (emit/immediate primitive-emitter/immediate #f))
+
+(define *primitives* (make-hash-table))
+(define (lookup-primitive name) (hashq-ref *primitives* name))
+
+(define-syntax-rule (define-primitive primitive kw ...)
+ (hashq-set! *primitives* 'primitive
+ (make-primitive #:name 'primitive kw ...)))
+
+(define-syntax-rule (define-primitives (primitive kw ...) ...)
+ (begin (define-primitive primitive kw ...) ...))
+
+(define-primitives
+ (+ #:nargs 2 #:has-result? #t #:emit emit-add
+ #:immediate-in-range? u8?
+ #:emit/immediate emit-add/immediate)
+ (- #:nargs 2 #:has-result? #t #:emit emit-sub
+ #:immediate-in-range? u8?
+ #:emit/immediate emit-sub/immediate)
+
+ (* #:nargs 2 #:has-result? #t #:emit emit-mul)
+ (/ #:nargs 2 #:has-result? #t #:emit emit-div)
+ (quotient #:nargs 2 #:has-result? #t #:emit emit-quo)
+ (remainder #:nargs 2 #:has-result? #t #:emit emit-rem)
+ (modulo #:nargs 2 #:has-result? #t #:emit emit-mod)
+ (exact->inexact #:nargs 1 #:has-result? #t #:emit emit-inexact)
+
+ (sqrt #:nargs 1 #:has-result? #t #:emit emit-sqrt)
+ (abs #:nargs 1 #:has-result? #t #:emit emit-abs)
+ (floor #:nargs 1 #:has-result? #t #:emit emit-floor)
+ (ceiling #:nargs 1 #:has-result? #t #:emit emit-ceiling)
+ (sin #:nargs 1 #:has-result? #t #:emit emit-sin)
+ (cos #:nargs 1 #:has-result? #t #:emit emit-cos)
+ (tan #:nargs 1 #:has-result? #t #:emit emit-tan)
+ (asin #:nargs 1 #:has-result? #t #:emit emit-asin)
+ (acos #:nargs 1 #:has-result? #t #:emit emit-acos)
+ (atan #:nargs 1 #:has-result? #t #:emit emit-atan)
+ (atan2 #:nargs 2 #:has-result? #t #:emit emit-atan2)
+
+ (logand #:nargs 2 #:has-result? #t #:emit emit-logand)
+ (logior #:nargs 2 #:has-result? #t #:emit emit-logior)
+ (logxor #:nargs 2 #:has-result? #t #:emit emit-logxor)
+ (logsub #:nargs 2 #:has-result? #t #:emit emit-logsub)
+
+ (lsh #:nargs 2 #:has-result? #t #:emit emit-lsh
+ #:immediate-in-range? u6?
+ #:emit/immediate emit-lsh/immediate)
+ (rsh #:nargs 2 #:has-result? #t #:emit emit-rsh
+ #:immediate-in-range? u6?
+ #:emit/immediate emit-rsh/immediate)
+
+ (throw #:nargs 2 #:emit emit-throw)
+ (throw/value #:nargs 2 #:emit #f
+ #:immediate-in-range? (lambda (_) #t)
+ #:emit/immediate emit-throw/value)
+ (throw/value+data #:nargs 2 #:emit #f
+ #:immediate-in-range? (lambda (_) #t)
+ #:emit/immediate emit-throw/value+data)
+
+ (current-thread #:nargs 2 #:has-result? #t #:emit emit-current-thread)
+ (current-module #:nargs 0 #:has-result? #t #:emit emit-current-module)
+ (module-ensure-local-variable! #:nargs 2 #:has-result? #t #:emit
emit-define!)
+ (builtin-ref #:nargs 1 #:has-result? #t #:emit #f
+ #:immediate-in-range? (lambda (_) #t)
+ #:emit/immediate emit-builtin-ref)
+
+ (wind #:nargs 2 #:emit emit-wind)
+ (unwind #:nargs 0 #:emit emit-unwind)
+ (push-dynamic-state #:nargs 1 #:emit emit-push-dynamic-state)
+ (pop-dynamic-state #:nargs 0 #:emit emit-pop-dynamic-state)
+ (push-fluid #:nargs 2 #:emit emit-push-fluid)
+ (pop-fluid-state #:nargs 0 #:emit emit-pop-dynamic-state)
+ (fluid-ref #:nargs 1 #:has-result? #t #:emit emit-fluid-ref)
+ (fluid-set! #:nargs 2 #:emit emit-fluid-set!)
+
+ (string->number #:nargs 1 #:has-result? #t #:emit emit-string->number)
+ (string->symbol #:nargs 1 #:has-result? #t #:emit emit-string->symbol)
+ (symbol->keyword #:nargs 1 #:has-result? #t #:emit emit-symbol->keyword)
+
+ (class-of #:nargs 1 #:has-result? #t #:emit emit-class-of)
+
+ (cons #:nargs 2 #:has-result? #t #:emit emit-cons)
+ (car #:nargs 1 #:has-result? #t #:emit emit-$car)
+ (cdr #:nargs 1 #:has-result? #t #:emit emit-$cdr)
+ (set-car! #:nargs 2 #:emit emit-$set-car!)
+ (set-cdr! #:nargs 2 #:emit emit-$set-cdr!)
+
+ (box #:nargs 1 #:has-result? #t #:emit emit-box)
+ (variable-ref #:nargs 1 #:has-result? #t #:emit emit-$variable-ref)
+ (variable-set! #:nargs 2 #:emit emit-$variable-set!)
+ (%variable-ref #:nargs 1 #:has-result? #t #:emit emit-$variable-ref)
+ (%variable-set! #:nargs 2 #:emit emit-box-set!)
+
+ (vector-length #:nargs 1 #:has-result? #t #:emit emit-$vector-length)
+ (vector-ref #:nargs 2 #:has-result? #t #:emit emit-$vector-ref
+ #:immediate-in-range? u8?
+ #:emit/immediate emit-$vector-ref/immediate)
+ (vector-set! #:nargs 3 #:emit emit-$vector-set!
+ #:immediate-in-range? u8?
+ #:emit/immediate emit-$vector-set!/immediate)
+
+ (struct-vtable #:nargs 1 #:has-result? #t #:emit emit-$struct-vtable)
+ (struct-ref #:nargs 2 #:has-result? #t #:emit emit-$struct-ref
+ #:immediate-in-range? u8?
+ #:emit/immediate emit-$struct-ref/immediate)
+ (struct-set! #:nargs 3 #:emit emit-$struct-set!
+ #:immediate-in-range? u8?
+ #:emit/immediate emit-$struct-set!/immediate)
+
+ (eq? #:nargs 2 #:predicate? #t #:emit (lambda (asm a b kf)
+ (emit-eq? asm a b)
+ (emit-jne asm kf)))
+ (< #:nargs 2 #:predicate? #t #:emit (lambda (asm a b kf)
+ (emit-<? asm a b)
+ (emit-jl asm kf)))
+ (<= #:nargs 2 #:predicate? #t #:emit (lambda (asm a b kf)
+ (emit-<? asm b a)
+ (emit-jnge asm kf)))
+ (= #:nargs 2 #:predicate? #t #:emit (lambda (asm a b kf)
+ (emit-=? asm a b)
+ (emit-jne asm kf))))
+
+(define (variadic-constructor? name)
+ (memq name '(vector list make-struct/simple)))
+
+(define-syntax predicate-emitter
+ (lambda (stx)
+ (define (id-prepend pre id)
+ (datum->syntax id (symbol-append pre (syntax->datum id))))
+ (syntax-case stx ()
+ ((_ pred)
+ #`(lambda (asm a kf)
+ (#,(id-prepend 'emit- #'pred) asm a)
+ (emit-jne asm kf))))))
+(define-syntax-rule (define-immediate-type-predicate name pred mask tag)
+ (define-primitive pred #:nargs 1 #:predicate? #t
+ #:emit (predicate-emitter pred)))
+(define-syntax-rule (define-heap-type-predicate name pred mask tag)
+ (define-primitive pred #:nargs 1 #:predicate? #t
+ #:emit (lambda (asm a kf)
+ (emit-heap-object? asm a)
+ (emit-jne asm kf)
+ ((predicate-emitter pred) asm a kf))))
+
+(visit-immediate-tags define-immediate-type-predicate)
+(visit-heap-tags define-heap-type-predicate)
+
+(define (primitive-module name)
+ (case name
+ ((bytevector?
+ bytevector-length
+
+ bytevector-u8-ref bytevector-u8-set!
+ bytevector-s8-ref bytevector-s8-set!
+
+ bytevector-u16-ref bytevector-u16-set!
+ bytevector-u16-native-ref bytevector-u16-native-set!
+ bytevector-s16-ref bytevector-s16-set!
+ bytevector-s16-native-ref bytevector-s16-native-set!
+
+ bytevector-u32-ref bytevector-u32-set!
+ bytevector-u32-native-ref bytevector-u32-native-set!
+ bytevector-s32-ref bytevector-s32-set!
+ bytevector-s32-native-ref bytevector-s32-native-set!
+
+ bytevector-u64-ref bytevector-u64-set!
+ bytevector-u64-native-ref bytevector-u64-native-set!
+ bytevector-s64-ref bytevector-s64-set!
+ bytevector-s64-native-ref bytevector-s64-native-set!
+
+ bytevector-ieee-single-ref bytevector-ieee-single-set!
+ bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
+ bytevector-ieee-double-ref bytevector-ieee-double-set!
+ bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!)
+ '(rnrs bytevectors))
+ ((atomic-box?
+ make-atomic-box atomic-box-ref atomic-box-set!
+ atomic-box-swap! atomic-box-compare-and-swap!)
+ '(ice-9 atomic))
+ ((current-thread) '(ice-9 threads))
+ ((class-of) '(oop goops))
+ ((u8vector-ref
+ u8vector-set! s8vector-ref s8vector-set!
+ u16vector-ref u16vector-set! s16vector-ref s16vector-set!
+ u32vector-ref u32vector-set! s32vector-ref s32vector-set!
+ u64vector-ref u64vector-set! s64vector-ref s64vector-set!
+ f32vector-ref f32vector-set! f64vector-ref f64vector-set!)
+ '(srfi srfi-4))
+ (else '(guile))))
+
+(define (canonicalize exp)
+ (define (reify-primref src name)
+ ;; some are builtin-ref
+ (cond
+ ((builtin-name->index name)
+ => (lambda (idx)
+ (make-primcall src 'builtin-ref (list (make-const #f idx)))))
+ (else
+ (make-module-ref src (primitive-module name) name #t))))
+ (define (reify-primcall src name args)
+ (make-call src (reify-primref src name) args))
+ (define (reify-branch src name args)
+ (make-conditional src
+ (make-primcall src name args)
+ (make-const src #t)
+ (make-const src #f)))
+ (define (finish-conditional exp)
+ (define (true? x) (match x (($ <const> _ val) val) (_ #f)))
+ (define (false? x) (match x (($ <const> _ val) (not val)) (_ #f)))
+ (match exp
+ (($ <conditional> src ($ <conditional> _ test (? true?) (? false?))
+ consequent alternate)
+ (finish-conditional (make-conditional src test consequent alternate)))
+ (($ <conditional> src ($ <conditional> _ test (? false?) (? true?))
+ consequent alternate)
+ (finish-conditional (make-conditional src test alternate consequent)))
+ (($ <conditional> src test consequent alternate)
+ (make-conditional src (make-primcall src 'false? (list test))
+ alternate consequent))))
+ (post-order
+ (lambda (exp)
+ (match exp
+ ;; Turn <void> into *unspecified*.
+ (($ <void> src) (make-const src *unspecified*))
+
+ ;; Ensure the test of a conditional is a branching primcall.
+ (($ <conditional>) (finish-conditional exp))
+
+ ;; Reify primitives.
+ (($ <primitive-ref> src name) (reify-primref src name))
+
+ ;; Invert >= and >.
+ (($ <primcall> src '>= (a b)) (reify-branch src '<= (list b a)))
+ (($ <primcall> src '> (a b)) (reify-branch src '< (list b a)))
+
+ ;; Simplify "not".
+ (($ <primcall> src 'not (x))
+ (finish-conditional
+ (make-conditional src x (make-const src #f) (make-const src #t))))
+
+ ;; Special cases for variadic list, vector, make-struct/simple.
+ (($ <primcall> src (? variadic-constructor?)) exp)
+
+ ;; struct-set! needs to return its value.
+ (($ <primcall> src 'struct-set! (x idx v))
+ (let ((sym (gensym "v ")))
+ (make-let src (list 'v) (list sym) (list v)
+ (let ((v (make-lexical-ref src 'v sym)))
+ (make-seq src
+ (make-primcall src 'struct-set! (list x idx v))
+ v)))))
+
+ ;; Transform "ash" to lsh / rsh.
+ (($ <primcall> src 'ash (x ($ <const> src (? exact-integer? y))))
+ (if (negative? y)
+ (make-primcall src 'lsh (list x (make-const src (- y))))
+ (make-primcall src 'rsh (list x (make-const src y)))))
+
+ ;; (throw key subr msg (list x) (list x))
+ (($ <primcall> src 'throw
+ (($ <const> _ key) ($ <const> _ subr) ($ <const> _ msg)
+ ($ <primcall> _ 'list (x))
+ ($ <primcall> _ 'list (x))))
+ (make-primcall src 'throw/value+data
+ (list x (make-const #f `#(,key ,subr ,msg)))))
+
+ ;; (throw key subr msg (list x) #f)
+ (($ <primcall> src 'throw
+ (($ <const> _ key) ($ <const> _ subr) ($ <const> _ msg)
+ ($ <primcall> _ 'list (x))
+ ($ <const> _ #f)))
+ (make-primcall src 'throw/value
+ (list x (make-const #f `#(,key ,subr ,msg)))))
+
+ ;; (throw key arg ...)
+ (($ <primcall> src 'throw (key . args))
+ (make-primcall src 'throw
+ (list key (make-primcall #f 'list args))))
+
+ ;; Now that we handled special cases, ensure remaining primcalls
+ ;; are understood by the code generator, and if not, reify them
+ ;; as calls.
+ (($ <primcall> src name args)
+ (or (and=> (lookup-primitive name)
+ (lambda (prim)
+ (and (= (primitive-nargs prim) (length args))
+ (if (primitive-predicate? prim)
+ (reify-branch src name args)
+ exp))))
+ (reify-primcall src name args)))
+
+ ;; Add a clause to clauseless lambdas.
+ (($ <lambda> src meta #f)
+ (make-lambda src meta
+ (make-lambda-case
+ src '() #f #f #f '() '()
+ (make-primcall
+ src 'throw
+ (list (make-const src 'wrong-number-of-args)
+ (make-const src #f)
+ (make-const src "Wrong number of arguments")
+ (make-const src '())
+ (make-const src #f)))
+ #f)))
+
+ ;; Turn <abort> into abort-to-prompt.
+ (($ <abort> src tag args ($ <const> _ ()))
+ (reify-primcall src 'abort-to-prompt (cons tag args)))
+ (($ <abort> src tag args tail)
+ (reify-primcall src 'apply
+ (cons* (reify-primref src 'abort-to-prompt)
+ tag
+ (append args (list tail)))))
+
+ ;; Change non-escape-only prompt bodies from being thunks to
+ ;; expressions. (Escape-only prompt bodies are already
+ ;; expressions.)
+ (($ <prompt> src #f tag body handler)
+ (make-prompt src tag #f (make-call src body '()) handler))
+
+ (_ exp)))
+ exp))
+
+(define-record-type <closure>
+ (make-closure label code module-scope free-vars)
+ closure?
+ (label closure-label)
+ (code closure-code)
+ (module-scope closure-module-scope)
+ (free-vars closure-free-vars))
+
+;; Identify closures and assigned variables within X.
+(define (split-closures exp)
+ (define closures '())
+ (define assigned (make-hash-table))
+
+ ;; Guile's current semantics are that a toplevel lambda captures a
+ ;; reference on the current module, and that all contained lambdas use
+ ;; that module to resolve toplevel variables. The `module-scope'
+ ;; parameter of `visit-closure' tracks whether or not we are in a
+ ;; toplevel lambda. Visiting a top-level lambda allocates a new
+ ;; module-scope by incrementing this counter. Visiting a nested
+ ;; lambda re-uses the same module-scope. The code generator will
+ ;; associate these ID's with the module that was current at the point
+ ;; the top-level lambda is created.
+ (define scope-counter 0)
+
+ ;; Compute free variables in X, adding entries to `free-vars' as
+ ;; lambdas are seen, and adding set! vars to `assigned'.
+ (define (visit-closure exp module-scope)
+ (define (visit exp)
+ (define (union f1 f2) (lset-union eq? f1 f2))
+ (define (union3 f1 f2 f3) (union f1 (union f2 f3)))
+ (define (difference f1 f2) (lset-difference eq? f1 f2))
+ (define (visit* xs) (fold (lambda (x free) (union (visit x) free))
+ '() xs))
+
+ (match exp
+ (($ <lexical-ref> src name sym)
+ (list sym))
+
+ ((or ($ <const>) ($ <module-ref>) ($ <toplevel-ref>))
+ '())
+
+ (($ <lambda> src meta body)
+ (let* ((module-scope (or module-scope
+ (let ((scope scope-counter))
+ (set! scope-counter (1+ scope-counter))
+ scope)))
+ (free (visit-closure body module-scope))
+ (label (gensym "closure")))
+ (set! closures
+ (cons (make-closure label exp module-scope free)
+ closures))
+ free))
+
+ (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
+ (union (difference (union (visit* inits) (visit body))
+ gensyms)
+ (if alternate
+ (visit alternate)
+ '())))
+
+ (($ <module-set> src mod name public? exp)
+ (visit exp))
+
+ (($ <toplevel-set> src mod name exp)
+ (visit exp))
+
+ (($ <toplevel-define> src modname name exp)
+ (visit exp))
+
+ (($ <call> src proc args)
+ (union (visit proc) (visit* args)))
+
+ (($ <primcall> src name args)
+ (visit* args))
+
+ (($ <prompt> src escape-only? tag body
+ ($ <lambda> hsrc hmeta hclause))
+ (union3 (visit tag) (visit body) (visit hclause)))
+
+ (($ <conditional> src test consequent alternate)
+ (union3 (visit test) (visit consequent) (visit alternate)))
+
+ (($ <lexical-set> src name gensym exp)
+ (hashq-set! assigned gensym #t)
+ (visit exp))
+
+ (($ <seq> src head tail)
+ (union (visit head) (visit tail)))
+
+ (($ <let> src names syms vals body)
+ (union (visit* vals)
+ (difference (visit body) syms)))
+
+ (($ <fix> src names gensyms funs body)
+ (difference (union (visit* funs) (visit body))
+ gensyms))
+
+ (($ <let-values> src exp body)
+ (union (visit exp) (visit body)))))
+
+ (visit exp))
+
+ (match (visit-closure exp #f)
+ (()
+ (let ()
+ (define x-thunk
+ (let ((src (tree-il-src exp)))
+ (make-lambda src '()
+ (make-lambda-case src '() #f #f #f '() '() exp #f))))
+ (values (cons (make-closure 'init x-thunk #f '())
+ (reverse closures))
+ assigned)))
+ (vars
+ (error "unexpected free vars" vars))))
+
+(define call-frame-size 3)
+
+(define (compute-frame-size clause)
+ "Compute a conservative count of how many stack slots will be needed
+in the frame with for the lambda-case clause @var{clause}."
+ (define (visit* xs)
+ (fold (lambda (x size) (max (visit x) size)) 0 xs))
+ (define (visit-args xs)
+ (let lp ((i 0) (xs xs))
+ (match xs
+ (() i)
+ ((x . xs)
+ (max (+ i (visit x))
+ (lp (+ i 1) xs))))))
+
+ ;; Computing a value may require temporaries. For example, for
+ ;; module-ref, we may need a temporary for the module and a temporary
+ ;; for the symbol. Instead of trying to be extraordinarily precise
+ ;; about temporary usage in all the different cases, let's just
+ ;; reserve 3 temporaries.
+ (define temporary-count 3)
+
+ (define (visit exp)
+ (match exp
+ ((or ($ <const>) ($ <lexical-ref>) ($ <module-ref>) ($ <toplevel-ref>)
+ ($ <lambda>))
+ 1)
+
+ (($ <module-set> src mod name public? exp)
+ (+ 1 (visit exp)))
+ (($ <toplevel-set> src mod name exp)
+ (+ 1 (visit exp)))
+ (($ <toplevel-define> src modname name exp)
+ (+ 1 (visit exp)))
+
+ (($ <call> src proc args)
+ (+ call-frame-size (visit-args (cons proc args))))
+
+ (($ <primcall> src name args)
+ (visit-args args))
+
+ (($ <prompt> src escape-only? tag body
+ ($ <lambda> hsrc hmeta
+ ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
+ (max (visit tag)
+ (visit body)
+ (+ (length hsyms) (visit hbody))))
+
+ (($ <conditional> src test consequent alternate)
+ (max (visit test) (visit consequent) (visit alternate)))
+
+ (($ <lexical-set> src name gensym exp)
+ (+ 1 (visit exp)))
+
+ (($ <seq> src head tail)
+ (max (visit head) (visit tail)))
+
+ (($ <let> src names syms vals body)
+ (max (visit-args vals)
+ (+ (length vals) (visit body))))
+
+ (($ <fix> src names gensyms funs body)
+ (+ (length funs) (visit body)))
+
+ (($ <let-values> src exp
+ ($ <lambda-case> lsrc req #f rest #f () syms body #f))
+ (max (visit exp)
+ (+ (length syms) (visit body))))))
+
+ (match clause
+ (($ <lambda-case> src req opt rest kw inits syms body alt)
+ (+ 1 ; One slot for the closure.
+ (length syms) ; One slot for each arg.
+ (max (visit* inits) ; Prologue.
+ (visit body)) ; Body.
+ temporary-count)))) ; Temporaries.
+
+(define (compile-closure asm closure assigned? lookup-closure)
+ (define-record-type <env>
+ (make-env prev name id idx closure? boxed? next-local)
+ env?
+
+ ;; Outer <env>, or #f.
+ (prev env-prev)
+
+ ;; Pretty name of the binding, or #f.
+ (name env-name)
+
+ ;; For a lexical (local or closure), its sym. For temporaries, #f.
+ (id env-id)
+
+ ;; For temporary or local, index from SP at which this value can be
+ ;; loaded. Otherwise index from closure.
+ (idx env-idx)
+
+ ;; True for closure vars, false otherwise.
+ (closure? env-closure?)
+
+ ;; True for boxed vars, false otherwise. Only lexicals can be boxed.
+ (boxed? env-boxed?)
+
+ ;; If another local is pushed on inside this lexical environment,
+ ;; where it should be written. Usually the same as (1- idx) except
+ ;; in the case of lexical aliases. Invariant: no binding in the
+ ;; <env> chain has an idx of next-local or lower. For closure
+ ;; bindings, #f.
+ (next-local env-next-local))
+
+ (define (lookup-lexical sym env)
+ (match env
+ (($ <env> prev _ id)
+ (if (eq? id sym)
+ env
+ (lookup-lexical sym prev)))
+ (_ (error "sym not found!" sym))))
+
+ (define (frame-base env)
+ (match env
+ (($ <env> _ 'frame-base #f)
+ env)
+ (($ <env> prev)
+ (frame-base prev))))
+
+ (define (push-free-var sym idx env)
+ (make-env env sym sym idx #t (assigned? sym) #f))
+
+ (define (push-closure frame-size env)
+ (push-local 'closure #f
+ (make-env env 'frame-base #f #f #f #f (- frame-size 1))))
+
+ (define (push-local name sym env)
+ (let ((idx (env-next-local env)))
+ (make-env env name sym idx #f (assigned? sym) (1- idx))))
+
+ (define (push-local-alias name sym idx env)
+ (make-env env name sym idx #f #f (env-next-local env)))
+
+ (define (push-temp env)
+ (let ((idx (env-next-local env)))
+ (make-env env #f #f idx #f #f (1- idx))))
+
+ (define (push-frame env)
+ (let lp ((i 0) (env env))
+ (if (< i call-frame-size)
+ (lp (1+ i) (push-temp env))
+ env)))
+
+ (define (create-initial-env names syms free-syms frame-size)
+ (define (push-free-vars env)
+ (let lp ((idx 0) (free free-syms) (env env))
+ (match free
+ (() env)
+ ((sym . free)
+ (lp (1+ idx) free
+ (push-free-var sym idx env))))))
+ (fold push-local (push-closure frame-size (push-free-vars #f)) names syms))
+
+ (define (compile-body clause module-scope free-vars frame-size)
+ (define (stack-height env)
+ (- frame-size (env-next-local env) 1))
+
+ (define (maybe-cache-module! scope tmp)
+ (unless module-scope
+ (emit-current-module asm 0)
+ (emit-cache-set! asm scope 0)))
+
+ (define (init-free-vars dst free-vars env tmp0 tmp1)
+ (let lp ((free-idx 0) (free-vars free-vars))
+ (unless (null? free-vars)
+ (let* ((loc (lookup-lexical (car free-vars) env))
+ (idx (env-idx loc)))
+ (cond
+ ((env-closure? loc)
+ (emit-load-free-variable asm tmp0 (1- frame-size) idx tmp1)
+ (emit-init-free-variable asm dst free-idx tmp0 tmp1))
+ (else
+ (emit-init-free-variable asm dst free-idx idx tmp0))))
+ (lp (1+ free-idx) (cdr free-vars)))))
+
+ ;; Visit let-values or prompt handler.
+ (define (visit-values-handler src req rest syms body env ctx)
+ (define (push-bindings names syms env)
+ (fold (lambda (name sym env)
+ (let ((env (push-local name sym env)))
+ (when (env-boxed? env)
+ (emit-box asm (env-idx env) (env-idx env)))
+ env))
+ names syms env))
+ (let ((proc-slot (stack-height env))
+ (nreq (length req)))
+ (unless (and rest (zero? nreq))
+ (emit-receive-values asm proc-slot (->bool rest) nreq))
+ (when rest
+ (emit-bind-rest asm (+ proc-slot nreq)))
+ (emit-reset-frame asm frame-size)
+ (let ((names (append req (if rest (list rest) '()))))
+ (for-context body (push-bindings names syms env) ctx))))
+
+ (define (visit-prompt exp env ctx)
+ (match exp
+ (($ <prompt> src escape-only? tag body
+ ($ <lambda> hsrc hmeta
+ ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
+ (let ((tag (env-idx (for-value tag env)))
+ (proc-slot (stack-height env))
+ (khandler (gensym "handler"))
+ (done (gensym "done")))
+
+ (emit-prompt src tag escape-only? proc-slot khandler)
+ (match ctx
+ ('tail
+ ;; Would be nice if we could invoke the body in true tail
+ ;; context, but that's not how it currently is.
+ (for-values body env)
+ (emit-unwind asm)
+ (emit-return-values asm))
+ (_
+ (for-context body env ctx)
+ (emit-unwind asm)
+ (emit-j asm done)))
+
+ (emit-label asm khandler)
+ (visit-values-handler hsrc hreq hrest hsyms hbody env ctx)
+
+ (emit-label asm done)))))
+
+ (define (visit-conditional exp env ctx)
+ (match exp
+ (($ <conditional> src ($ <primcall> tsrc name args)
+ consequent alternate)
+ (let ((emit (primitive-emitter (lookup-primitive name)))
+ (args (for-args args env))
+ (kf (gensym "false"))
+ (kdone (gensym "done")))
+ (match args
+ ((a) (emit asm args a kf))
+ ((a b) (emit asm args a b kf)))
+ (for-context consequent env ctx)
+ (unless (eq? ctx 'tail)
+ (emit-j asm kdone))
+ (emit-label asm kf)
+ (for-context alternate env ctx)
+ (emit-label asm kdone)))))
+
+ (define (visit-seq exp env ctx)
+ (match exp
+ (($ <seq> src head tail)
+ (for-effect head env)
+ (for-context tail env ctx))))
+
+ (define (visit-let exp env ctx)
+ (define (push-bindings names syms vals env)
+ (fold (lambda (name sym val env)
+ (for-push val env)
+ (let ((env (push-local name sym env)))
+ (when (env-boxed? env)
+ (emit-box asm (env-idx env) (env-idx env)))
+ env))
+ env names syms vals))
+ (match exp
+ (($ <let> src names syms vals body)
+ (for-context body (push-bindings names syms vals env) ctx))))
+
+ (define (visit-fix exp env ctx)
+ (define (push-bindings names syms vals env)
+ (let* ((closures (map lookup-closure vals))
+ (env (fold
+ (lambda (name sym closure env)
+ (let ((env (push-local name sym env)))
+ (match closure
+ (($ <closure> label code scope free-vars)
+ (emit-maybe-allocate-closure
+ asm (env-idx env) (length free-vars) label 0)
+ env))))
+ env names syms closures)))
+ (for-each
+ (lambda (sym closure)
+ (let ((idx (env-idx (lookup-lexical sym env))))
+ (match closure
+ (($ <closure> label code scope free-vars)
+ (init-free-vars idx free-vars env 0 1)))))
+ syms closures)
+ env))
+ (match exp
+ (($ <fix> src names syms vals body)
+ (for-context body (push-bindings names syms vals env) ctx))))
+
+ (define (visit-let-values exp env ctx)
+ (match exp
+ (($ <let-values> src exp
+ ($ <lambda-case> lsrc req #f rest #f () syms body #f))
+ (for-values exp env)
+ (visit-values-handler lsrc req rest syms body env ctx))))
+
+ (define (for-context exp env ctx)
+ (match ctx
+ ('effect (for-effect exp env))
+ ('value (for-value exp env))
+ ('tail (for-tail exp env))
+ (('value-at . base) (for-value-at exp env base))
+ (('values-at . base) (for-values-at exp env base))))
+
+ (define (for-args exps env)
+ (match exps
+ (() '())
+ ((exp . exps)
+ (let ((env (for-value exp env)))
+ (cons (env-idx env) (for-args exps env))))))
+
+ (define (for-effect exp env)
+ (match exp
+ ((or ($ <lexical-ref>) ($ <const>) ($ <lambda>))
+ ;; Nothing to do.
+ (values))
+
+ ((or ($ <module-ref>) ($ <toplevel-ref>)
+ ($ <primcall> _ (? variadic-constructor?)))
+ ;; Cause side effects but ignore value.
+ (for-value exp env))
+
+ (($ <lexical-set> src name sym exp)
+ (let ((env (for-value exp env)))
+ (match (lookup-lexical sym env)
+ (($ <env> _ _ _ idx #t #t) ;; Boxed closure.
+ (emit-load-free-variable asm 0 (1- frame-size) idx 0)
+ (emit-$variable-set! asm 0 (env-idx env)))
+ (($ <env> _ _ _ idx #f #t) ;; Boxed local.
+ (emit-$variable-set! asm idx (env-idx env))))))
+
+ (($ <module-set> src mod name public? exp)
+ (let ((env (for-value exp env)))
+ (emit-cached-module-box asm 0 mod name public? 1)
+ (emit-$variable-set! asm 0 (env-idx env))))
+
+ (($ <toplevel-set> src mod name exp)
+ (let ((env (for-value exp env)))
+ (if module-scope
+ (emit-cached-toplevel-box asm 0 module-scope name 1)
+ (emit-toplevel-box asm 0 name 1))
+ (emit-$variable-set! asm 0 (env-idx env))))
+
+ (($ <toplevel-define> src mod name exp)
+ (let ((env (for-value exp env)))
+ (emit-current-module asm 0)
+ (emit-load-constant asm 1 name)
+ (emit-define! asm 0 0 1)
+ (emit-$variable-set! asm 0 (env-idx env))))
+
+ (($ <call> src proc args)
+ (let ((proc-slot (let ((env (push-frame env)))
+ (fold for-push (for-push proc env) args)
+ (stack-height env))))
+ (emit-call asm proc-slot (1+ (length args)))
+ (emit-reset-frame asm frame-size)))
+
+ (($ <primcall> src name args)
+ (let ((prim (lookup-primitive name)))
+ (define (emit/immediate? val)
+ (and=> (primitive-immediate-in-range-predicate prim) val))
+ (cond
+ ((primitive-has-result? prim)
+ (for-value exp env))
+ (else
+ (match args
+ ((a ($ <const> _ (? emit/immediate? b)))
+ (let ((emit (primitive-emitter/immediate prim)))
+ (match (for-args (list a) env)
+ ((a) (emit asm a b)))))
+ ((a ($ <const> _ (? emit/immediate? b)) c)
+ (let ((emit (primitive-emitter/immediate prim)))
+ (match (for-args (list a c) env)
+ ((a c) (emit asm a b c)))))
+ (_
+ (let ((emit (primitive-emitter prim)))
+ (apply emit asm (for-args args env)))))))))
+
+ (($ <prompt>) (visit-prompt exp env 'effect))
+ (($ <conditional>) (visit-conditional exp env 'effect))
+ (($ <seq>) (visit-seq exp env 'effect))
+ (($ <let>) (visit-let exp env 'effect))
+ (($ <fix>) (visit-fix exp env 'effect))
+ (($ <let-values>) (visit-let-values exp env 'effect)))
+
+ (values))
+
+ (define (for-value-at exp env base)
+ ;; The baseline compiler follows a stack discipline: compiling
+ ;; temporaries pushes entries on an abstract compile-time stack
+ ;; (the "env"), which are then popped as they are used. Generally
+ ;; speaking the "env" is compiled as stack slots: compiling an
+ ;; operand pushes on an "env" entry, which increments the current
+ ;; stack height, allocating a new slot that is in use by no live
+ ;; value. However since we're targetting a register VM though,
+ ;; there are some important optimizations we should make.
+ ;;
+ ;; 1. In the case of (lambda (x) (+ x x)), we don't want to cause
+ ;; the references to "x" to allocate new stack slots. We want
+ ;; to emit:
+ ;;
+ ;; (add 0 0 0)
+ ;; (return-values)
+ ;;
+ ;; and not:
+ ;;
+ ;; (mov 1 0)
+ ;; (mov 2 0)
+ ;; (add 0 1 2)
+ ;; (return-values)
+ ;;
+ ;; (These examples use FP-relative indexes.)
+ ;;
+ ;; This optimization is handled by for-value, which can push
+ ;; on a special "env" that aliases a lexical binding.
+ ;;
+ ;; 2. Again for (lambda (x) (+ x x)), we want to write the result
+ ;; directly to its destination, which may alias an operand.
+ ;; So we want to avoid this:
+ ;;
+ ;; (add 1 0 0)
+ ;; (mov 0 1)
+ ;; (return-values)
+ ;;
+ ;; That optimization is implemented by for-value-at and
+ ;; for-values-at. It works as long as long as the destination
+ ;; is clobbered only after operands are used, so each part of
+ ;; this function has to be careful not to do some kind of
+ ;; multi-part computation that first clobbers "dst" and then
+ ;; reads the operands.
+ (define dst-env (push-temp base))
+ (define dst (env-idx dst-env))
+ (match exp
+ (($ <lexical-ref> src name sym)
+ (match (lookup-lexical sym env)
+ (($ <env> _ _ _ idx #t #t)
+ (emit-load-free-variable asm dst (1- frame-size) idx 0)
+ (emit-$variable-ref asm dst dst))
+ (($ <env> _ _ _ idx #t #f)
+ (emit-load-free-variable asm dst (1- frame-size) idx 0))
+ (($ <env> _ _ _ idx #f #t)
+ (emit-$variable-ref asm dst idx))
+ (($ <env> _ _ _ idx #f #f)
+ (emit-mov asm dst idx))))
+
+ (($ <const> src val)
+ (emit-load-constant asm dst val))
+
+ (($ <module-ref> src mod name public?)
+ (emit-cached-module-box asm 0 mod name public? 1)
+ (emit-$variable-ref asm dst 0))
+
+ (($ <toplevel-ref> src mod name)
+ (if module-scope
+ (emit-cached-toplevel-box asm 0 module-scope name 1)
+ (emit-toplevel-box asm 0 name 1))
+ (emit-$variable-ref asm dst 0))
+
+ (($ <lambda> src)
+ (match (lookup-closure exp)
+ (($ <closure> label code scope free-vars)
+ (maybe-cache-module! scope 0)
+ (match (length free-vars)
+ (0
+ (emit-load-static-procedure asm dst label))
+ (nfree
+ ;; Stage closure in 0 to avoid stompling captured free
+ ;; vars.
+ (emit-allocate-closure asm 0 nfree label 1)
+ (init-free-vars 0 free-vars env 1 2)
+ (emit-mov asm dst 0))))))
+
+ ((or ($ <lexical-set>)
+ ($ <module-set>)
+ ($ <toplevel-set>)
+ ($ <toplevel-define>))
+ (for-effect exp env)
+ (emit-load-constant asm dst *unspecified*))
+
+ (($ <call> src proc args)
+ (let ((proc-slot (let ((env (push-frame env)))
+ (fold for-push (for-push proc env) args)
+ (stack-height env))))
+ (emit-call asm proc-slot (length args))
+ (emit-receive src dst proc-slot frame-size)))
+
+ (($ <primcall> src (? variadic-constructor? name) args)
+ ;; Stage result in 0 to avoid stompling args.
+ (let ((args (for-args args env)))
+ (match name
+ ('list
+ (emit-load-constant asm 0 '())
+ (for-each (lambda (arg)
+ (emit-cons asm 0 arg 0))
+ (reverse args)))
+ ('vector
+ (let ((len (length args)))
+ (emit-allocate-vector asm 0 len 1)
+ (let lp ((i 0) (args args))
+ (when (< i len)
+ (emit-vector-init! asm 0 i (car args) 1)
+ (lp (1+ i) (cdr args))))))
+ ('make-struct/simple
+ (match args
+ ((vtable . args)
+ (let ((len (length args)))
+ (emit-$allocate-struct asm 0 vtable len)
+ (let lp ((i 0) (args args))
+ (when (< i len)
+ (emit-struct-init! asm 0 i (car args) 1)
+ (lp (1+ i) (cdr args)))))))))
+ (emit-mov asm dst 0)))
+
+ (($ <primcall> src name args)
+ (let ((prim (lookup-primitive name)))
+ (define (emit/immediate? val)
+ (and=> (primitive-immediate-in-range-predicate prim) val))
+ (cond
+ ((not (primitive-has-result? prim))
+ (for-effect exp env)
+ (emit-load-constant asm dst *unspecified*))
+ (else
+ (match args
+ ((($ <const> _ (? emit/immediate? a)))
+ (let* ((emit (primitive-emitter/immediate prim)))
+ (emit asm dst a)))
+ ((a ($ <const> _ (? emit/immediate? b)))
+ (let* ((emit (primitive-emitter/immediate prim))
+ (a (for-value a env)))
+ (emit asm dst (env-idx a) b)))
+ (_
+ (let ((emit (primitive-emitter prim)))
+ (apply emit asm dst (for-args args env)))))))))
+
+ (($ <prompt>) (visit-prompt exp env `(value-at . ,base)))
+ (($ <conditional>) (visit-conditional exp env `(value-at. ,base)))
+ (($ <seq>) (visit-seq exp env `(value-at . ,base)))
+ (($ <let>) (visit-let exp env `(value-at . ,base)))
+ (($ <fix>) (visit-fix exp env `(value-at . ,base)))
+ (($ <let-values>) (visit-let-values exp env `(value-at . ,base))))
+ dst-env)
+
+ (define (for-value exp env)
+ (match (and (lexical-ref? exp)
+ (lookup-lexical (lexical-ref-gensym exp) env))
+ (($ <env> _ name sym idx #f #f)
+ (push-local-alias name sym idx env))
+ (_
+ (for-push exp env))))
+
+ (define (for-push exp env)
+ (for-value-at exp env env))
+
+ (define (for-init sym init env)
+ (match (lookup-lexical sym env)
+ (($ <env> prev name sym idx #f boxed? next-local)
+ (when init
+ (let ((done (gensym "post-init")))
+ (emit-undefined? asm idx)
+ (emit-jne asm done)
+ (for-value-at init env prev)
+ (emit-label asm done)))
+ (when boxed?
+ (emit-box asm idx idx)))))
+
+ (define (for-values-at exp env base)
+ (match exp
+ ((or ($ <const>)
+ ($ <lexical-ref>)
+ ($ <lexical-set>)
+ ($ <toplevel-ref>)
+ ($ <toplevel-set>)
+ ($ <toplevel-define>)
+ ($ <module-ref>)
+ ($ <module-set>)
+ ($ <lambda>)
+ ($ <primcall>))
+ (for-value-at exp env base)
+ (emit-reset-frame asm (1+ (stack-height base))))
+
+ (($ <call> src proc args)
+ (let* ((to (stack-height base))
+ (env (push-frame env))
+ (from (stack-height env)))
+ (fold for-push (for-push proc env) args)
+ (emit-call asm from (1+ (length args)))
+ (unless (= from to)
+ (emit-shuffle-down asm from to))))
+
+ (($ <prompt>) (visit-prompt exp env `(values-at . ,base)))
+ (($ <conditional>) (visit-conditional exp env `(values-at . ,base)))
+ (($ <seq>) (visit-seq exp env `(values-at . ,base)))
+ (($ <let>) (visit-let exp env `(values-at . ,base)))
+ (($ <fix>) (visit-fix exp env `(values-at . ,base)))
+ (($ <let-values>) (visit-let-values exp env `(values-at . ,base))))
+
+ (values))
+
+ (define (for-values exp env)
+ (for-values-at exp env env))
+
+ (define (for-tail exp env)
+ (match exp
+ ((or ($ <const>)
+ ($ <lexical-ref>)
+ ($ <lexical-set>)
+ ($ <toplevel-ref>)
+ ($ <toplevel-set>)
+ ($ <toplevel-define>)
+ ($ <module-ref>)
+ ($ <module-set>)
+ ($ <lambda>)
+ ($ <primcall>))
+ (for-values-at exp env (frame-base env))
+ (emit-return-values asm))
+
+ (($ <call> src proc args)
+ (let ((from (stack-height env)))
+ (fold for-push (for-push proc env) args)
+ (emit-reset-frame asm (+ from 1 (length args)))
+ (emit-shuffle-down asm from 0)
+ (emit-tail-call asm)))
+
+ (($ <prompt>) (visit-prompt exp env 'tail))
+ (($ <conditional>) (visit-conditional exp env 'tail))
+ (($ <seq>) (visit-seq exp env 'tail))
+ (($ <let>) (visit-let exp env 'tail))
+ (($ <fix>) (visit-fix exp env 'tail))
+ (($ <let-values>) (visit-let-values exp env 'tail)))
+
+ (values))
+
+ (match clause
+ (($ <lambda-case> src req opt rest kw inits syms body alt)
+ (let ((names (append req
+ (or opt '())
+ (if rest (list rest) '())
+ (match kw
+ ((aok? (key name sym) ...) name)
+ (#f '()))))
+ (inits (append (make-list (length req) #f)
+ (list-head inits (if opt (length opt) 0))
+ (if rest '(#f) '())
+ (list-tail inits (if opt (length opt) 0)))))
+ (unless (= (length names) (length syms) (length inits))
+ (error "unexpected args" names syms inits))
+ (let ((env (create-initial-env names syms free-vars frame-size)))
+ (for-each (lambda (sym init) (for-init sym init env)) syms inits)
+ (for-tail body env))))))
+
+ (define (emit-clause label clause module-scope free)
+ (let ((frame-size (compute-frame-size clause)))
+ (match clause
+ (($ <lambda-case> src req opt rest kw inits syms body alt)
+ (let ((alt-label (and alt (gensym "clause"))))
+ (call-with-values
+ (lambda ()
+ (match kw
+ (#f (values #f '()))
+ ((aok? . kw)
+ (values aok?
+ (map (match-lambda
+ ((key name sym)
+ (cons key (list-index syms sym))))
+ kw)))))
+ (lambda (allow-other-keys? kw-indices)
+ (when label (emit-label asm label))
+ (let ((has-closure? #t) (opt (or opt '())))
+ (emit-begin-kw-arity asm has-closure? req opt rest kw-indices
+ allow-other-keys? frame-size alt-label))
+ (compile-body clause module-scope free frame-size)
+ (emit-end-arity asm)
+ (when alt
+ (emit-clause alt-label alt module-scope free)))))))))
+ (match closure
+ (($ <closure> label ($ <lambda> src meta body) module-scope free)
+ (when src (emit-source asm src))
+ (emit-begin-program asm label meta)
+ (emit-clause #f body module-scope free)
+ (emit-end-program asm))))
+
+(define %warning-passes
+ `((unused-variable . ,unused-variable-analysis)
+ (unused-toplevel . ,unused-toplevel-analysis)
+ (shadowed-toplevel . ,shadowed-toplevel-analysis)
+ (unbound-variable . ,unbound-variable-analysis)
+ (macro-use-before-definition . ,macro-use-before-definition-analysis)
+ (arity-mismatch . ,arity-analysis)
+ (format . ,format-analysis)))
+
+(define (optimize-tree-il x e opts)
+ (define warnings
+ (or (and=> (memq #:warnings opts) cadr)
+ '()))
+
+ ;; Go through the warning passes.
+ (let ((analyses (filter-map (lambda (kind)
+ (assoc-ref %warning-passes kind))
+ warnings)))
+ (analyze-tree analyses x e))
+
+ (optimize x e opts))
+
+(define (kw-arg-ref args kw default)
+ (match (memq kw args)
+ ((_ val . _) val)
+ (_ default)))
+
+(define (compile-bytecode exp env opts)
+ (let* ((exp (canonicalize (optimize-tree-il exp env opts)))
+ (asm (make-assembler)))
+ (call-with-values (lambda () (split-closures exp))
+ (lambda (closures assigned)
+ (let ((by-code (make-hash-table)))
+ (for-each (lambda (closure)
+ (hashq-set! by-code (closure-code closure) closure))
+ closures)
+ (define (assigned? sym)
+ (hashq-ref assigned sym))
+ (define (lookup-closure x)
+ (or (hashq-ref by-code x) (error "missing <closure>" x)))
+ (for-each (lambda (closure)
+ (compile-closure asm closure assigned? lookup-closure))
+ closures))))
+ (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
+ env
+ env)))