????
Your IP : 3.139.239.16
;;; Lightweight compiler directly from Tree-IL to bytecode
;; Copyright (C) 2020, 2021 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 program. If not, see <http://www.gnu.org/licenses/>.
;;; 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:
(define-module (language tree-il compile-bytecode)
#:use-module (ice-9 match)
#:use-module (language bytecode)
#:use-module (language tree-il)
#:use-module ((srfi srfi-1) #:select (filter-map
fold
lset-adjoin 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-scm-set!/immediate asm loc 1 val))
(define (emit-box-ref asm dst loc)
(emit-scm-ref/immediate asm dst loc 1))
(define (emit-cons asm dst car cdr)
(cond
((= car dst)
(emit-mov asm 1 car)
(emit-cons asm dst 1 (if (= cdr dst) 1 cdr)))
((= 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? bound? 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)
(cond
(bound?
(let ((name (symbol->string name)))
(if public?
(emit-lookup-bound-public asm dst mod name)
(emit-lookup-bound-private asm dst mod name))))
(else
(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 bound? 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)
(if bound?
(emit-lookup-bound asm dst dst tmp)
(emit-lookup asm dst dst tmp))
(emit-cache-set! asm key dst)
(emit-label asm cached))
(define (emit-toplevel-box asm dst name bound? tmp)
(emit-current-module asm dst)
(emit-load-constant asm tmp name)
(if bound?
(emit-lookup-bound asm dst dst tmp)
(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 #:nargs 0 #:emit emit-pop-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))
#:immediate-in-range? (lambda (x)
(and=>
(scm->immediate-bits x)
(lambda (bits)
(truncate-bits bits 16 #t))))
#:emit/immediate (lambda (asm a b kf)
(emit-eq-immediate? asm a b)
(emit-jne asm kf)))
(< #:nargs 2 #:predicate? #t #:emit (lambda (asm a b kf)
(emit-<? asm a b)
(emit-jnl 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 define-immediate-type-predicate
(syntax-rules ()
((_ name #f mask tag) #f)
((_ 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)))
(define (predicate? name) (primitive-predicate? (lookup-primitive name)))
(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 ($ <primcall> _ (? predicate?)))
exp)
(($ <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)))
;; For eq? on constants, make the second arg the constant.
(($ <primcall> src 'eq? ((and a ($ <const>))
(and b (not ($ <const>)))))
(reify-branch src 'eq? (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))
(with-lexicals src (v)
(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 'rsh (list x (make-const src* (- y))))
(make-primcall src 'lsh (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 #f tag (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 (adjoin sym f) (lset-adjoin eq? f sym))
(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)
(adjoin gensym (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 (compile-body clause module-scope free-vars frame-size)
(define (push-free-var sym idx env)
(make-env env sym sym idx #t (assigned? sym) (env-next-local env)))
(define (push-local name sym env)
(let ((idx (env-next-local env)))
(emit-definition asm name (- frame-size idx 1) 'scm)
(make-env env name sym idx #f (assigned? sym) (1- idx))))
(define (push-closure env)
(push-local 'closure #f env))
(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)
(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))))))
(define frame-base
(make-env #f 'frame-base #f #f #f #f (- frame-size 1)))
(fold push-local (push-closure (push-free-vars frame-base)) names syms))
(define (stack-height-under-local idx)
(- frame-size idx 1))
(define (stack-height env)
(stack-height-under-local (env-next-local env)))
(define (maybe-cache-module! scope tmp)
(unless module-scope
(emit-current-module asm 0)
(emit-cache-set! asm scope 0)))
(define (maybe-emit-source source)
(when source (emit-source asm source)))
(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))
env names syms))
(let ((proc-slot (stack-height env))
(nreq (length req)))
(maybe-emit-source src)
(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)))
(maybe-emit-source src)
(let ((tag (env-idx (for-value tag env)))
(proc-slot (stack-height env))
(khandler (gensym "handler"))
(done (gensym "done")))
(emit-prompt asm 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-at body env 0)
(emit-unwind asm)
(emit-handle-interrupts 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)
(maybe-emit-source tsrc)
(let ((prim (lookup-primitive name))
(kf (gensym "false"))
(kdone (gensym "done")))
(define (emit/immediate? val)
(and=> (primitive-immediate-in-range-predicate prim)
(lambda (pred) (pred val))))
(match args
((a ($ <const> _ (? emit/immediate? b)))
(let ((emit (primitive-emitter/immediate prim)))
(match (for-args (list a) env)
((a)
(maybe-emit-source src)
(emit asm a b kf)))))
(_
(let ((emit (primitive-emitter prim))
(args (for-args args env)))
(maybe-emit-source src)
(match args
((a) (emit asm a kf))
((a b) (emit asm 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)
(maybe-emit-source src)
(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)
(maybe-emit-source src)
(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)
;; FIXME: Allocate one scope per fix.
(maybe-cache-module! scope 0)
(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)
(maybe-emit-source src)
(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))
(maybe-emit-source src)
(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 . dst) (for-value-at exp env dst))
(('values-at . height) (for-values-at exp env height))))
(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)))
(maybe-emit-source src)
(match (lookup-lexical sym env)
(($ <env> _ _ _ idx #t #t) ;; Boxed closure.
(emit-load-free-variable asm 0 (1- frame-size) idx 0)
(emit-box-set! asm 0 (env-idx env)))
(($ <env> _ _ _ idx #f #t) ;; Boxed local.
(emit-box-set! asm idx (env-idx env))))))
(($ <module-set> src mod name public? exp)
(let ((env (for-value exp env)))
(maybe-emit-source src)
(emit-cached-module-box asm 0 mod name public? #f 1)
(emit-box-set! asm 0 (env-idx env))))
(($ <toplevel-set> src mod name exp)
(let ((env (for-value exp env)))
(maybe-emit-source src)
(if module-scope
(emit-cached-toplevel-box asm 0 module-scope name #f 1)
(emit-toplevel-box asm 0 name #f 1))
(emit-box-set! asm 0 (env-idx env))))
(($ <toplevel-define> src mod name exp)
(let ((env (for-value exp env)))
(maybe-emit-source src)
(emit-current-module asm 0)
(emit-load-constant asm 1 name)
(emit-define! asm 0 0 1)
(emit-box-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))))
(maybe-emit-source src)
(emit-handle-interrupts asm)
(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)
(lambda (pred) (pred 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)
(maybe-emit-source src)
(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)
(maybe-emit-source src)
(emit asm a b c)))))
(_
(let ((emit (primitive-emitter prim))
(args (for-args args env)))
(maybe-emit-source src)
(apply emit asm args))))))))
(($ <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))))
(define (for-value-at exp env dst)
;; 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.
(match exp
(($ <lexical-ref> src name sym)
(maybe-emit-source src)
(match (lookup-lexical sym env)
(($ <env> _ _ _ idx #t #t)
(emit-load-free-variable asm dst (1- frame-size) idx 0)
(emit-box-ref asm dst dst))
(($ <env> _ _ _ idx #t #f)
(emit-load-free-variable asm dst (1- frame-size) idx 0))
(($ <env> _ _ _ idx #f #t)
(emit-box-ref asm dst idx))
(($ <env> _ _ _ idx #f #f)
(emit-mov asm dst idx))))
(($ <const> src val)
(maybe-emit-source src)
(emit-load-constant asm dst val))
(($ <module-ref> src mod name public?)
(maybe-emit-source src)
(emit-cached-module-box asm 0 mod name public? #t 1)
(emit-box-ref asm dst 0))
(($ <toplevel-ref> src mod name)
(maybe-emit-source src)
(if module-scope
(emit-cached-toplevel-box asm 0 module-scope name #t 1)
(emit-toplevel-box asm 0 name #t 1))
(emit-box-ref asm dst 0))
(($ <lambda> src)
(maybe-emit-source 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))))
(maybe-emit-source src)
(emit-handle-interrupts asm)
(emit-call asm proc-slot (1+ (length args)))
(emit-receive asm (stack-height-under-local 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)))
(maybe-emit-source src)
(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)
(emit-load-constant asm 0 (length args))
(emit-$allocate-struct asm 0 vtable 0)
(let lp ((i 0) (args args))
(match args
(() #t)
((arg . args)
(emit-struct-init! asm 0 i arg 1)
(lp (1+ i) 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)
(lambda (pred) (pred 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)))
(maybe-emit-source src)
(emit asm dst a)))
((a ($ <const> _ (? emit/immediate? b)))
(let* ((emit (primitive-emitter/immediate prim))
(a (for-value a env)))
(maybe-emit-source src)
(emit asm dst (env-idx a) b)))
(_
(let ((emit (primitive-emitter prim))
(args (for-args args env)))
(maybe-emit-source src)
(apply emit asm dst args))))))))
(($ <prompt>) (visit-prompt exp env `(value-at . ,dst)))
(($ <conditional>) (visit-conditional exp env `(value-at . ,dst)))
(($ <seq>) (visit-seq exp env `(value-at . ,dst)))
(($ <let>) (visit-let exp env `(value-at . ,dst)))
(($ <fix>) (visit-fix exp env `(value-at . ,dst)))
(($ <let-values>) (visit-let-values exp env `(value-at . ,dst)))))
(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-next-local env))
(push-temp 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 idx)
(emit-label asm done)))
(when boxed?
(emit-box asm idx idx)))))
(define (for-values-at exp env height)
(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 (- frame-size height 1))
(emit-reset-frame asm (1+ height)))
(($ <call> src proc args)
(let* ((env (push-frame env))
(from (stack-height env)))
(fold for-push (for-push proc env) args)
(maybe-emit-source src)
(emit-handle-interrupts asm)
(emit-call asm from (1+ (length args)))
(unless (= from height)
(emit-shuffle-down asm from height))))
(($ <prompt>) (visit-prompt exp env `(values-at . ,height)))
(($ <conditional>) (visit-conditional exp env `(values-at . ,height)))
(($ <seq>) (visit-seq exp env `(values-at . ,height)))
(($ <let>) (visit-let exp env `(values-at . ,height)))
(($ <fix>) (visit-fix exp env `(values-at . ,height)))
(($ <let-values>) (visit-let-values exp env `(values-at . ,height)))))
(define (for-values exp env)
(for-values-at exp env (stack-height 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 0)
(emit-handle-interrupts asm)
(emit-return-values asm))
(($ <call> src proc args)
(let* ((base (stack-height env))
(env (fold for-push (for-push proc env) args)))
(maybe-emit-source src)
(let lp ((i (length args)) (env env))
(when (<= 0 i)
(lp (1- i) (env-prev env))
(emit-mov asm (+ (env-idx env) base) (env-idx env))))
(emit-reset-frame asm (+ 1 (length args)))
(emit-handle-interrupts asm)
(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))))
(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))
(maybe-emit-source src)
(let ((env (create-initial-env names syms free-vars)))
(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 (1+ (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 (kw-arg-ref args kw default)
(match (memq kw args)
((_ val . _) val)
(_ default)))
(define (compile-bytecode exp env opts)
(let* ((exp (canonicalize exp))
(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)))