421 lines
11 KiB
Scheme
421 lines
11 KiB
Scheme
|
|
(module sig mzscheme
|
|
(require mzlib/unit)
|
|
|
|
(require "../sig.ss")
|
|
(require syntax/zodiac-sig)
|
|
|
|
(define for-syntax-in-env-stx #'for-syntax-in-env)
|
|
(provide for-syntax-in-env-stx)
|
|
|
|
(provide compiler:library^)
|
|
(define-signature compiler:library^
|
|
(logical-inverse
|
|
one-of
|
|
all-of
|
|
none-of
|
|
vector-map
|
|
improper-map
|
|
begin-map
|
|
list-index
|
|
list-last
|
|
|
|
set?
|
|
empty-set
|
|
make-singleton-set
|
|
list->set
|
|
set->list
|
|
improper-list->set
|
|
set-memq?
|
|
set-empty?
|
|
set-find
|
|
set-union
|
|
set-union-singleton
|
|
set-minus
|
|
set-remove
|
|
set-intersect
|
|
set-subset?
|
|
set-map
|
|
set-filter
|
|
remove-duplicates
|
|
symbol-append
|
|
compiler:formals->arity
|
|
compiler:formals->arity*
|
|
compiler:gensym
|
|
compiler:genlabel
|
|
compiler:clean-string
|
|
protect-comment
|
|
global-defined-value*
|
|
kernel-modname?
|
|
|
|
compiler:get-label-number
|
|
compiler:reset-label-number!))
|
|
|
|
(provide compiler:cstructs^)
|
|
(define-signature compiler:cstructs^
|
|
(varref:empty-attributes
|
|
varref:add-attribute!
|
|
varref:has-attribute?
|
|
|
|
varref:static
|
|
varref:per-load-static
|
|
varref:primitive
|
|
varref:symbol
|
|
varref:inexact
|
|
varref:env
|
|
varref:in-module
|
|
varref:module-stx-string
|
|
|
|
(struct compiler:make-closure (lambda free-vars args name))
|
|
|
|
(struct binding (rec? ; part of a letrec recursive binding set
|
|
mutable? ; set!ed?
|
|
anchor ; anchor binding for this binding
|
|
letrec-set?; set! for a letrec definition
|
|
ivar? ; is a class ivar?
|
|
known? val ; has known value?
|
|
known-but-used? ; known value used in an improper way?
|
|
rep)) ; reprsentation
|
|
copy-binding
|
|
|
|
copy-binding-for-light-closures
|
|
|
|
binder:empty-anno
|
|
|
|
(struct code (free-vars local-vars global-vars used-vars captured-vars
|
|
parent case-parent children))
|
|
|
|
(struct closure-code (rep alloc-rep label vehicle
|
|
max-arity
|
|
return-multi ; #f, #t, or 'possible
|
|
name))
|
|
|
|
(struct procedure-code (case-codes case-arities liftable method?))
|
|
|
|
(struct case-code (has-continue?))
|
|
|
|
(struct app (tail? prim? prim-name))
|
|
|
|
compiler:bound-varref->binding
|
|
|
|
(struct c-lambda (function-name scheme-name body arity))
|
|
|
|
(struct compiler:message (ast message))
|
|
(struct compiler:error-msg ())
|
|
(struct compiler:fatal-error-msg ())
|
|
(struct compiler:internal-error-msg ())
|
|
(struct compiler:warning-msg ())))
|
|
|
|
(provide compiler:zlayer^)
|
|
(define-signature compiler:zlayer^
|
|
(static-error
|
|
dynamic-error
|
|
internal-error
|
|
|
|
compiler:empty-annotation
|
|
make-empty-box
|
|
get-annotation
|
|
set-annotation!
|
|
annotated?
|
|
remove-annotation!
|
|
|
|
compiler:escape-on-error
|
|
|
|
zodiac:begin0-form-first
|
|
zodiac:begin0-form-rest
|
|
zodiac:set-begin0-form-first!
|
|
zodiac:set-begin0-form-rest!
|
|
|
|
undefined?
|
|
|
|
zodiac:make-special-constant
|
|
self_modidx
|
|
|
|
zodiac:binding->lexical-varref
|
|
|
|
main-source-file
|
|
zodiac:print-start!
|
|
|
|
zodiac->sexp/annotate))
|
|
|
|
(provide compiler:prephase^)
|
|
(define-signature compiler:prephase^
|
|
(prephase:init-binding-properties!
|
|
prephase:set-mutable!
|
|
prephase:set-binding-anchor!
|
|
prephase:is-mutable?
|
|
prephase:is-ivar?
|
|
prephase:binding-anchor
|
|
prephase:known-val
|
|
prephase:set-known-val!
|
|
|
|
prephase!))
|
|
|
|
(provide compiler:anorm^)
|
|
(define-signature compiler:anorm^
|
|
(a-normalize))
|
|
|
|
(provide compiler:const^)
|
|
(define-signature compiler:const^
|
|
(const:init-tables!
|
|
const:the-per-load-statics-table
|
|
const:per-load-statics-table?
|
|
|
|
const:get-symbol-counter
|
|
const:get-symbol-table
|
|
|
|
const:get-inexact-counter
|
|
const:get-inexact-table
|
|
|
|
const:get-string-table
|
|
const:get-bytes-table
|
|
const:intern-string
|
|
|
|
compiler:add-const!
|
|
compiler:get-symbol-const!
|
|
compiler:construct-const-code!
|
|
|
|
compiler:get-static-list
|
|
compiler:get-per-load-static-list
|
|
|
|
compiler:add-per-load-static-list!
|
|
|
|
compiler:make-const-constructor
|
|
|
|
(struct compiled-string (id len))))
|
|
|
|
(provide compiler:rep^)
|
|
(define-signature compiler:rep^
|
|
((struct rep:atomic (type))
|
|
(struct rep:pointer (to))
|
|
(struct rep:struct (name orig-name fields))
|
|
(struct rep:struct-field (name orig-name rep))
|
|
|
|
compiler:get-structs
|
|
compiler:init-structs!
|
|
|
|
rep:find-field
|
|
|
|
choose-binding-representations!
|
|
choose-closure-representation!))
|
|
|
|
(provide compiler:known^)
|
|
(define-signature compiler:known^
|
|
(make-unknown-letbound-binding
|
|
extract-varref-known-val
|
|
extract-ast-known-value
|
|
analyze-knowns!))
|
|
|
|
(provide compiler:analyze^)
|
|
(define-signature compiler:analyze^
|
|
(compiler:get-global-symbols
|
|
compiler:get-primitive-refs
|
|
|
|
compiler:get-define-list
|
|
compiler:get-per-load-define-list
|
|
|
|
compiler:init-define-lists!
|
|
|
|
compiler:add-global-varref!
|
|
compiler:add-primitive-varref!
|
|
|
|
compiler:add-local-define-list!
|
|
compiler:add-local-per-load-define-list!
|
|
|
|
(struct case-info (body case-code global-vars used-vars captured-vars max-arity))
|
|
|
|
(struct mod-glob (cname modname varname position exp-time? exp-def? in-module?))
|
|
compiler:get-module-path-constant
|
|
|
|
analyze-expression!))
|
|
|
|
(provide compiler:lift^)
|
|
(define-signature compiler:lift^
|
|
(lift-lambdas!
|
|
set-single-module-mode!))
|
|
|
|
(provide compiler:closure^)
|
|
(define-signature compiler:closure^
|
|
(compiler:get-closure-list
|
|
|
|
compiler:get-once-closures-list
|
|
compiler:get-once-closures-globals-list
|
|
compiler:get-lifted-lambdas
|
|
compiler:get-lifted-lambda-vars
|
|
|
|
compiler:init-closure-lists!
|
|
compiler:init-once-closure-lists!
|
|
compiler:init-lifted-lambda-list!
|
|
compiler:add-lifted-lambda!
|
|
(struct top-level-varref/bind-from-lift (lambda pls?))
|
|
|
|
closure-expression!))
|
|
|
|
(provide compiler:vehicle^)
|
|
(define-signature compiler:vehicle^
|
|
((struct vehicle (total-labels lambdas max-arity))
|
|
(struct procedure-vehicle (max-args))
|
|
|
|
compiler:get-vehicles
|
|
compiler:get-total-vehicles
|
|
compiler:get-case-lambdas
|
|
|
|
compiler:init-vehicles!
|
|
|
|
get-vehicle
|
|
relate-lambdas!
|
|
|
|
vehicle:only-code-in-vehicle?
|
|
|
|
choose-vehicles!))
|
|
|
|
(provide compiler:vmstructs^)
|
|
(define-signature compiler:vmstructs^
|
|
((struct vm:sequence (vals))
|
|
(struct vm:if (test then else))
|
|
|
|
(struct vm:void (val magic?))
|
|
(struct vm:return (val magic?))
|
|
(struct vm:tail-apply (closure argc prim))
|
|
(struct vm:tail-call (label closure set-env?))
|
|
(struct vm:continue ())
|
|
|
|
(struct vm:set! (vars val mode))
|
|
(struct vm:generic-args (closure tail? magic? prim vals))
|
|
(struct vm:register-args (vars vals))
|
|
(struct vm:args (type vals))
|
|
(struct vm:begin0-mark! (var val))
|
|
(struct vm:begin0-setup! (var))
|
|
(struct vm:syntax! (vars val in-mod?))
|
|
|
|
(struct vm:global-prepare (vec pos))
|
|
(struct vm:global-lookup (vec pos))
|
|
(struct vm:global-assign (vec val pos))
|
|
(struct vm:safe-vector-ref (vec pos))
|
|
|
|
(struct vm:alloc (type))
|
|
(struct vm:build-constant (text))
|
|
(struct vm:make-closure (closure))
|
|
(struct vm:make-procedure-closure (vehicle min-arity max-arity name empty? method?))
|
|
(struct vm:make-case-procedure-closure (vehicle num-cases case-arities name empty? method?))
|
|
(struct vm:apply (closure argc known? multi? prim simple-tail-prim?))
|
|
(struct vm:macro-apply (name primitive args tail? magic? bool?))
|
|
(struct vm:call (label closure))
|
|
(struct vm:begin0-extract (var))
|
|
(struct vm:wcm-mark! (key val))
|
|
(struct vm:wcm-push! (var))
|
|
(struct vm:wcm-pop! (var))
|
|
(struct vm:wcm-remember! (var val))
|
|
(struct vm:wcm-extract (var))
|
|
(struct vm:check-global (var))
|
|
(struct vm:module-create (shape id))
|
|
|
|
(struct vm:global-varref (var))
|
|
(struct vm:bucket (var))
|
|
(struct vm:per-load-statics-table ())
|
|
(struct vm:cast (val rep)) ; last resort
|
|
|
|
(struct vm:local-varref (var binding))
|
|
(struct vm:static-varref (var))
|
|
(struct vm:static-varref-from-lift (lambda))
|
|
(struct vm:per-load-static-varref ())
|
|
(struct vm:per-load-static-varref-from-lift (lambda))
|
|
(struct vm:primitive-varref (var))
|
|
(struct vm:symbol-varref (var))
|
|
(struct vm:inexact-varref (var))
|
|
(struct vm:struct-ref (field var))
|
|
(struct vm:deref (var))
|
|
(struct vm:ref (var))
|
|
|
|
(struct vm:immediate (text))
|
|
|
|
(struct vm:struct-type (fields))
|
|
|
|
vm:box-struct-type
|
|
|
|
arg-type:register
|
|
arg-type:arg
|
|
arg-type:tail-arg
|
|
|
|
target-type:global
|
|
target-type:lexical
|
|
target-type:static
|
|
|
|
vm:control-return?
|
|
|
|
vm:fixnum?
|
|
|
|
vm:literal-constant?))
|
|
|
|
(provide compiler:vmphase^)
|
|
(define-signature compiler:vmphase^
|
|
(vm:convert-bound-varref
|
|
vm-phase))
|
|
|
|
(provide compiler:vmopt^)
|
|
(define-signature compiler:vmopt^
|
|
(vm-optimize!))
|
|
|
|
(provide compiler:driver^)
|
|
(define-signature compiler:driver^ extends compiler:inner^
|
|
(compiler:error
|
|
compiler:fatal-error
|
|
compiler:internal-error
|
|
compiler:warning
|
|
|
|
get-s:file-block
|
|
s:register-max-arity!
|
|
compiler:get-setup-suffix
|
|
|
|
compiler:multi-o-constant-pool
|
|
|
|
register-c-lambda-function
|
|
register-c-declaration
|
|
|
|
debug
|
|
debug:get-port))
|
|
|
|
(provide compiler:top-level^)
|
|
(define-signature compiler:top-level^
|
|
((struct block (source codes bytecodes magics max-arity))
|
|
make-empty-block
|
|
block:register-max-arity!
|
|
|
|
add-code-local+used-vars!
|
|
remove-code-free-vars!))
|
|
|
|
(provide compiler:vm2c^)
|
|
(define-signature compiler:vm2c^
|
|
(vm->c:generate-modglob-name
|
|
|
|
vm->c:indent-by
|
|
vm->c:indent-spaces
|
|
|
|
vm->c:extract-inferred-name
|
|
|
|
vm->c:emit-symbol-list!
|
|
vm->c:emit-symbol-declarations!
|
|
vm->c:emit-symbol-definitions!
|
|
vm->c:emit-bytecode-string-definition!
|
|
vm->c:emit-inexact-declarations!
|
|
vm->c:emit-inexact-definitions!
|
|
vm->c:emit-string-declarations!
|
|
vm->c:emit-prim-ref-declarations!
|
|
vm->c:emit-prim-ref-definitions!
|
|
vm->c:emit-struct-definitions!
|
|
vm->c:emit-static-declarations!
|
|
vm->c:emit-registration!
|
|
vm->c:emit-case-arities-definitions!
|
|
vm->c:emit-top-levels!
|
|
vm->c:emit-vehicle-prototype
|
|
vm->c:emit-vehicle-declaration
|
|
vm->c:emit-vehicle-header
|
|
vm->c:emit-vehicle-prologue
|
|
vm->c:emit-vehicle-epilogue
|
|
vm->c:convert-type-definition
|
|
vm->c:emit-function-prologue
|
|
vm->c:emit-case-prologue
|
|
vm->c:emit-case-epilogue
|
|
vm->c:emit-function-epilogue
|
|
vm->c-expression)))
|