983e8b6c00
procedures with large numbers of variables:
- added pass-time tracking for pre-cpnanopass passes to compile.
compile.ss
- added inline handler for fxdiv-and-mod
cp0.ss, primdata.ss
- changed order in which return-point operations are done (adjust
sfp first, then store return values, then restore local saves) to
avoid storing return values to homes beyond the end of the stack
in cases where adjusting sfp might result in a call to dooverflood.
cpnanopass.ss, np-languages.ss
- removed unused {make-,}asm-return-registers bindings
cpnanopass.ss
- corrected the max-fv value field of the lambda produced by the
hand-coded bytevector=? handler.
cpnanopass.ss
- reduced live-pointer and inspector free-variable mask computation
overhead
cpnanopass.ss
- moved regvec cset copies to driver so they aren't copied each
time a uvar is assigned to a register. removed checks for
missing register csets, since registers always have csets.
cpnanopass.ss
- added closure-rep else clause in record-inspector-information!.
cpnanopass.ss
- augmented tree representation with a constant representation
for full trees to reduce the overhead of manipulating trees or
subtress with all bits set.
cpnanopass.ss
- tree-for-each now takes start and end offsets; this cuts the
cost of traversing and applying the action when the range of
applicable offsets is other than 0..tree-size.
cpnanopass.ss
- introduced the notion of poison variables to reduce the cost of
register/frame allocation for procedures with large sets of local
variables. When the number of local variables exceeds a given
limit (currently hardwired to 1000), each variable with a large
live range is considered poison. A reasonable set of variables
with large live ranges (the set of poison variables) is computed
by successive approximation to avoid excessive overhead. Poison
variables directly conflict with all spillables, and all non-poison
spillables indirectly conflict with all poison spillables through
a shared poison-cset. Thus poison variables cannot live in the
same location as any other variable, i.e., they poison the location.
Conflicts between frame locations and poison variables are handled
normally, which allows poison variables to be assigned to
move-related frame homes. Poison variables are spilled prior to
register allocation, so conflicts between registers and poison
variables are not represented. move relations between poison
variables and frame variables are recorded as usual, but other
move relations involving poison variables are not recorded.
cpnanopass.ss, np-languages.ss
- changed the way a uvar's degree is decremented by remove-victim!.
instead of checking for a conflict between each pair of victim
and keeper and decrementing when the conflict is found, remove-victim!
now decrements the degree of each var in each victim's conflict
set. while this might decrement other victims' degrees unnecessarily,
it can be much less expensive when large numbers of variables are
involved, since the number of conflicts between two non-poison
variables should be small due to the selection process for
(non-)poison variables and the fact that the unspillables introduced
by instruction selection should also have few conflicts. That
is, it reduces the worst-case complexity of decrementing degrees
from O(n^2) to O(n).
cpnanopass.ss
- took advice in compute-degree! comment to increment the uvars in
each registers csets rather than looping over the registers for
each uvar asking whether the register conflicts with the uvar.
cpnanopass.ss
- assign-new-frame! now zeros out save-weight for local saves, since
once they are explicitly saved and restored, they are no longer
call-live and thus have no save cost.
cpnanopass.ss
- desensitized the let-values source-caching timing test slightly
8.ms
- updated allx, bullyx patches
patch*
original commit: 3a49d0193ae57b8e31ec6a00b5b49db31a52373f
1065 lines
36 KiB
Scheme
1065 lines
36 KiB
Scheme
;;; np-languages.ss
|
|
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
|
;;;
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
|
;;; you may not use this file except in compliance with the License.
|
|
;;; You may obtain a copy of the License at
|
|
;;;
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
|
;;;
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
;;; See the License for the specific language governing permissions and
|
|
;;; limitations under the License.
|
|
|
|
#!chezscheme
|
|
(module np-languages ()
|
|
(export sorry! var? var-index var-index-set! prelex->uvar make-tmp make-assigned-tmp
|
|
make-unspillable make-cpvar make-restricted-unspillable
|
|
uvar? uvar-name uvar-type uvar-source
|
|
uvar-referenced? uvar-referenced! uvar-assigned? uvar-assigned!
|
|
uvar-was-closure-ref? uvar-was-closure-ref!
|
|
uvar-unspillable? uvar-spilled? uvar-spilled! uvar-local-save? uvar-local-save!
|
|
uvar-seen? uvar-seen! uvar-loop? uvar-loop! uvar-poison? uvar-poison!
|
|
uvar-in-prefix? uvar-in-prefix!
|
|
uvar-location uvar-location-set!
|
|
uvar-move* uvar-move*-set!
|
|
uvar-conflict*
|
|
uvar-ref-weight uvar-ref-weight-set! uvar-save-weight uvar-save-weight-set!
|
|
uvar-live-count uvar-live-count-set!
|
|
uvar
|
|
fv-offset
|
|
var-spillable-conflict* var-spillable-conflict*-set!
|
|
var-unspillable-conflict* var-unspillable-conflict*-set!
|
|
uvar-degree uvar-degree-set!
|
|
uvar-info-lambda uvar-info-lambda-set!
|
|
uvar-iii uvar-iii-set!
|
|
ur?
|
|
block make-block block? block-label block-effect* block-src* block-pseudo-src block-in-link* block-flags
|
|
block-label-set! block-effect*-set! block-src*-set! block-pseudo-src-set! block-in-link*-set! block-flags-set!
|
|
block-live-in block-live-in-set! block-fp-offset block-fp-offset-set!
|
|
block-depth block-depth-set! block-loop-headers block-loop-headers-set!
|
|
block-weight block-weight-set!
|
|
block-index block-index-set!
|
|
block-pariah! block-seen! block-finished! block-return-point! block-repeater! block-loop-header!
|
|
block-pariah? block-seen? block-finished? block-return-point? block-repeater? block-loop-header?
|
|
L1 unparse-L1 L2 unparse-L2 L3 unparse-L3 L4 unparse-L4
|
|
L4.5 unparse-L4.5 L4.75 unparse-L4.75 L4.875 unparse-L4.875
|
|
L5 unparse-L5 L6 unparse-L6 L7 unparse-L7
|
|
L9 unparse-L9 L9.5 unparse-L9.5 L9.75 unparse-L9.75
|
|
L10 unparse-L10 L10.5 unparse-L10.5 L11 unparse-L11
|
|
L11.5 unparse-L11.5 L12 unparse-L12 L13 unparse-L13 L13.5 unparse-L13.5 L14 unparse-L14
|
|
L15a unparse-L15a L15b unparse-L15b L15c unparse-L15c L15d unparse-L15d
|
|
L15e unparse-L15e
|
|
L16 unparse-L16
|
|
info null-info
|
|
live-info make-live-info live-info-live live-info-live-set! live-info-useless live-info-useless-set!
|
|
primitive-pure? primitive-type primitive-handler primitive-handler-set!
|
|
%primitive value-primitive? pred-primitive? effect-primitive?
|
|
fv? $make-fv make-reg reg? reg-name reg-tc-disp reg-callee-save? reg-mdinfo
|
|
reg-precolored reg-precolored-set!
|
|
label? label-name
|
|
libspec-label? make-libspec-label libspec-label-libspec libspec-label-live-reg*
|
|
local-label? make-local-label
|
|
local-label-func local-label-func-set!
|
|
local-label-offset local-label-offset-set!
|
|
local-label-iteration local-label-iteration-set!
|
|
local-label-block local-label-block-set!
|
|
local-label-overflow-check local-label-overflow-check-set!
|
|
local-label-trap-check local-label-trap-check-set!
|
|
direct-call-label? make-direct-call-label
|
|
direct-call-label-referenced direct-call-label-referenced-set!
|
|
Lsrc Lsrc? Ltype Ltype? unparse-Ltype unparse-Lsrc
|
|
lookup-primref primref? primref-level primref-name primref-flags primref-arity
|
|
preinfo-src preinfo-sexpr preinfo-lambda-name preinfo-lambda-flags preinfo-lambda-libspec
|
|
prelex-name prelex-name-set!)
|
|
|
|
(import (nanopass))
|
|
(include "base-lang.ss")
|
|
|
|
; convention is a symbol or #f (we're assuming the front end already verified
|
|
; the convention is a valid one for this machine-type
|
|
(define convention? (lambda (x) (or (symbol? x) (eq? #f x))))
|
|
|
|
; r6rs says a quote subform should be a datum, not must be a datum
|
|
; chez scheme allows a quote subform to be any value
|
|
(define datum? (lambda (x) #t))
|
|
|
|
(define-record-type var
|
|
(fields (mutable index) (mutable spillable-conflict*) (mutable unspillable-conflict*))
|
|
(nongenerative)
|
|
(protocol (lambda (new) (lambda () (new #f #f #f)))))
|
|
|
|
(define-record-type (fv $make-fv fv?)
|
|
(parent var)
|
|
(fields offset)
|
|
(nongenerative)
|
|
(sealed #t)
|
|
(protocol
|
|
(lambda (pargs->new)
|
|
(lambda (offset)
|
|
((pargs->new) offset)))))
|
|
|
|
(module ()
|
|
(record-writer (record-type-descriptor fv)
|
|
(lambda (x p wr)
|
|
(fprintf p "fv~s" (fv-offset x)))))
|
|
|
|
(define-record-type reg
|
|
(parent var)
|
|
(fields name mdinfo tc-disp callee-save? (mutable precolored))
|
|
(nongenerative)
|
|
(sealed #t)
|
|
(protocol
|
|
(lambda (pargs->new)
|
|
(lambda (name mdinfo tc-disp callee-save?)
|
|
((pargs->new) name mdinfo tc-disp callee-save? #f)))))
|
|
|
|
(module ()
|
|
(record-writer (record-type-descriptor reg)
|
|
(lambda (x p wr)
|
|
(write (reg-name x) p))))
|
|
|
|
(define-syntax define-flag-field
|
|
(lambda (exp)
|
|
(syntax-case exp ()
|
|
((_k type-name field (flag mask) ...)
|
|
(let ()
|
|
(define getter-name
|
|
(lambda (f)
|
|
(construct-name #'_k #'type-name "-" f "?")))
|
|
(define setter-name
|
|
(lambda (f)
|
|
(construct-name #'_k #'type-name "-" f "!")))
|
|
(with-syntax ([field-ref (construct-name #'_k #'type-name "-" #'field)]
|
|
[field-set! (construct-name #'_k #'type-name "-" #'field "-set!")]
|
|
[(flag-ref ...) (map getter-name #'(flag ...))]
|
|
[(flag-set! ...) (map setter-name #'(flag ...))]
|
|
[f->m (construct-name #'_k #'type-name "-" #'field "-mask")])
|
|
#'(begin
|
|
(define-flags f->m (flag mask) ...)
|
|
(define flag-ref
|
|
(lambda (x)
|
|
(any-set? (f->m flag) (field-ref x))))
|
|
...
|
|
(define flag-set!
|
|
(lambda (x bool)
|
|
(field-set! x
|
|
(let ([flags (field-ref x)])
|
|
(if bool
|
|
(set-flags (f->m flag) flags)
|
|
(reset-flags (f->m flag) flags))))))
|
|
...)))))))
|
|
|
|
(define-flag-field uvar flags
|
|
(referenced #b00000000001)
|
|
(assigned #b00000000010)
|
|
(unspillable #b00000000100)
|
|
(spilled #b00000001000)
|
|
(seen #b00000010000)
|
|
(was-closure-ref #b00000100000)
|
|
(loop #b00001000000)
|
|
(in-prefix #b00010000000)
|
|
(local-save #b00100000000)
|
|
(poison #b01000000000)
|
|
)
|
|
|
|
(define-record-type (uvar $make-uvar uvar?)
|
|
(parent var)
|
|
(fields
|
|
name
|
|
source
|
|
type
|
|
conflict*
|
|
(mutable flags)
|
|
(mutable info-lambda)
|
|
(mutable location)
|
|
(mutable move*)
|
|
(mutable degree)
|
|
(mutable iii) ; inspector info index
|
|
(mutable ref-weight) ; must be a fixnum!
|
|
(mutable save-weight) ; must be a fixnum!
|
|
(mutable live-count) ; must be a fixnum!
|
|
)
|
|
(nongenerative)
|
|
(sealed #t)
|
|
(protocol
|
|
(lambda (pargs->new)
|
|
(lambda (name source type conflict* flags)
|
|
((pargs->new) name source type conflict* flags #f #f '() #f #f 0 0 0)))))
|
|
(define prelex->uvar
|
|
(lambda (x)
|
|
($make-uvar (prelex-name x) (prelex-source x) 'ptr '()
|
|
(if (prelex-referenced x)
|
|
(if (prelex-assigned x)
|
|
(uvar-flags-mask referenced assigned)
|
|
(uvar-flags-mask referenced))
|
|
(if (prelex-assigned x)
|
|
(uvar-flags-mask assigned)
|
|
(uvar-flags-mask))))))
|
|
(define make-tmp
|
|
(case-lambda
|
|
[(name) (make-tmp name 'ptr)]
|
|
[(name type) ($make-uvar name #f type '() (uvar-flags-mask referenced))]))
|
|
(define make-assigned-tmp
|
|
(case-lambda
|
|
[(name) (make-assigned-tmp name 'ptr)]
|
|
[(name type) ($make-uvar name #f type '() (uvar-flags-mask referenced assigned))]))
|
|
(define make-unspillable
|
|
(lambda (name)
|
|
($make-uvar name #f 'ptr '() (uvar-flags-mask referenced unspillable))))
|
|
(define make-cpvar
|
|
(lambda ()
|
|
(include "types.ss")
|
|
;; NB: cpsymbol is not a source object. Why is it put into the uvar-source field?
|
|
($make-uvar 'cp cpsymbol 'ptr '() (uvar-flags-mask referenced))))
|
|
(define make-restricted-unspillable
|
|
(lambda (name conflict*)
|
|
($make-uvar name #f 'uptr conflict* (uvar-flags-mask referenced assigned unspillable))))
|
|
|
|
(module ()
|
|
(record-writer (record-type-descriptor uvar)
|
|
(lambda (x p wr)
|
|
(write (lookup-unique-uvar x) p))))
|
|
|
|
(define lookup-unique-uvar
|
|
(let ([ht (make-eq-hashtable)])
|
|
(lambda (x)
|
|
(or (eq-hashtable-ref ht x #f)
|
|
(let ([sym (gensym (symbol->string (uvar-name x)))])
|
|
(eq-hashtable-set! ht x sym)
|
|
sym)))))
|
|
|
|
(define-record-type info (nongenerative))
|
|
|
|
(define null-info (make-info))
|
|
|
|
(module ()
|
|
(record-writer (record-type-descriptor info)
|
|
(lambda (x p wr)
|
|
(fprintf p "#<info>"))))
|
|
|
|
(define-record-type label
|
|
(nongenerative)
|
|
(fields name))
|
|
|
|
(define-record-type libspec-label
|
|
(parent label)
|
|
(nongenerative)
|
|
(sealed #t)
|
|
(fields libspec live-reg*)
|
|
(protocol
|
|
(lambda (pargs->new)
|
|
(lambda (name libspec live-reg*)
|
|
((pargs->new name) libspec live-reg*)))))
|
|
|
|
; TODO: need better abstraction for reusing record fields for
|
|
; different purposes in different passes.
|
|
(define-record-type local-label
|
|
(parent label)
|
|
(nongenerative)
|
|
(fields (mutable func) (mutable offset) (mutable iteration) (mutable block)
|
|
; following used by place-overflow-and-trap-check pass
|
|
(mutable overflow-check) (mutable trap-check))
|
|
(protocol
|
|
(lambda (pargs->new)
|
|
(lambda (name)
|
|
((pargs->new name) #f #f #f #f 'no 'no)))))
|
|
|
|
(define-record-type direct-call-label
|
|
(parent local-label)
|
|
(nongenerative)
|
|
(sealed #t)
|
|
(fields (mutable referenced))
|
|
(protocol
|
|
(lambda (pargs->new)
|
|
(lambda (name)
|
|
((pargs->new name) #f)))))
|
|
|
|
(module ()
|
|
(define lookup-unique-label
|
|
(let ([ht (make-eq-hashtable)])
|
|
(lambda (x)
|
|
(or (eq-hashtable-ref ht x #f)
|
|
(let ([sym (gensym (symbol->string (label-name x)))])
|
|
(eq-hashtable-set! ht x sym)
|
|
sym)))))
|
|
(record-writer (record-type-descriptor local-label)
|
|
(lambda (x p wr)
|
|
(write (lookup-unique-label x) p)))
|
|
(record-writer (record-type-descriptor libspec-label)
|
|
(lambda (x p wr)
|
|
(write (label-name x) p))))
|
|
|
|
(define maybe-var?
|
|
(lambda (x)
|
|
(or (eq? x #f) (var? x))))
|
|
|
|
(define maybe-label?
|
|
(lambda (x)
|
|
(or (eq? x #f) (label? x))))
|
|
|
|
; language to replace prelex with uvar, create info records out of some of the complex
|
|
; records, and make sure other record types have been discarded. also formally sets up
|
|
; CaseLambdaClause as entry point for language.
|
|
(define-language L1
|
|
(terminals
|
|
(uvar (x))
|
|
(datum (d))
|
|
(source-object (src))
|
|
(info (info))
|
|
(fixnum (interface))
|
|
(primref (pr))
|
|
)
|
|
(entry CaseLambdaExpr)
|
|
(Expr (e body)
|
|
le
|
|
x
|
|
pr
|
|
(quote d)
|
|
(call info e0 e1 ...) => (e0 e1 ...)
|
|
(if e0 e1 e2)
|
|
(seq e0 e1)
|
|
(set! x e)
|
|
(letrec ([x le] ...) body)
|
|
(moi) => "moi"
|
|
(foreign info e)
|
|
(fcallable info e)
|
|
(profile src) => (profile)
|
|
(pariah)
|
|
)
|
|
(CaseLambdaExpr (le)
|
|
(case-lambda info cl ...) => (case-lambda cl ...)
|
|
)
|
|
(CaseLambdaClause (cl)
|
|
(clause (x* ...) interface body)
|
|
))
|
|
|
|
; from this point on, if a uvar x is bound to a lambda expression le by letrec,
|
|
; (uvar-info-lambda x) must be equal to le's info-lambda
|
|
|
|
; introducing let
|
|
(define-language L2 (extends L1)
|
|
(entry CaseLambdaExpr)
|
|
(Expr (e body)
|
|
(+ (let ([x e] ...) body))))
|
|
|
|
; removes moi; also adds name to info-lambda & info-foreign
|
|
(define-language L3 (extends L2)
|
|
(entry CaseLambdaExpr)
|
|
(Expr (e body)
|
|
(- (moi))))
|
|
|
|
; removes assignable indefinite-extent variables from the language
|
|
(define-language L4 (extends L3)
|
|
(entry CaseLambdaExpr)
|
|
(Expr (e body)
|
|
(- (set! x e))))
|
|
|
|
; introducing mvlet, and mvcall
|
|
(define-language L4.5 (extends L4)
|
|
(terminals
|
|
(+ (label (l))
|
|
(maybe-label (mdcl))
|
|
(immediate (imm))))
|
|
(entry CaseLambdaExpr)
|
|
(Expr (e body)
|
|
(- (call info e0 e1 ...))
|
|
(+ (call info mdcl e0 e1 ...) => (call mdcl e0 e1 ...)
|
|
(mvcall info e1 e2) => (mvcall e1 e2)
|
|
(mvlet e ((x** ...) interface* body*) ...))))
|
|
|
|
; removes foreign, adds foreign-call, updates fcallable
|
|
(define-language L4.75 (extends L4.5)
|
|
(entry CaseLambdaExpr)
|
|
(Expr (e body)
|
|
(- (foreign info e)
|
|
(fcallable info e))
|
|
(+ (label l body)
|
|
(foreign-call info e e* ...)
|
|
(fcallable info))))
|
|
|
|
; adds loop form
|
|
(define-language L4.875 (extends L4.75)
|
|
(entry CaseLambdaExpr)
|
|
(Expr (e body)
|
|
(+ (loop x (x* ...) body) => (loop x body))))
|
|
|
|
; moves all case lambda expressions into rhs of letrec
|
|
(define-language L5 (extends L4.875)
|
|
(entry CaseLambdaExpr)
|
|
(Expr (e body)
|
|
(- le)))
|
|
|
|
; replaces letrec with labels and closures forms
|
|
(define-language L6 (extends L5)
|
|
(terminals
|
|
(+ (maybe-var (mcp))))
|
|
(entry CaseLambdaExpr)
|
|
(Expr (e body)
|
|
(- (letrec ([x le] ...) body))
|
|
(+ (closures ([x* (x** ...) le*] ...) body)))
|
|
(CaseLambdaClause (cl)
|
|
(- (clause (x* ...) interface body))
|
|
(+ (clause (x* ...) mcp interface body))))
|
|
|
|
; move labels to top level and expands closures forms to more primitive operations
|
|
(define-language L7 (extends L6)
|
|
(terminals
|
|
(- (uvar (x))
|
|
(fixnum (interface)))
|
|
(+ (var (x))
|
|
(primitive (prim)) ; moved up one language to support closure instrumentation
|
|
(fixnum (interface offset))))
|
|
(entry Program)
|
|
(Program (prog)
|
|
(+ (labels ([l* le*] ...) l) => (labels ([l* le*] ...) (l))))
|
|
(CaseLambdaExpr (le)
|
|
(+ (fcallable info) => (fcallable info)))
|
|
(Lvalue (lvalue)
|
|
(+ x
|
|
(mref e1 e2 imm)))
|
|
(Expr (e body)
|
|
(- x
|
|
(fcallable info)
|
|
(closures ([x* (x** ...) le*] ...) body)
|
|
(call info mdcl e0 e1 ...))
|
|
(+ lvalue
|
|
(alloc info e) => (alloc info e)
|
|
(literal info) => info
|
|
(label-ref l offset)
|
|
(immediate imm) => imm
|
|
; moved up one language to support closure instrumentation
|
|
(inline info prim e* ...) => (inline info prim e* ...)
|
|
(call info mdcl (maybe e0) e1 ...) => (call mdcl e0 e1 ...)
|
|
(set! lvalue e)
|
|
; these two forms are added here so expand-inline handlers can expand into them
|
|
(values info e* ...)
|
|
(goto l))))
|
|
|
|
(define-record-type primitive
|
|
(fields name type pure? (mutable handler))
|
|
(nongenerative)
|
|
(sealed #t)
|
|
(protocol
|
|
(lambda (new)
|
|
(lambda (name type pure?)
|
|
(new name type pure? (lambda args (sorry! name "no primitive handler defined")))))))
|
|
|
|
(module ()
|
|
(record-writer (record-type-descriptor primitive)
|
|
(lambda (x p wr)
|
|
(fprintf p "~s" (primitive-name x)))))
|
|
|
|
(define value-primitive?
|
|
(lambda (x)
|
|
(and (primitive? x)
|
|
(eq? (primitive-type x) 'value))))
|
|
|
|
(define pred-primitive?
|
|
(lambda (x)
|
|
(and (primitive? x)
|
|
(eq? (primitive-type x) 'pred))))
|
|
|
|
(define effect-primitive?
|
|
(lambda (x)
|
|
(and (primitive? x)
|
|
(eq? (primitive-type x) 'effect))))
|
|
|
|
(define-syntax declare-primitive
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ name type pure?)
|
|
(with-syntax ([%name (construct-name #'name "%" #'name)])
|
|
#'(begin
|
|
(define %name (make-primitive 'name 'type pure?))
|
|
(export %name)))])))
|
|
|
|
(define-syntax %primitive
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ name)
|
|
(let ([a (syntax->annotation #'name)]
|
|
[sym (string->symbol (format "%~a" (datum name)))])
|
|
(datum->syntax #'name
|
|
(if a (make-annotation sym (annotation-source a) sym) sym)))])))
|
|
|
|
(declare-primitive asmlibcall! effect #f)
|
|
(declare-primitive c-call effect #f)
|
|
(declare-primitive c-simple-call effect #f)
|
|
(declare-primitive fl* effect #f)
|
|
(declare-primitive fl+ effect #f)
|
|
(declare-primitive fl- effect #f)
|
|
(declare-primitive fl/ effect #f)
|
|
(declare-primitive flsqrt effect #f) ; not implemented for some ppc32 (so we don't use it)
|
|
(declare-primitive flt effect #f)
|
|
(declare-primitive inc-cc-counter effect #f)
|
|
(declare-primitive inc-profile-counter effect #f)
|
|
(declare-primitive invoke-prelude effect #f)
|
|
(declare-primitive keep-live effect #f)
|
|
(declare-primitive load-double effect #f)
|
|
(declare-primitive load-double->single effect #f)
|
|
(declare-primitive load-single effect #f)
|
|
(declare-primitive load-single->double effect #f)
|
|
(declare-primitive locked-decr! effect #f)
|
|
(declare-primitive locked-incr! effect #f)
|
|
(declare-primitive pause effect #f)
|
|
(declare-primitive push effect #f)
|
|
(declare-primitive pop-multiple effect #f) ; arm
|
|
(declare-primitive push-multiple effect #f) ; arm
|
|
(declare-primitive remember effect #f)
|
|
(declare-primitive restore-flrv effect #f)
|
|
(declare-primitive restore-lr effect #f) ; ppc
|
|
(declare-primitive save-flrv effect #f)
|
|
(declare-primitive save-lr effect #f) ; ppc
|
|
(declare-primitive store effect #f)
|
|
(declare-primitive store-double effect #f)
|
|
(declare-primitive store-single effect #f)
|
|
(declare-primitive store-single->double effect #f)
|
|
(declare-primitive store-with-update effect #f) ; ppc
|
|
(declare-primitive vpush-multiple effect #f) ; arm
|
|
|
|
(declare-primitive < pred #t)
|
|
(declare-primitive <= pred #t)
|
|
(declare-primitive > pred #t)
|
|
(declare-primitive >= pred #t)
|
|
(declare-primitive condition-code pred #t)
|
|
(declare-primitive eq? pred #t)
|
|
(declare-primitive fl< pred #t)
|
|
(declare-primitive fl<= pred #t)
|
|
(declare-primitive fl= pred #t)
|
|
(declare-primitive lock! pred #f)
|
|
(declare-primitive logtest pred #t)
|
|
(declare-primitive log!test pred #t)
|
|
(declare-primitive type-check? pred #t)
|
|
(declare-primitive u< pred #t)
|
|
|
|
(declare-primitive - value #t)
|
|
(declare-primitive / value #t)
|
|
(declare-primitive + value #t)
|
|
(declare-primitive +/ovfl value #f)
|
|
(declare-primitive +/carry value #f)
|
|
(declare-primitive -/ovfl value #f)
|
|
(declare-primitive -/eq value #f)
|
|
(declare-primitive asmlibcall value #f)
|
|
(declare-primitive fstpl value #f) ; x86 only
|
|
(declare-primitive get-double value #t) ; x86_64
|
|
(declare-primitive get-tc value #f) ; threaded version only
|
|
(declare-primitive lea1 value #t)
|
|
(declare-primitive lea2 value #t)
|
|
(declare-primitive load value #t)
|
|
(declare-primitive logand value #t)
|
|
(declare-primitive logor value #t)
|
|
(declare-primitive logxor value #t)
|
|
(declare-primitive lognot value #t)
|
|
(declare-primitive move value #t)
|
|
(declare-primitive * value #t)
|
|
(declare-primitive */ovfl value #f)
|
|
(declare-primitive pop value #f)
|
|
(declare-primitive read-performance-monitoring-counter value #t) ; on x86/x86_64 actually side-effects edx/rdx
|
|
(declare-primitive read-time-stamp-counter value #t) ; on x86/x86_64 actually side-effects edx/rdx
|
|
(declare-primitive sext8 value #t)
|
|
(declare-primitive sext16 value #t)
|
|
(declare-primitive sext32 value #t) ; 64-bit only
|
|
(declare-primitive sll value #t)
|
|
(declare-primitive srl value #t)
|
|
(declare-primitive sra value #t)
|
|
(declare-primitive trunc value #t)
|
|
(declare-primitive zext8 value #t)
|
|
(declare-primitive zext16 value #t)
|
|
(declare-primitive zext32 value #t) ; 64-bit only
|
|
|
|
(define immediate?
|
|
(let ([low (- (bitwise-arithmetic-shift-left 1 (fx- (constant ptr-bits) 1)))]
|
|
[high (- (bitwise-arithmetic-shift-left 1 (constant ptr-bits)) 1)])
|
|
(if (and (eqv? (constant most-negative-fixnum) (most-negative-fixnum))
|
|
(eqv? (constant most-positive-fixnum) (most-positive-fixnum)))
|
|
(lambda (x) (or (fixnum? x) (and (bignum? x) (<= low x high))))
|
|
(lambda (x) (and (or (fixnum? x) (bignum? x)) (<= low x high))))))
|
|
|
|
(define imm->ptr
|
|
(lambda (x)
|
|
(cond
|
|
[(= x (constant sfalse)) #f]
|
|
[(= x (constant strue)) #t]
|
|
[(= x (constant svoid)) (void)]
|
|
[(= x (constant snil)) '()]
|
|
[(= x (constant seof)) #!eof]
|
|
[(= x (constant sunbound)) ($unbound-object)]
|
|
[(= x (constant sbwp)) #!bwp]
|
|
[(= (logand x (constant mask-fixnum)) (constant type-fixnum))
|
|
(ash (- x (constant type-fixnum)) (- (constant fixnum-offset)))]
|
|
[(= (logand x (constant mask-char)) (constant type-char))
|
|
(integer->char (/ (- x (constant type-char)) (constant char-factor)))]
|
|
[else ($oops 'cpnanopass-internal "imm->ptr got unrecognized immediate: ~s" x)])))
|
|
|
|
; specifies the representation for simple scheme constants: #t, #f, (void),
|
|
; '(), (eof-object), ($unbound-object), #!bwp, characters, and fixnums as
|
|
; scheme-object ptrs and inlines primitive calls
|
|
(define-language L9 (extends L7)
|
|
(entry Program)
|
|
(terminals
|
|
(- (datum (d))
|
|
(primref (pr)))
|
|
(+ (symbol (sym))))
|
|
(CaseLambdaExpr (le)
|
|
(+ (hand-coded sym)))
|
|
(Expr (e body)
|
|
(- (quote d)
|
|
pr)))
|
|
|
|
; determine where we should be placing interrupt and overflow
|
|
(define-language L9.5 (extends L9)
|
|
(entry Program)
|
|
(terminals
|
|
(+ (boolean (ioc))))
|
|
(Expr (e body)
|
|
(+ (trap-check ioc e)
|
|
(overflow-check e))))
|
|
|
|
; remove the loop form
|
|
(define-language L9.75 (extends L9.5)
|
|
(entry Program)
|
|
(Expr (e body)
|
|
(- (loop x (x* ...) body))))
|
|
|
|
; bindings are replaced with combination of a locals form and a series of set!
|
|
; expressions; value is broken into three categories: Triv, Rhs, and Expr. Triv
|
|
; expressions can appear as arguments to call and inline, or in any Rhs or Tail
|
|
; location, and are considered simple enough for the instruction selector to handle.
|
|
; Rhs expressions can appear on the right-hand-side of a set! or anywhere arbitrary
|
|
; Exprs can appear. Exprs appear in the body of a case-lambda clause.
|
|
(define-language L10 (extends L9.75)
|
|
(terminals
|
|
(+ (uvar (local))))
|
|
(entry Program)
|
|
(CaseLambdaClause (cl)
|
|
(- (clause (x* ...) mcp interface body))
|
|
(+ (clause (x* ...) (local* ...) mcp interface body)))
|
|
(Lvalue (lvalue)
|
|
(- (mref e1 e2 imm))
|
|
(+ (mref x1 x2 imm)))
|
|
(Triv (t)
|
|
(+ lvalue
|
|
(literal info) => info
|
|
(immediate imm) => (quote imm)
|
|
(label-ref l offset)))
|
|
(Rhs (rhs)
|
|
(+ t
|
|
(call info mdcl (maybe t0) t1 ...) => (call mdcl t0 t1 ...)
|
|
(alloc info t) => (alloc info t)
|
|
(inline info prim t* ...) => (inline info prim t* ...)
|
|
(mvcall info e t) => (mvcall e t)
|
|
(foreign-call info t t* ...)))
|
|
(Expr (e body)
|
|
(- lvalue
|
|
(values info e* ...)
|
|
(literal info)
|
|
(immediate imm)
|
|
(label-ref l offset)
|
|
(call info mdcl (maybe e0) e1 ...)
|
|
(inline info prim e* ...)
|
|
(alloc info e)
|
|
(let ([x e] ...) body)
|
|
(set! lvalue e)
|
|
(mvcall info e1 e2)
|
|
(foreign-call info e e* ...))
|
|
(+ rhs
|
|
(values info t* ...)
|
|
(set! lvalue rhs))))
|
|
|
|
(define-language L10.5 (extends L10)
|
|
(entry Program)
|
|
(Rhs (rhs)
|
|
(- (call info mdcl (maybe t0) t1 ...)
|
|
(mvcall info e t))
|
|
(+ (mvcall info mdcl (maybe t0) t1 ... (t* ...)) => (mvcall mdcl t0 t1 ... (t* ...))))
|
|
(Expr (e body)
|
|
(- (mvlet e ((x** ...) interface* body*) ...))
|
|
(+ (mvset info (mdcl (maybe t0) t1 ...) (t* ...) ((x** ...) interface* l*) ...) =>
|
|
(mvset (mdcl t0 t1 ...) (t* ...) ((x** ...) interface* l*) ...)
|
|
(mlabel e (l* e*) ...))))
|
|
|
|
; expressions are normalized into Tail, Pred, or Effect context; primrefs
|
|
; are converted into inline expressions; make-closure,
|
|
; closure-ref, and closure-set! are converted into inline calls; numbers and
|
|
; labels used as arguments to make-closure, closure-ref, and closure-set! are
|
|
; marked as literals so they will not be turned into scheme constants again.
|
|
(define-language L11 (extends L10.5)
|
|
(terminals
|
|
(- (primitive (prim)))
|
|
(+ (value-primitive (value-prim))
|
|
(pred-primitive (pred-prim))
|
|
(effect-primitive (effect-prim))))
|
|
(entry Program)
|
|
(CaseLambdaClause (cl)
|
|
(- (clause (x* ...) (local* ...) mcp interface body))
|
|
(+ (clause (x* ...) (local* ...) mcp interface tlbody)))
|
|
(Rhs (rhs)
|
|
(- (inline info prim t* ...))
|
|
(+ (inline info value-prim t* ...) => (inline info value-prim t* ...)))
|
|
(Expr (e body)
|
|
(- rhs
|
|
(label l body)
|
|
(set! lvalue rhs)
|
|
(if e0 e1 e2)
|
|
(seq e0 e1)
|
|
(mvset info (mdcl (maybe t0) t1 ...) (t* ...) ((x** ...) interface* l*) ...)
|
|
(values info t* ...)
|
|
(goto l)
|
|
(mlabel e (l* e*) ...)
|
|
(pariah)
|
|
(trap-check ioc e)
|
|
(overflow-check e)
|
|
(profile src)))
|
|
(Tail (tl tlbody)
|
|
(+ rhs
|
|
(if p0 tl1 tl2)
|
|
(seq e0 tl1)
|
|
(values info t* ...) => (values t* ...)
|
|
(goto l)))
|
|
(Pred (p pbody)
|
|
(+ (true) => #t
|
|
(false) => #f
|
|
(inline info pred-prim t* ...) => (inline info pred-prim t* ...)
|
|
(if p0 p1 p2)
|
|
(seq e0 p1)
|
|
(goto l)
|
|
(mlabel p (l* p*) ...)))
|
|
(Effect (e ebody)
|
|
(+ (nop)
|
|
(label l)
|
|
(goto l)
|
|
(pariah)
|
|
(trap-check ioc)
|
|
(overflow-check)
|
|
(profile src) => (profile)
|
|
(set! lvalue rhs)
|
|
(inline info effect-prim t* ...) => (inline info effect-prim t* ...)
|
|
(if p0 e1 e2)
|
|
(seq e0 e1)
|
|
(mvset info (mdcl (maybe t0) t1 ...) (t* ...) ((x** ...) interface* l*) ...) =>
|
|
(mvset (mdcl t0 t1 ...) (t* ...) ((x** ...) interface* l*) ...)
|
|
(mvcall info mdcl (maybe t0) t1 ... (t* ...)) => (mvcall mdcl t0 t1 ... (t* ...))
|
|
(foreign-call info t t* ...)
|
|
(tail tl))))
|
|
|
|
(define-language L11.5 (extends L11)
|
|
(entry Program)
|
|
(terminals
|
|
(- (boolean (ioc))))
|
|
(Effect (e body)
|
|
(- (trap-check ioc))))
|
|
|
|
(define-language L12 (extends L11.5)
|
|
(terminals
|
|
(- (fixnum (interface offset))
|
|
(label (l)))
|
|
(+ (fixnum (fixed-args offset))
|
|
(label (l dcl))))
|
|
(entry Program)
|
|
(CaseLambdaExpr (le)
|
|
(- (case-lambda info cl ...))
|
|
(+ (lambda info (local* ...) tlbody) => (lambda (local* ...) tlbody)))
|
|
(CaseLambdaClause (cl)
|
|
(- (clause (x* ...) (local* ...) mcp interface tlbody)))
|
|
(Tail (tl tlbody)
|
|
(+ (entry-point (x* ...) dcl mcp tlbody)))
|
|
(Effect (e ebody)
|
|
(- (mvset info (mdcl (maybe t0) t1 ...) (t* ...) ((x** ...) interface* l*) ...))
|
|
(+ (do-rest fixed-args)
|
|
(mvset info (mdcl (maybe t0) t1 ...) (t* ...) ((x** ...) ...) ebody)
|
|
; mventry-point can appear only within an mvset ebody
|
|
; ideally, grammar would reflect this
|
|
(mventry-point (x* ...) l))))
|
|
|
|
(define exact-integer?
|
|
(lambda (x)
|
|
(and (integer? x) (exact? x))))
|
|
|
|
; calling conventions are imposed; clauses no longer have formals (they are
|
|
; now locals set by arguments from argument registers and frame); calls no
|
|
; longer have arguments; case-lambda is resposible for dispatching to correct
|
|
; clause, even when the game is being played
|
|
(define-language L13
|
|
(terminals
|
|
(fixnum (max-fv offset))
|
|
(fv (fv))
|
|
(reg (reg))
|
|
(var (x nfv cnfv var))
|
|
(uvar (local))
|
|
(effect-primitive (effect-prim))
|
|
(pred-primitive (pred-prim))
|
|
(value-primitive (value-prim))
|
|
(immediate (imm fs))
|
|
(exact-integer (lpm))
|
|
(info (info))
|
|
(maybe-label (mrvl))
|
|
(label (l rpl))
|
|
(source-object (src))
|
|
(symbol (sym)))
|
|
(Program (prog)
|
|
(labels ([l* le*] ...) l) => (letrec ([l* le*] ...) (l)))
|
|
(CaseLambdaExpr (le)
|
|
(lambda info max-fv (local* ...) tlbody) => (lambda (local* ...) tlbody)
|
|
(hand-coded sym))
|
|
(Lvalue (lvalue)
|
|
x
|
|
(mref x1 x2 imm))
|
|
(Triv (t)
|
|
lvalue
|
|
(literal info) => info
|
|
(immediate imm) => imm
|
|
(label-ref l offset))
|
|
(Rhs (rhs)
|
|
t
|
|
(alloc info t) => (alloc info t)
|
|
(inline info value-prim t* ...) => (inline info value-prim t* ...))
|
|
(Pred (p pbody)
|
|
(inline info pred-prim t* ...) => (inline info pred-prim t* ...)
|
|
(true)
|
|
(false)
|
|
(if p0 p1 p2)
|
|
(seq e0 p1)
|
|
(goto l)
|
|
(mlabel p (l* p*) ...))
|
|
(Effect (e ebody)
|
|
(overflow-check)
|
|
(overflood-check)
|
|
(fcallable-overflow-check)
|
|
(new-frame info rpl* ... rpl)
|
|
(return-point info rpl mrvl (cnfv* ...))
|
|
(rp-header mrvl fs lpm)
|
|
(remove-frame info)
|
|
(restore-local-saves info)
|
|
(shift-arg reg imm info)
|
|
(set! lvalue rhs)
|
|
(inline info effect-prim t* ...) => (inline info effect-prim t* ...)
|
|
(nop)
|
|
(pariah)
|
|
(if p0 e1 e2)
|
|
(seq e0 e1)
|
|
(label l)
|
|
(goto l)
|
|
(tail tl)
|
|
(profile src) => (profile)
|
|
(check-live reg* ...))
|
|
(Tail (tl tlbody)
|
|
(jump t (var* ...))
|
|
(joto l (nfv* ...))
|
|
(asm-return reg* ...)
|
|
(if p0 tl1 tl2)
|
|
(seq e0 tl1)
|
|
(goto l)))
|
|
|
|
(define-language L13.5 (extends L13)
|
|
(terminals
|
|
(- (symbol (sym))))
|
|
(entry Program)
|
|
(CaseLambdaExpr (le)
|
|
(- (hand-coded sym))))
|
|
|
|
(define-language L14 (extends L13.5)
|
|
(entry Program)
|
|
(Rhs (rhs)
|
|
(- (alloc info t))))
|
|
|
|
(define-record-type block
|
|
(fields
|
|
(mutable label)
|
|
(mutable effect*)
|
|
(mutable src*)
|
|
(mutable pseudo-src)
|
|
(mutable in-link*)
|
|
(mutable flags)
|
|
(mutable fp-offset)
|
|
(mutable live-in)
|
|
(mutable depth)
|
|
(mutable loop-headers)
|
|
(mutable index)
|
|
(mutable weight))
|
|
(nongenerative)
|
|
(protocol
|
|
(lambda (new)
|
|
(lambda ()
|
|
(new #f '() '() #f '() (block-flags-mask) #f 'uninitialized 0 #f #f #f)))))
|
|
|
|
(define-flag-field block flags
|
|
(pariah #b000001)
|
|
(seen #b000010)
|
|
(finished #b000100)
|
|
(return-point #b001000)
|
|
(repeater #b010000)
|
|
(loop-header #b100000))
|
|
|
|
(define-record-type live-info
|
|
(nongenerative)
|
|
(sealed #t)
|
|
(fields
|
|
(mutable live)
|
|
(mutable useless))
|
|
(protocol
|
|
(lambda (new)
|
|
(case-lambda
|
|
[() (new 'uninitialized #f)]
|
|
[(live) (new live #f)]))))
|
|
|
|
(module ()
|
|
(record-writer (record-type-descriptor live-info)
|
|
(lambda (x p wr)
|
|
(if (eq? (live-info-live x) 'uninitialized)
|
|
(display-string "#<live-info>" p)
|
|
(fprintf p "#<live-info ~s>" (live-info-live x))))))
|
|
|
|
(define-language L15a
|
|
(terminals
|
|
(var (x cnfv var))
|
|
(reg (reg))
|
|
(uvar (local))
|
|
(effect-primitive (effect-prim))
|
|
(pred-primitive (pred-prim))
|
|
(value-primitive (value-prim))
|
|
(immediate (imm fs))
|
|
(exact-integer (lpm))
|
|
(live-info (live-info))
|
|
(info (info))
|
|
(label (l rpl))
|
|
(maybe-label (mrvl))
|
|
(fixnum (max-fv offset))
|
|
(block (block entry-block)))
|
|
(Program (pgm)
|
|
(labels ([l* le*] ...) l) => (letrec ([l* le*] ...) (l)))
|
|
(CaseLambdaExpr (le)
|
|
(lambda info max-fv (local* ...) (entry-block* ...) (block* ...)) => (lambda (local* ...) (entry-block* ...) (block* ...)))
|
|
(Dummy (dumdum) (dummy))
|
|
(Lvalue (lvalue)
|
|
x
|
|
(mref x1 x2 imm))
|
|
(Triv (t)
|
|
lvalue
|
|
(literal info) => info
|
|
(immediate imm) => imm
|
|
(label-ref l offset))
|
|
(Rhs (rhs)
|
|
t
|
|
(inline info value-prim t* ...))
|
|
(Pred (p)
|
|
(inline live-info info pred-prim t* ...))
|
|
(Effect (e)
|
|
(overflow-check live-info)
|
|
(overflood-check live-info)
|
|
(fcallable-overflow-check live-info)
|
|
(return-point info rpl mrvl (cnfv* ...))
|
|
(rp-header mrvl fs lpm)
|
|
(remove-frame live-info info)
|
|
(restore-local-saves live-info info)
|
|
(shift-arg live-info reg imm info)
|
|
(set! live-info lvalue rhs)
|
|
(inline live-info info effect-prim t* ...)
|
|
(check-live live-info reg* ...))
|
|
(Tail (tl)
|
|
(goto l)
|
|
(jump live-info t (var* ...))
|
|
(asm-return reg* ...)))
|
|
|
|
(define-language L15b (extends L15a)
|
|
(terminals
|
|
(- (var (x cnfv var))
|
|
(reg (reg))
|
|
(label (l rpl)))
|
|
(+ (var (x var))
|
|
(label (l))))
|
|
(Effect (e)
|
|
(- (remove-frame live-info info)
|
|
(restore-local-saves live-info info)
|
|
(return-point info rpl mrvl (cnfv* ...))
|
|
(shift-arg live-info reg imm info)
|
|
(check-live live-info reg* ...))
|
|
(+ (fp-offset live-info imm)))
|
|
(Tail (tl)
|
|
(- (jump live-info t (var* ...))
|
|
(asm-return reg* ...))
|
|
(+ (jump live-info t)
|
|
(asm-return))))
|
|
|
|
(define ur?
|
|
(lambda (x)
|
|
(or (reg? x) (uvar? x))))
|
|
|
|
(define-language L15c (extends L15b)
|
|
(terminals
|
|
(- (var (x var)))
|
|
(+ (ur (x))))
|
|
; NB: base and index are really either regs or (mref %sfp %zero imm)
|
|
(Lvalue (lvalue)
|
|
(- (mref x1 x2 imm))
|
|
(+ (mref lvalue1 lvalue2 imm)))
|
|
(Effect (e)
|
|
(- (fp-offset live-info imm))))
|
|
|
|
(define-language L15d (extends L15c)
|
|
(terminals
|
|
(- (pred-primitive (pred-prim))
|
|
(value-primitive (value-prim))
|
|
(effect-primitive (effect-prim)))
|
|
(+ (procedure (proc)) => $procedure-name))
|
|
(entry Program)
|
|
(Lvalue (lvalue)
|
|
(- (mref lvalue1 lvalue2 imm))
|
|
(+ (mref x1 x2 imm)))
|
|
(Rhs (rhs)
|
|
(- (inline info value-prim t* ...))
|
|
(+ (asm info proc t* ...) => (asm proc t* ...)))
|
|
(Effect (e)
|
|
(- (inline live-info info effect-prim t* ...)
|
|
(overflow-check live-info)
|
|
(overflood-check live-info)
|
|
(fcallable-overflow-check live-info))
|
|
(+ (asm info proc t* ...) => (asm proc t* ...)
|
|
(move-related x1 x2)
|
|
(overflow-check p e* ...)))
|
|
(Pred (p pbody)
|
|
(- (inline live-info info pred-prim t* ...))
|
|
(+ (asm info proc t* ...) => (asm proc t* ...)))
|
|
(Tail (tl)
|
|
(- (jump live-info t))
|
|
(+ (jump t))))
|
|
|
|
(define-language L15e (extends L15d)
|
|
(terminals
|
|
(- (ur (x)))
|
|
(+ (reg (x))))
|
|
(entry Program)
|
|
(CaseLambdaExpr (le)
|
|
(- (lambda info max-fv (local* ...) (entry-block* ...) (block* ...)))
|
|
(+ (lambda info (entry-block* ...) (block* ...)) => (lambda (entry-block* ...) (block* ...))))
|
|
(Effect (e)
|
|
(- (set! live-info lvalue rhs)
|
|
(move-related x1 x2))
|
|
(+ (set! lvalue rhs))))
|
|
|
|
(define-language L16 (extends L15e)
|
|
(entry Program)
|
|
(Effect (e)
|
|
(- (overflow-check p e* ...))))
|
|
|
|
(meta-cond
|
|
[(not (eqv? (optimize-level) 3))
|
|
(pretty-format 'define-language
|
|
'(alt
|
|
(_ var #f ('terminals #f x ...) #f (_ _ #f ...) ...)
|
|
(_ var ('extends x) #f ('definitions #f x ...) #f ('terminals #f x ...) #f (_ _ #f ...) ...)
|
|
(_ var #f ('definitions #f x ...) #f ('terminals #f x ...) #f (_ _ #f ...) ...)
|
|
(_ var ('extends x) #f ('terminals #f x ...))
|
|
(_ var ('extends x) #f ('terminals #f x ...) #f (_ _ #f ...) ...)
|
|
(_ var ('extends x) #f (_ _ #f ...) ...)))
|
|
(pretty-format 'labels '(_ ([bracket x e] 0 ...) #f e ...))
|
|
(pretty-format 'blocks '(_ #f [bracket (x ...) 0 e] ...))])
|
|
|
|
(primitive-handler-set! %keep-live
|
|
(lambda (info x)
|
|
(with-output-language (L15d Effect)
|
|
`(asm ,info ,(lambda (code*) code*)))))
|
|
)
|