suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

299.406

Browse Source 
svn: r1287
This commit is contained in:
Matthew Flatt 2005-11-11 21:26:46 +00:00
parent bb69014fc7
commit aa0692e7cd
50 changed files with 2722 additions and 2453 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
collects/compiler/mzc.h
View File

@ -9,6 +9,36 @@
"invoke-unit: cannot link to undefined identifier: %S", \
(Scheme_Object*)(x)->key);
#ifdef NO_INLINE_KEYWORD
# define MZC_INLINE /* */
#else
# define MZC_INLINE MSC_IZE(inline)
#endif
#define MZC_GLOBAL_PREPARE(vec, pos) (SCHEME_VEC_ELS(vec)[pos] = SCHEME_PTR_VAL(SCHEME_VEC_ELS(vec)[pos]))
static MZC_INLINE Scheme_Object *MZC_GLOBAL_LOOKUP(Scheme_Object *vec, int pos) {
Scheme_Bucket *bucket = (Scheme_Bucket *)SCHEME_VEC_ELS(vec)[pos];
Scheme_Object *o = bucket->val;
if (o)
return o;
else {
scheme_unbound_global(bucket);
return NULL;
}
}
static MZC_INLINE Scheme_Object *MZC_GLOBAL_ASSIGN(Scheme_Object *vec, int pos, Scheme_Object *val) {
Scheme_Bucket *bucket = (Scheme_Bucket *)SCHEME_VEC_ELS(vec)[pos];
scheme_set_global_bucket("set!", bucket, val, 0);
return scheme_void;
}
#define MZC_KNOWN_SAFE_VECTOR_REF(vec, pos) (SCHEME_VEC_ELS(vec)[pos])
#define MZC_APPLY_MAGIC(val, n) \
scheme_eval_compiled_sized_string_with_magic(top_level_bytecode_ ## n, sizeof(top_level_bytecode_ ## n), NULL, \
scheme_intern_symbol(top_level_magic_sym_ ## n), val, 1)
#define DO_FUEL_POLL ((scheme_fuel_counter-- <= 0) ? (scheme_process_block(0), 0) : 0)
#define _scheme_direct_apply_primitive_multi_poll(prim, argc, argv) \

123
collects/compiler/private/analyze.ss
View File

@ -167,19 +167,15 @@
(define compiler:define-list null)
(define compiler:per-load-define-list null)
(define compiler:per-invoke-define-list null)
(define compiler:local-define-list null)
(define compiler:local-per-load-define-list null)
(define compiler:local-per-invoke-define-list null)
(define (compiler:get-define-list) compiler:define-list)
(define (compiler:get-per-load-define-list) compiler:per-load-define-list)
(define (compiler:get-per-invoke-define-list) compiler:per-invoke-define-list)
(define (compiler:init-define-lists!)
(set! compiler:define-list null)
(set! compiler:per-load-define-list null)
(set! compiler:per-invoke-define-list null)
(set! compiler:global-symbols (make-hash-table))
(set! compiler:primitive-refs empty-set))
@ -189,14 +185,10 @@
(define (compiler:add-local-per-load-define-list! def)
(set! compiler:local-per-load-define-list
(cons def compiler:local-per-load-define-list)))
(define (compiler:add-local-per-invoke-define-list! def)
(set! compiler:local-per-invoke-define-list
(cons def compiler:local-per-invoke-define-list)))
(define (prepare-local-lists)
(set! compiler:local-define-list null)
(set! compiler:local-per-load-define-list null)
(set! compiler:local-per-invoke-define-list null))
(set! compiler:local-per-load-define-list null))
(define (move-over-local-lists)
(set! compiler:define-list
@ -205,38 +197,9 @@
(set! compiler:per-load-define-list
(append! compiler:per-load-define-list
(reverse! compiler:local-per-load-define-list)))
(set! compiler:per-invoke-define-list
(append! compiler:per-invoke-define-list
(reverse! compiler:local-per-invoke-define-list)))
(set! compiler:local-define-list null)
(set! compiler:local-per-load-define-list null)
(set! compiler:local-per-invoke-define-list null))
(define (compiler:finish-syntax-constants!)
(set! compiler:local-define-list null)
(set! compiler:local-per-load-define-list null)
(set! compiler:local-per-invoke-define-list null)
(begin0
;; Return this result - it's a number
(const:finish-syntax-constants!)
(unless (and (null? compiler:local-per-load-define-list)
(null? compiler:local-per-invoke-define-list))
(set! compiler:define-list
(append! compiler:define-list
(reverse! compiler:local-define-list)))
(set! compiler:per-load-define-list
(append! compiler:per-load-define-list
(reverse! compiler:local-per-load-define-list)))
(set! compiler:per-invoke-define-list
(append! compiler:per-invoke-define-list
(reverse! compiler:local-per-invoke-define-list)))
(set! compiler:local-define-list null)
(set! compiler:local-per-load-define-list null)
(set! compiler:local-per-invoke-define-list null))))
(set! compiler:local-per-load-define-list null))
;; Temporary structure used in building up case-lambda info
(define-struct case-info
@ -429,6 +392,9 @@
(+ size 1)
(lambda (size)
(bloop size (cdr exprs))))))]
[(zodiac:global-lookup? body) (k size)]
[(zodiac:safe-vector-ref? body) (k size)]
[(zodiac:global-assign? body) (loop (zodiac:global-assign-expr body) env (+ size 1) k)]
[else (* 2 (compiler:option:max-inline-size))]))))
;; We copy inlined bodies to generate unique structure values
@ -538,6 +504,25 @@
(make-empty-box)
(map (lambda (x) (copy-inlined-body x binding-map))
(zodiac:begin-form-bodies ast)))]
[(zodiac:global-lookup? ast)
(zodiac:make-global-lookup
(zodiac:zodiac-stx ast)
(make-empty-box)
(copy-inlined-body (zodiac:global-lookup-vec ast) binding-map)
(zodiac:global-lookup-pos ast))]
[(zodiac:safe-vector-ref? ast)
(zodiac:make-safe-vector-ref
(zodiac:zodiac-stx ast)
(make-empty-box)
(copy-inlined-body (zodiac:safe-vector-ref-vec ast) binding-map)
(zodiac:safe-vector-ref-pos ast))]
[(zodiac:global-assign? ast)
(zodiac:make-global-assign
(zodiac:zodiac-stx ast)
(make-empty-box)
(copy-inlined-body (zodiac:global-assign-vec ast) binding-map)
(zodiac:global-assign-pos ast)
(copy-inlined-body (zodiac:global-assign-expr ast) binding-map))]
[else (compiler:internal-error
ast
(format "copy-inlined-body: can't copy ~a"
@ -749,9 +734,6 @@
(when (and (zodiac:varref? c)
(varref:has-attribute? c varref:per-load-static))
(add-global-var! const:the-per-load-statics-table))
(when (and (zodiac:varref? c)
(varref:has-attribute? c varref:per-invoke-static))
(add-global-var! (varref:invoke-module ast)))
c)]
@ -793,8 +775,6 @@
(compiler:add-primitive-varref! ast)]
[(varref:has-attribute? ast varref:per-load-static)
(add-global-var! const:the-per-load-statics-table)]
[(varref:has-attribute? ast varref:per-invoke-static)
(add-global-var! (varref:invoke-module ast))]
[(varref:has-attribute? ast varref:static)
(void)]
[else
@ -834,9 +814,6 @@
(when (and (zodiac:top-level-varref? ret)
(varref:has-attribute? ret varref:per-load-static))
(add-global-var! const:the-per-load-statics-table))
(when (and (zodiac:top-level-varref? ret)
(varref:has-attribute? ret varref:per-invoke-static))
(add-global-var! (varref:invoke-module ret)))
ret))]
@ -1060,7 +1037,6 @@
;; can't eliminiate if a letrec->let variable
(not (binding-letrec-set? binding))
;; can't eliminate if it is used by a bad application
;; or by invoke
(not (binding-known-but-used? binding)))
;; discard the let:
@ -1248,10 +1224,9 @@
(zodiac:set-define-values-form-vars!
ast
(map (lambda (v)
(let ([v (if (varref:current-invoke-module)
v
;; Make sure v is not mapped to an import:
(ensure-top-level v))])
(let ([v
;; Make sure v is not mapped to an import:
(ensure-top-level v)])
(analyze-varref! v env #f #t)))
(zodiac:define-values-form-vars ast)))
@ -1365,32 +1340,32 @@
(values ast body-multi))]
;;-----------------------------------------------------------------
;; QUOTE-SYNTAX
;;
;; Construct constant.
;;
[(zodiac:quote-syntax-form? ast)
(let ([ret (const:make-syntax-constant (zodiac:quote-syntax-form-expr ast))])
;; Put a pointer to the constructed constant in the quote-form's backbox
(set-annotation! ast ret)
;; This variable is per-load:
(add-global-var! const:the-per-load-statics-table)
(values ret #f))]
;;-----------------------------------------------------------
;; MODULE
;; GLOBALS
;;
[(zodiac:module-form? ast)
(zodiac:set-module-form-body!
[(zodiac:global-prepare? ast)
(zodiac:set-global-prepare-vec!
ast
(analyze!-ast (zodiac:module-form-body ast) env inlined))
(analyze!-ast (zodiac:global-prepare-vec ast) env inlined))
(values ast #f)]
[(zodiac:global-lookup? ast)
(zodiac:set-global-lookup-vec!
ast
(analyze!-ast (zodiac:global-lookup-vec ast) env inlined))
(values ast #f)]
[(zodiac:global-assign? ast)
(zodiac:set-global-assign-vec!
ast
(analyze!-ast (zodiac:global-assign-vec ast) env inlined))
(zodiac:set-global-assign-expr!
ast
(analyze!-ast (zodiac:global-assign-expr ast) env inlined))
(values ast #f)]
[(zodiac:safe-vector-ref? ast)
(zodiac:set-safe-vector-ref-vec!
ast
(analyze!-ast (zodiac:safe-vector-ref-vec ast) env inlined))
(values ast #f)]
[else (compiler:internal-error
ast

39
collects/compiler/private/anorm.ss
View File

@ -268,25 +268,6 @@
(set-annotation! begin0-exp tbound)
(k begin0-exp))]
;;-----------------------------------------------------------
;; MODULE
;;
[(zodiac:module-form? ast)
(k (zodiac:make-module-form
(zodiac:zodiac-stx ast)
(zodiac:parsed-back ast)
(zodiac:module-form-name ast)
(zodiac:module-form-requires ast)
(zodiac:module-form-for-syntax-requires ast)
(zodiac:module-form-for-template-requires ast)
(a-normalize (zodiac:module-form-body ast) identity)
#f ; see split-module in driver.ss
(zodiac:module-form-provides ast)
(zodiac:module-form-syntax-provides ast)
(zodiac:module-form-indirect-provides ast)
(zodiac:module-form-kernel-reprovide-hint ast)
(zodiac:module-form-self-path-index ast)))]
;;---------------------------------------------------------------
;; SET! EXPRESSIONS / DEFINE EXPRESSIONS
;;
@ -310,6 +291,26 @@
(zodiac:define-values-form-vars ast)
(a-normalize (zodiac:define-values-form-val ast) identity)))]
;;-----------------------------------------------------------
;; GLOBALS
;;
[(zodiac:global-prepare? ast)
(k ast)]
[(zodiac:global-lookup? ast)
(k ast)]
[(zodiac:global-assign? ast)
(normalize-name
(zodiac:global-assign-expr ast)
(lambda (norm-expr)
(k (zodiac:make-global-assign
(zodiac:zodiac-stx ast)
(zodiac:parsed-back ast)
(zodiac:global-assign-vec ast)
(zodiac:global-assign-pos ast)
norm-expr))))]
[(zodiac:safe-vector-ref? ast)
(k ast)]
;;----------------------------------------------------------
;; DEFINE-SYNTAX
;;

67
collects/compiler/private/closure.ss
View File

@ -64,9 +64,7 @@
;; Set the closure's liftable field to a new top-level-varref
(let* ([code (get-annotation lam)]
[var (gensym (if pls?
(if (varref:current-invoke-module)
'pmilifted
'pllifted)
'pllifted
'lifted))]
[sv (make-top-level-varref/bind-from-lift
(zodiac:zodiac-stx lam)
@ -78,7 +76,7 @@
#f
#f
lam
(and pls? (or (varref:current-invoke-module) pls?)))]
pls?)]
[def (zodiac:make-define-values-form
(zodiac:zodiac-stx lam)
(make-empty-box)
@ -92,32 +90,11 @@
(set-procedure-code-liftable! code (list sv))
(if pls?
(let ([def (if (varref:current-invoke-module)
(let ([def (zodiac:make-module-form
(zodiac:zodiac-stx def)
(make-empty-box)
#f #f #f #f
def #f
#f #f #f #f #f)])
(set-annotation!
def
(let ([mi (varref:current-invoke-module)])
(make-module-info mi
#f
(if (varref:module-invoke-syntax? mi)
'syntax-body
'body))))
def)
def)])
(let ([mi (varref:current-invoke-module)])
(varref:add-attribute! sv (or mi varref:per-load-static))
((if mi
(lambda (v) (compiler:add-per-invoke-static-list! v mi))
compiler:add-per-load-static-list!)
var)
(set! compiler:once-closures-list (cons def compiler:once-closures-list))
(set! compiler:once-closures-globals-list (cons (code-global-vars code) compiler:once-closures-globals-list))))
(begin
(varref:add-attribute! sv varref:per-load-static)
(compiler:add-per-load-static-list! var)
(set! compiler:once-closures-list (cons def compiler:once-closures-list))
(set! compiler:once-closures-globals-list (cons (code-global-vars code) compiler:once-closures-globals-list)))
(begin
(set! compiler:lifted-lambda-vars (cons sv compiler:lifted-lambda-vars))
(set! compiler:lifted-lambdas (cons def compiler:lifted-lambdas)))))))
@ -272,16 +249,32 @@
(transform! (zodiac:with-continuation-mark-form-body ast)))
ast]
;;-----------------------------------------------------------
;; MODULE
;; GLOBALS
;;
[(zodiac:module-form? ast)
(zodiac:set-module-form-body!
[(zodiac:global-prepare? ast)
(zodiac:set-global-prepare-vec!
ast
(transform! (zodiac:module-form-body ast)))
(transform! (zodiac:global-prepare-vec ast)))
ast]
[(zodiac:global-lookup? ast)
(zodiac:set-global-lookup-vec!
ast
(transform! (zodiac:global-lookup-vec ast)))
ast]
[(zodiac:global-assign? ast)
(zodiac:set-global-assign-vec!
ast
(transform! (zodiac:global-assign-vec ast)))
(zodiac:set-global-assign-expr!
ast
(transform! (zodiac:global-assign-expr ast)))
ast]
[(zodiac:safe-vector-ref? ast)
(zodiac:set-safe-vector-ref-vec!
ast
(transform! (zodiac:safe-vector-ref-vec ast)))
ast]
[else (compiler:internal-error

199
collects/compiler/private/const.ss
View File

@ -54,16 +54,12 @@
(define compiler:static-list null)
(define compiler:per-load-static-list null)
(define compiler:per-invoke-static-list null)
(define (compiler:get-static-list) compiler:static-list)
(define (compiler:get-per-load-static-list) compiler:per-load-static-list)
(define (compiler:get-per-invoke-static-list) compiler:per-invoke-static-list)
(define new-uninterned-symbols null) ; list of (cons sym pos)
(define syntax-strings null) ; list of syntax-string structs
(define (const:init-tables!)
(set! const:symbol-table (make-hash-table))
(set! const:symbol-counter 0)
@ -75,10 +71,8 @@
(set! const:string-counter 0)
(set! compiler:static-list null)
(set! compiler:per-load-static-list null)
(set! compiler:per-invoke-static-list null)
(set! vector-table (make-hash-table))
(set! new-uninterned-symbols null)
(set! syntax-strings null))
(set! new-uninterned-symbols null))
(define (const:intern-string s)
(let ([table
@ -98,32 +92,12 @@
(set! compiler:per-load-static-list
(cons var compiler:per-load-static-list)))
(define (compiler:add-per-invoke-static-list! var mi)
(set! compiler:per-invoke-static-list
(cons (cons var mi) compiler:per-invoke-static-list)))
(define-values (const:the-per-load-statics-table
const:per-load-statics-table?)
(let-struct const:per-load-statics-table ()
(values (make-const:per-load-statics-table)
const:per-load-statics-table?)))
(define (wrap-module-definition def mi)
(let ([def (zodiac:make-module-form
(zodiac:zodiac-stx def)
(make-empty-box)
#f #f #f #f
def #f
#f #f #f #f #f)])
(set-annotation!
def
(make-module-info mi
#f
(if (varref:module-invoke-syntax? mi)
'syntax-body
'body)))
def))
;; we need to make this in a-normalized, analyzed form from the beginning
(define compiler:add-const!
(lambda (code attr)
@ -149,11 +123,6 @@
(set! compiler:per-load-static-list
(cons var compiler:per-load-static-list))
(compiler:add-local-per-load-define-list! def)]
[(varref:module-invoke? attr)
(set! compiler:per-invoke-static-list
(cons (cons var attr) compiler:per-invoke-static-list))
(let ([def (wrap-module-definition def attr)])
(compiler:add-local-per-invoke-define-list! def))]
[else
(set! compiler:static-list (cons var compiler:static-list))
(compiler:add-local-define-list! def)])
@ -199,17 +168,6 @@
new-uninterned-symbols
(set! new-uninterned-symbols null)))
(define-struct syntax-string (str mi uposes ustart id))
(define (compiler:add-syntax-string! str mi uninterned-positions uninterned-start)
(let ([naya (make-syntax-string str mi uninterned-positions uninterned-start
(length syntax-strings))])
(set! syntax-strings (cons naya syntax-strings))
naya))
(define (const:get-syntax-strings)
syntax-strings)
(define compiler:get-inexact-real-const!
(lambda (v ast)
(let ([sym (string->symbol (number->string v))])
@ -463,10 +421,9 @@
(compiler:construct-const-code!
(wrap base)
known-immutable?)))
(or (varref:current-invoke-module)
(if known-immutable?
varref:static
varref:per-load-static))))
(if known-immutable?
varref:static
varref:per-load-static)))
(zodiac:make-special-constant 'self_modidx)))]
;; other atomic constants that must be built
@ -475,151 +432,5 @@
(bytes? (zodiac:zread-object ast)))
(const:intern-string (zodiac:zread-object ast)))
(compiler:add-const! (compiler:re-quote ast)
varref:static)])))
(define syntax-constants null)
(define (const:reset-syntax-constants!)
(set! syntax-constants null))
(define (const:make-syntax-constant stx)
;; Marhsall to a string constant, and read back out at run-time.
;; For sharing of syntax info, put all syntax objects for a given
;; top-level expression into one marshal step.
(let* ([var (gensym 'conststx)]
[sv (zodiac:make-top-level-varref
stx
(make-empty-box)
var
#f
(box '())
#f
#f
#f)])
(set! syntax-constants (cons (cons sv stx)
syntax-constants))
(set-annotation! sv (varref:empty-attributes))
(varref:add-attribute! sv varref:static)
(varref:add-attribute! sv (or (varref:current-invoke-module)
varref:per-load-static))
(if (varref:current-invoke-module)
(set! compiler:per-invoke-static-list
(cons (cons var (varref:current-invoke-module))
compiler:per-invoke-static-list))
(set! compiler:per-load-static-list
(cons var compiler:per-load-static-list)))
sv))
;; We collect syntax objects together to share the cost of of
;; the rename tables. More gnerally, to get the expansion-time
;; info to use-time, we use the bytecode writer built into
;; MzScheme, putting multiple syntax objects together into a
;; syntax vector. The scheme_eval_compiled_stx_string() will
;; unpack it, and perform any necessary phase shifts. To perform
;; the module mapping associated with the phase shift,
;; scheme_eval_compiled_stx_string() expects the "syntax" vector
;; to have a module index path (the "self" path) as its last
;; element.
;; Returns a max-arity.
(define (const:finish-syntax-constants!)
(if (null? syntax-constants)
0
(let* ([s (open-output-bytes)]
[uninterned-symbol-info (get-new-uninterned-symbols!)]
[c (compile `(quote-syntax ,(list->vector
(let ([l (map cdr syntax-constants)]
[mi (varref:current-invoke-module)])
(append
l
(map car uninterned-symbol-info) ; car gets the syms
(if mi
(list (varref:module-invoke-context-path-index mi))
null))))))])
(display c s)
(let ([syntax-string (get-output-bytes s)])
(let* ([strvar (compiler:add-syntax-string!
syntax-string
(varref:current-invoke-module)
(map cdr uninterned-symbol-info) ; cdr gets positions
(length syntax-constants))] ; starting place for symbols
[vecvar (gensym 'conststxvec)]
[sv (zodiac:make-top-level-varref
#f
(make-empty-box)
vecvar
#f
(box '())
#f
#f
#f)])
(set-annotation! sv (varref:empty-attributes))
(varref:add-attribute! sv varref:static)
(varref:add-attribute! sv (or (varref:current-invoke-module)
varref:per-load-static))
(if (varref:current-invoke-module)
(set! compiler:per-invoke-static-list
(cons (cons vecvar (varref:current-invoke-module))
compiler:per-invoke-static-list))
(set! compiler:per-load-static-list
(cons vecvar compiler:per-load-static-list)))
((if (varref:current-invoke-module)
compiler:add-local-per-invoke-define-list!
compiler:add-local-per-load-define-list!)
(let ([def
(zodiac:make-define-values-form
#f
(make-empty-box) (list sv)
(compiler:re-quote
(zodiac:make-zread
(datum->syntax-object
#f
strvar ;; <------ HACK! See "HACK!" in vm2c.ss
#f))))])
(if (varref:current-invoke-module)
(wrap-module-definition def (varref:current-invoke-module))
def)))
;; Create construction code for each
;; syntax variable:
(let loop ([l syntax-constants]
[pos 0])
(unless (null? l)
(let ([app (zodiac:make-app
(cdar l)
(make-empty-box)
(zodiac:make-top-level-varref
(cdar l)
(make-empty-box)
'vector-ref
'#%kernel
(box '())
#f
#f
#f)
(list
sv
(compiler:re-quote
(zodiac:make-zread
(datum->syntax-object
#f
pos
(cdar l))))))])
(set-annotation! app (make-app #f #t 'vector-ref))
((if (varref:current-invoke-module)
compiler:add-local-per-invoke-define-list!
compiler:add-local-per-load-define-list!)
(let ([def
(zodiac:make-define-values-form
(cdar l)
(make-empty-box) (list (caar l))
app)])
(if (varref:current-invoke-module)
(wrap-module-definition def (varref:current-invoke-module))
def)))
(loop (cdr l) (add1 pos)))))))
(set! syntax-constants null)
;; We make an application with 2 arguments
2))))))
varref:static)]))))))

43
collects/compiler/private/cstructs.ss
View File

@ -25,27 +25,18 @@
;; VARREF ATTRIBUTES
;; Used as the annotation for zodiac:varref objects
(define-struct va (flags invoke-module))
(define-struct va (flags i-n-v-oke-module))
(define (varref:empty-attributes) (make-va 0 #f))
(define (varref:add-attribute! ast attr)
(let ([va (get-annotation ast)])
(let ([attr (if (varref:module-invoke? attr)
(begin
(set-va-invoke-module! va attr)
varref:per-invoke-static)
attr)])
(set-va-flags! va (bitwise-ior attr (va-flags va))))))
(set-va-flags! va (bitwise-ior attr (va-flags va)))))
(define (varref:has-attribute? ast attr)
(let ([anno (get-annotation ast)])
(and (va? anno) (positive? (bitwise-and (va-flags anno) attr)))))
(define (varref:invoke-module ast)
(let ([anno (get-annotation ast)])
(and (va? anno) (va-invoke-module anno))))
(define varref:static 1)
(define varref:per-load-static 2)
(define varref:per-invoke-static 4)
(define varref:primitive 8)
(define varref:symbol 16)
(define varref:inexact 32)
@ -53,22 +44,6 @@
(define varref:in-module 128)
(define varref:module-stx-string 256)
(define mi-counter -1)
(define-struct varref:module-invoke (id syntax? context-path-index))
(define (make-module-invokes self-path-index)
(set! mi-counter (add1 mi-counter))
(values (make-varref:module-invoke mi-counter #f self-path-index)
(make-varref:module-invoke mi-counter #t self-path-index)))
(define (get-num-module-invokes)
(add1 mi-counter))
(define (is-module-invoke? mi num)
(and (varref:module-invoke? mi)
(= num (varref:module-invoke-id mi))))
(define (varref:reset-module-id!) (set! mi-counter -1))
;;----------------------------------------------------------------------------
;; AST NODES
;; New AST nodes to augment the zodiac set:
@ -84,7 +59,7 @@
;; analysis phase
(define-struct binding (rec? ; part of a letrec recursive binding set
mutable? ; set!ed? (but not for unit or letrec definitions)
unit-i/e? ; is imported/exported (including uses by invoke)
unit-i/e? ; is imported/exported (including uses by in-voke)
anchor ; zodiac:binding - anchor binding for this binding
letrec-set?; set! to implement a letrec
ivar? ; is a class ivar?
@ -182,7 +157,7 @@
max-arity
;; max number of args in applications
;; within the closure (which is unrelated
;; to the number of arguments used to invoke
;; to the number of arguments used to call
;; this closure, if it happens to be a
;; lambda)
@ -229,16 +204,6 @@
;; MzScheme name for the known primitive, or #f
))
(define-struct module-info (invoke
;; a module-invoke record
syntax-invoke
;; another module-invoke record
part
;; 'body, 'syntax-body, or 'constructor
))
(define varref:current-invoke-module (make-parameter #f))
;;----------------------------------------------------------------------------
;; ACCESSOR
;;

293
collects/compiler/private/driver.ss
View File

@ -73,8 +73,9 @@
(lib "link-sig.ss" "dynext")
(lib "file-sig.ss" "dynext"))
(require "../sig.ss")
(require "sig.ss")
(require "../sig.ss"
"sig.ss"
"to-core.ss")
(provide driver@)
@ -223,7 +224,7 @@
expand-top-level-with-compile-time-evals
expand)
expr)])
(zodiac:syntax->zodiac
(values ; use to be zodiac:syntax->zodiac here
(let ([p (src2src:optimize expanded #t)])
'(with-output-to-file "/tmp/l.ss"
(lambda () (pretty-print (syntax-object->datum p)))
@ -249,71 +250,7 @@
(require-for-syntax mzscheme))))))))
;;----------------------------------------------------------------------
;; Misc utils
;; see (single) use for info:
(define (split-module m)
(let ([info (get-annotation m)])
(let ([mk
(lambda (expr mode)
(let ([ast (zodiac:make-module-form
(zodiac:zodiac-stx expr)
(make-empty-box)
(zodiac:module-form-name m)
(zodiac:module-form-requires m)
(zodiac:module-form-for-syntax-requires m)
(zodiac:module-form-for-template-requires m)
expr #f
(zodiac:module-form-provides m)
(zodiac:module-form-syntax-provides m)
(zodiac:module-form-indirect-provides m)
(zodiac:module-form-kernel-reprovide-hint m)
(zodiac:module-form-self-path-index m))])
(set-annotation!
ast
(make-module-info ((if (eq? mode 'syntax-body)
module-info-syntax-invoke
module-info-invoke)
info)
#f
mode))
ast))]
[body->list
(lambda (expr)
(if (zodiac:begin-form? expr)
(zodiac:begin-form-bodies expr)
(list expr)))])
(append
(map (lambda (x) (mk x 'body))
(body->list
(zodiac:module-form-body m)))
(map (lambda (x) (mk x 'syntax-body))
(body->list
(zodiac:module-form-syntax-body m)))
(list (mk
;; Construct constant expression for module construction info:
(let ([q (zodiac:make-quote-form
(zodiac:zodiac-stx m)
(make-empty-box)
(zodiac:make-zread
(datum->syntax-object
#f
(list (zodiac:module-form-name m)
(zodiac:module-form-requires m)
(zodiac:module-form-for-syntax-requires m)
(zodiac:module-form-for-template-requires m)
(filter (if (zodiac:module-form-kernel-reprovide-hint m)
(lambda (x) (or (symbol? x)
(not (eq? '#%kernel (car x)))))
(lambda (x) #t))
(zodiac:module-form-provides m))
(zodiac:module-form-syntax-provides m)
(zodiac:module-form-indirect-provides m)
(zodiac:module-form-kernel-reprovide-hint m))
(zodiac:zodiac-stx m))))])
(set-annotation! q 'immutable)
q)
'constructor))))))
;; Misc utils
;; takes a list of a-normalized expressions and analyzes them
;; returns the analyzed code, a list of local variable lists,
@ -344,11 +281,6 @@
(reverse! children-acc))
max-arity)
(begin
(varref:current-invoke-module
(and (zodiac:module-form? (car sexps))
(let ([info (get-annotation (car sexps))])
(and (not (eq? (module-info-part info) 'constructor))
(module-info-invoke info)))))
;; (printf "~a~n" (syntax-line (zodiac:zodiac-stx (car sexps))))
@ -357,22 +289,8 @@
(analyze-expression! (car sexps) empty-set null (null? (cdr sexps)))])
(let ([sc-max-arity
;; Adds to const, per-load-const, per-invoke-const lists:
(if (or (null? (cdr sexps))
(not (zodiac:module-form? (car sexps)))
(not (zodiac:module-form? (cadr sexps)))
(let ([a1 (get-annotation (car sexps))]
[a2 (get-annotation (cadr sexps))])
(not (and (eq? (module-info-part a1)
(module-info-part a2))
(eq? (module-info-invoke a1)
(module-info-invoke a2))))))
(compiler:finish-syntax-constants!)
0)])
(let ([sc-max-arity 0])
(varref:current-invoke-module #f)
(loop (cdr sexps)
(cons exp source-acc)
(cons local-vars locals-acc)
@ -404,13 +322,21 @@
[l l][c c]
[pll-acc null][plc-acc null])
(if (zero? n)
(begin
(let ([lifted-lambdas (compiler:get-lifted-lambdas)]
[once-closures (compiler:get-once-closures-list)])
(let ([naya (append lifted-lambdas once-closures)])
(set-block-magics! s:file-block (append (map (lambda (x) #f) naya)
(block-magics s:file-block)))
(set-block-bytecodes! s:file-block (append (map (lambda (x) #f) naya)
(block-bytecodes s:file-block))))
(set-block-source!
s:file-block
(append (reverse l-acc)
(compiler:get-lifted-lambdas)
lifted-lambdas
(reverse pll-acc)
(compiler:get-once-closures-list)
once-closures
(map car l)))
(set-block-codes!
s:file-block
@ -438,9 +364,7 @@
(list
(get-annotation
(zodiac:define-values-form-val
(if (zodiac:module-form? ll)
(zodiac:module-form-body ll)
ll))))))
ll)))))
(compiler:get-once-closures-list)
(compiler:get-once-closures-globals-list))
(map reset-globals c (map cdr l)))))
@ -457,7 +381,7 @@
(lambda (file-block l)
(set-block-codes!
file-block
(append!
(append
(map
(lambda (glob)
(make-code empty-set
@ -470,7 +394,15 @@
(block-codes file-block)))
(set-block-source!
file-block
(append! l (block-source file-block)))))
(append l (block-source file-block)))
(set-block-bytecodes!
file-block
(append (map (lambda (x) #f) l)
(block-bytecodes file-block)))
(set-block-magics!
file-block
(append (map (lambda (x) #f) l)
(block-magics file-block)))))
(define (open-input-scheme-file path)
(let ([p (let ([open (with-handlers ([exn:fail? (lambda (x) #f)])
@ -630,7 +562,6 @@
(set! c-lambdas null)
(const:init-tables!)
(compiler:init-closure-lists!)
(varref:reset-module-id!)
; process the input string - try to open the input file
(let-values ([(input-path c-output-path
constant-pool-output-path obj-output-path dll-output-path
@ -695,14 +626,73 @@
;;-----------------------------------------------------------------------
;; record module name, if a single declaration
;;
(set-single-module-mode! #f)
(when (and (= 1 (length (block-source s:file-block)))
(zodiac:module-form? (car (block-source s:file-block))))
(set-single-module-mode! #t)
(set! compiler:module-decl-name
(syntax-e (zodiac:module-form-name (car (block-source s:file-block))))))
(when (= 1 (length (block-source s:file-block)))
(syntax-case (car (block-source s:file-block)) (module)
[(module name . _)
(begin
(set-single-module-mode! #t)
(set! compiler:module-decl-name (syntax-e #'name)))]
[_else (void)]))
;;-----------------------------------------------------------------------
;; ensure that no `module' expression is inside a `begin'
;;
(letrec ([needs-split?
(lambda (stx saw-begin?)
(syntax-case stx (begin module)
[(module . _) saw-begin?]
[(begin . e)
(ormap (lambda (x) (needs-split? x #t))
(syntax->list #'e))]
[_else #f]))]
[split
(lambda (stx)
(syntax-case stx (begin module)
[(begin . e)
(apply append (map split (syntax->list #'e)))]
[_else (list stx)]))])
(set-block-source!
s:file-block
(apply
append
(map (lambda (e)
(if (needs-split? e #f)
(split e)
(list e)))
(block-source s:file-block)))))
;;-----------------------------------------------------------------------
;; Extract stateless, phaseless core, leaving the rest of bytecode
;;
(when (compiler:option:verbose) (printf " extracting core expressions~n"))
(when (compiler:option:debug) (debug " = CORE =~n"))
(let ([core-thunk
(lambda ()
(let ([sources+bytecodes+magics
(map (lambda (src)
(let-values ([(src bytecode magic-sym)
(top-level-to-core src
#`'#,zodiac:global-lookup-id
#`'#,zodiac:global-assign-id
#`'#,zodiac:safe-vector-ref-id
#`'#,zodiac:global-prepare-id)])
(list (zodiac:syntax->zodiac src)
bytecode magic-sym)))
(block-source s:file-block))])
(set-block-source! s:file-block (map car sources+bytecodes+magics))
(set-block-bytecodes! s:file-block
(parameterize ([current-namespace elaborate-namespace])
(map compile
(map cadr sources+bytecodes+magics))))
(set-block-magics! s:file-block (map caddr sources+bytecodes+magics))))])
(verbose-time core-thunk))
;;-----------------------------------------------------------------------
;; Run a preprocessing phase on the input
;;
@ -722,17 +712,7 @@
(if (eq? errors compiler:messages)
;; no errors here
(if (zodiac:module-form? ast)
;; If it's a module, split it into three parts:
;; - body
;; - syntax definitions
;; - module registration
;; That way, the global variable sets, etc., are
;; kept separate.
(append (split-module ast) (loop (cdr source) errors))
;; Normal expr
(cons ast (loop (cdr source) errors)))
(cons ast (loop (cdr source) errors))
;; error, drop this one
(loop (cdr source) compiler:messages)))))))])
@ -793,7 +773,6 @@
; analyze top level expressions, cataloguing local variables
(compiler:init-define-lists!)
(const:reset-syntax-constants!)
(let ([bnorm-thunk
(lambda ()
(let-values ([(new-source new-codes max-arity)
@ -803,20 +782,18 @@
(set-block-codes! s:file-block new-codes)
(block:register-max-arity! s:file-block max-arity)
(s:register-max-arity! max-arity))
; take constant construction code and place it in front of the
; previously generated code. True constants first.
;; take constant construction code and place it in front of the
;; previously generated code. True constants first.
(set! number-of-true-constants (length (compiler:get-define-list)))
(set! number-of-per-load-constants (+ (length (compiler:get-per-load-define-list))
(length (compiler:get-per-invoke-define-list))))
(set! number-of-per-load-constants (+ (length (compiler:get-per-load-define-list))))
(s:append-block-sources! s:file-block
(append
(compiler:get-define-list)
(compiler:get-per-load-define-list)
(compiler:get-per-invoke-define-list))))])
(compiler:get-per-load-define-list))))])
(verbose-time bnorm-thunk))
(compiler:report-messages! #t)
; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block))
;;-----------------------------------------------------------------------
@ -833,7 +810,7 @@
(compiler:report-messages! #t)
; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block))
;;-----------------------------------------------------------------------
;; Closure conversion and explicit control transformation
;;
@ -847,7 +824,7 @@
s:file-block
(map closure-expression! (block-source s:file-block))))])
(verbose-time closure-thunk))
;;-----------------------------------------------------------------------
;; Vehicle assignment
;;
@ -928,7 +905,8 @@
; top-level. The last expression will be in tail position and should
; return its value
(let loop ([s (block-source s:file-block)]
[l (block-codes s:file-block)])
[l (block-codes s:file-block)]
[m (block-magics s:file-block)])
(unless (null? s)
(let-values ([(vm new-locals)
(vm-phase (car s)
@ -938,15 +916,18 @@
(lambda (ast)
(make-vm:return
(zodiac:zodiac-stx ast)
ast))
ast
(and (car m) #t)))
(lambda (ast)
(make-vm:void
(zodiac:zodiac-stx ast)
ast)))
(null? (cdr s)))])
ast
(and (car m) #t))))
(null? (cdr s))
(and (car m) #t))])
(set-car! s vm)
(add-code-local+used-vars! (car l) new-locals))
(loop (cdr s) (cdr l))))
(loop (cdr s) (cdr l) (cdr m))))
; code-bodies
(for-each
(lambda (L)
@ -954,7 +935,8 @@
[tail-pos (lambda (ast)
(make-vm:return
(zodiac:zodiac-stx ast)
ast))]
ast
#f))]
[new-locals
(cond
[(zodiac:case-lambda-form? L)
@ -968,7 +950,7 @@
; empty: already added via case
empty-set)
(let-values ([(vm new-locals)
(vm-phase (car l) #t #f tail-pos #t)])
(vm-phase (car l) #t #f tail-pos #t #f)])
(add-code-local+used-vars!
(car case-codes)
new-locals )
@ -1083,11 +1065,24 @@
(fprintf c-port "#include \"mzc.h\"~n~n")
(vm->c:emit-struct-definitions! (compiler:get-structs) c-port)
(vm->c:emit-symbol-declarations! c-port)
(vm->c:emit-syntax-string-declarations! c-port)
(vm->c:emit-inexact-declarations! c-port)
(vm->c:emit-string-declarations! c-port)
(vm->c:emit-prim-ref-declarations! c-port)
(vm->c:emit-static-declarations! c-port)
(let loop ([c 0][l (block-bytecodes s:file-block)][m (block-magics s:file-block)])
(cond
[(null? l) (void)]
[(not (car l)) (loop c (cdr l) (cdr m))]
[else
(vm->c:emit-bytecode-string-definition!
(format "top_level_bytecode_~a" c)
(car l)
c-port)
(fprintf c-port "#define top_level_magic_sym_~a ~s\n\n"
c
(symbol->string (car m)))
(loop (add1 c) (cdr l) (cdr m))]))
(let loop ([n 0])
(unless (= n (compiler:get-total-vehicles))
@ -1100,10 +1095,6 @@
(vm->c:emit-symbol-definitions! c-port)
(fprintf c-port "}~n"))
(fprintf c-port "~nstatic void make_syntax_strings()~n{~n")
(vm->c:emit-syntax-string-definitions! c-port)
(fprintf c-port "}~n")
(unless (zero? (const:get-inexact-counter))
(fprintf c-port "~nstatic void make_inexacts()~n{~n")
(vm->c:emit-inexact-definitions! c-port)
@ -1135,31 +1126,6 @@
(block-max-arity s:file-block)
#f #f ; no module entries
c-port))]
[invoke-counts
(let loop ([i 0])
(if (= i (get-num-module-invokes))
null
(cons
(let loop ([syntax? #f])
(cons
(vm->c:emit-top-levels! (format "module~a_body_~a"
(if syntax? "_syntax" "")
i)
#f #f #f -1
(block-source s:file-block)
locals
globals
(block-max-arity s:file-block)
i syntax?
c-port)
(if syntax?
null
(loop #t))))
(loop (add1 i)))))]
[_ (let loop ([i 0][counts invoke-counts])
(unless (= i (get-num-module-invokes))
(vm->c:emit-module-glue! c-port i (caar counts) (cadar counts))
(loop (add1 i) (cdr counts))))]
[top-level-count
(vm->c:emit-top-levels! "top_level" #t #t #f -1
(list-tail (block-source s:file-block) number-of-true-constants)
@ -1198,8 +1164,6 @@
(unless (compiler:multi-o-constant-pool)
(fprintf c-port "~amake_symbols();~n"
vm->c:indent-spaces))
(fprintf c-port "~amake_syntax_strings();~n"
vm->c:indent-spaces)
(unless (zero? (const:get-inexact-counter))
(fprintf c-port "~amake_inexacts();~n"
vm->c:indent-spaces))
@ -1296,7 +1260,8 @@
code
c-port
(* (if suffix? 3 2) vm->c:indent-by)
#f)
#f
-1)
(vm->c:emit-case-epilogue L i undefines indent c-port)
(when suffix?
(fprintf c-port "~a~a} /* end case ~a */~n"

33
collects/compiler/private/known.ss
View File

@ -199,6 +199,11 @@
[(zodiac:case-lambda-form? fun) (simple-case-lambda? fun)]
[else #f])))))]
[(zodiac:global-prepare? v) #t]
[(zodiac:global-lookup? v) #f]
[(zodiac:global-assign? v) #f]
[(zodiac:safe-vector-ref? v) #t]
[else #f])))
;; extract-ast-known-value tries to extract a useful value from a known-value AST
@ -544,14 +549,30 @@
ast]
;;-----------------------------------------------------------
;; MODULE
;; GLOBALS
;;
[(zodiac:module-form? ast)
(zodiac:set-module-form-body!
[(zodiac:global-prepare? ast)
(zodiac:set-global-prepare-vec!
ast
(analyze! (zodiac:module-form-body ast)))
(analyze! (zodiac:global-prepare-vec ast)))
ast]
[(zodiac:global-lookup? ast)
(zodiac:set-global-lookup-vec!
ast
(analyze! (zodiac:global-lookup-vec ast)))
ast]
[(zodiac:global-assign? ast)
(zodiac:set-global-assign-vec!
ast
(analyze! (zodiac:global-assign-vec ast)))
(zodiac:set-global-assign-expr!
ast
(analyze! (zodiac:global-assign-expr ast)))
ast]
[(zodiac:safe-vector-ref? ast)
(zodiac:set-safe-vector-ref-vec!
ast
(analyze! (zodiac:safe-vector-ref-vec ast)))
ast]

62
collects/compiler/private/lift.ss
View File

@ -75,7 +75,7 @@
;; LAMBDA EXPRESSIONS
;;
[(zodiac:case-lambda-form? ast)
(set! procedures (cons (cons ast (varref:current-invoke-module )) procedures))
(set! procedures (cons (cons ast #f) procedures))
(for-each find! (zodiac:case-lambda-form-bodies ast))]
;;--------------------------------------------------------------
@ -158,12 +158,17 @@
(find! (zodiac:with-continuation-mark-form-body ast))]
;;-----------------------------------------------------------
;; MODULE
;; GLOBALS
;;
[(zodiac:module-form? ast)
(parameterize ([varref:current-invoke-module
(module-info-invoke (get-annotation ast))])
(find! (zodiac:module-form-body ast)))]
[(zodiac:global-prepare? ast)
(find! (zodiac:global-prepare-vec ast))]
[(zodiac:global-lookup? ast)
(find! (zodiac:global-lookup-vec ast))]
[(zodiac:global-assign? ast)
(find! (zodiac:global-assign-vec ast))
(find! (zodiac:global-assign-expr ast))]
[(zodiac:safe-vector-ref? ast)
(find! (zodiac:safe-vector-ref-vec ast))]
[else (compiler:internal-error
ast
@ -297,8 +302,7 @@
(remove-code-free-vars! code (make-singleton-set
(zodiac:bound-varref-binding ast))))
(when (top-level-varref/bind-from-lift-pls? lifted)
(add-global! (or (varref:current-invoke-module)
const:the-per-load-statics-table)))
(add-global! const:the-per-load-statics-table))
lifted)
;; No change
@ -314,8 +318,6 @@
(void)]
[(varref:has-attribute? ast varref:per-load-static)
(add-global! const:the-per-load-statics-table)]
[(varref:has-attribute? ast varref:per-invoke-static)
(add-global! (varref:invoke-module ast))]
[(varref:has-attribute? ast varref:static)
(void)]
[else (add-global! (compiler:add-global-varref! ast))])
@ -365,8 +367,7 @@
(if (top-level-varref/bind-from-lift-pls? lifted)
(set! globals (set-union-singleton
save-globals
(or (varref:current-invoke-module)
const:the-per-load-statics-table)))
const:the-per-load-statics-table))
(set! globals save-globals))
lifted))))]
@ -552,15 +553,30 @@
ast]
;;-----------------------------------------------------------
;; MODULE
;; GLOBALS
;;
[(zodiac:module-form? ast)
(parameterize ([varref:current-invoke-module (module-info-invoke (get-annotation ast))])
(zodiac:set-module-form-body!
ast
(lift! (zodiac:module-form-body ast) code)))
[(zodiac:global-prepare? ast)
(zodiac:set-global-prepare-vec!
ast
(lift! (zodiac:global-prepare-vec ast) code))
ast]
[(zodiac:global-lookup? ast)
(zodiac:set-global-lookup-vec!
ast
(lift! (zodiac:global-lookup-vec ast) code))
ast]
[(zodiac:global-assign? ast)
(zodiac:set-global-assign-vec!
ast
(lift! (zodiac:global-assign-vec ast) code))
(zodiac:set-global-assign-expr!
ast
(lift! (zodiac:global-assign-expr ast) code))
ast]
[(zodiac:safe-vector-ref? ast)
(zodiac:set-safe-vector-ref-vec!
ast
(lift! (zodiac:safe-vector-ref-vec ast) code))
ast]
[else (compiler:internal-error
@ -596,10 +612,8 @@
;; Set liftable flags
(for-each (lambda (l)
(let ([l (car l)]
[mi (cdr l)])
(parameterize ([varref:current-invoke-module mi])
(set-liftable! l))))
(let ([l (car l)])
(set-liftable! l)))
procedures)
(set! globals empty-set)

37
collects/compiler/private/prephase.ss
View File

@ -654,24 +654,31 @@
ast]
;;-----------------------------------------------------------
;; MODULE
;; GLOBALS
;;
[(zodiac:module-form? ast)
(let-values ([(mi smi) (make-module-invokes
(zodiac:module-form-self-path-index ast))])
(set-annotation! ast (make-module-info mi smi #f)))
(zodiac:set-module-form-body!
[(zodiac:global-prepare? ast)
(zodiac:set-global-prepare-vec!
ast
(prephase! (zodiac:module-form-body ast)
#t #f #f))
(zodiac:set-module-form-syntax-body!
ast
(prephase! (zodiac:module-form-syntax-body ast)
#t #f #f))
(prephase! (zodiac:global-prepare-vec ast) in-mod? #t #f))
ast]
[(zodiac:global-lookup? ast)
(zodiac:set-global-lookup-vec!
ast
(prephase! (zodiac:global-lookup-vec ast) in-mod? #t #f))
ast]
[(zodiac:global-assign? ast)
(zodiac:set-global-assign-vec!
ast
(prephase! (zodiac:global-assign-vec ast) in-mod? #t #f))
(zodiac:set-global-assign-expr!
ast
(prephase! (zodiac:global-assign-expr ast) in-mod? #t #f))
ast]
[(zodiac:safe-vector-ref? ast)
(zodiac:set-safe-vector-ref-vec!
ast
(prephase! (zodiac:safe-vector-ref-vec ast) in-mod? #t #f))
ast]
;;-----------------------------------------------------------
;; Unsupported forms

21
collects/compiler/private/rep.ss
View File

@ -45,7 +45,6 @@
;; 'scheme-object
;; 'scheme-bucket
;; 'scheme-per-load-static
;; 'scheme-per-invoke-static
;; 'label
;; 'prim
;; 'prim-case
@ -55,8 +54,6 @@
(define-struct rep:struct (name orig-name fields))
(define-struct rep:struct-field (name orig-name rep))
(define-struct (rep:atomic/invoke rep:atomic) (module-invoke))
(define (rep:same-shape? a b)
(let ([al (rep:struct-fields a)]
[bl (rep:struct-fields b)])
@ -67,10 +64,7 @@
(or (and (rep:atomic? ar)
(rep:atomic? br)
(eq? (rep:atomic-type ar)
(rep:atomic-type br))
(or (not (rep:atomic/invoke? ar))
(eq? (rep:atomic/invoke-module-invoke ar)
(rep:atomic/invoke-module-invoke br))))
(rep:atomic-type br)))
(and (rep:struct? ar)
(rep:struct? br)
(eq? (rep:struct-name ar)
@ -181,21 +175,14 @@
;; field-name
(if (const:per-load-statics-table? global)
'pls
(if (varref:module-invoke? global)
'pmis
#f))
(if (or (const:per-load-statics-table? global)
(varref:module-invoke? global))
#f)
(if (const:per-load-statics-table? global)
global
(mod-glob-cname global))
;; field-type
(if (const:per-load-statics-table? global)
(make-rep:atomic 'scheme-per-load-static)
(if (varref:module-invoke? global)
(make-rep:atomic/invoke
'scheme-per-invoke-static
global)
(make-rep:atomic 'scheme-bucket)))))
(make-rep:atomic 'scheme-bucket))))
(set->list (code-global-vars code))))])
(if (null? fields)
#f ; empty structure - don't use anything

52
collects/compiler/private/sig.ss
View File

@ -57,11 +57,9 @@
(varref:empty-attributes
varref:add-attribute!
varref:has-attribute?
varref:invoke-module
varref:static
varref:per-load-static
varref:per-invoke-static
varref:primitive
varref:symbol
varref:inexact
@ -69,13 +67,6 @@
varref:in-module
varref:module-stx-string
(struct varref:module-invoke (id syntax? context-path-index))
make-module-invokes
get-num-module-invokes
is-module-invoke?
varref:reset-module-id!
(struct compiler:make-closure (lambda free-vars args name))
(struct binding (rec? ; part of a letrec recursive binding set
@ -106,10 +97,6 @@
(struct app (tail? prim? prim-name))
(struct module-info (invoke syntax-invoke part))
varref:current-invoke-module
compiler:bound-varref->binding
(struct c-lambda (function-name scheme-name body arity))
@ -191,21 +178,11 @@
compiler:get-static-list
compiler:get-per-load-static-list
compiler:get-per-invoke-static-list
compiler:add-per-load-static-list!
compiler:add-per-invoke-static-list!
compiler:make-const-constructor
const:make-syntax-constant
const:reset-syntax-constants!
const:finish-syntax-constants!
(struct syntax-string (str mi uposes ustart id))
const:get-syntax-strings
(struct compiled-string (id len))))
(provide compiler:rep^)
@ -215,8 +192,6 @@
(struct rep:struct (name orig-name fields))
(struct rep:struct-field (name orig-name rep))
(struct rep:atomic/invoke (module-invoke))
compiler:get-structs
compiler:init-structs!
@ -239,7 +214,6 @@
compiler:get-define-list
compiler:get-per-load-define-list
compiler:get-per-invoke-define-list
compiler:init-define-lists!
@ -248,15 +222,12 @@
compiler:add-local-define-list!
compiler:add-local-per-load-define-list!
compiler:add-local-per-invoke-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
compiler:finish-syntax-constants!
analyze-expression!))
(provide compiler:lift^)
@ -303,29 +274,33 @@
(define-signature compiler:vmstructs^
((struct vm:sequence (vals))
(struct vm:if (test then else))
(struct vm:module-body (vals invoke syntax?))
(struct vm:void (val))
(struct vm:return (val))
(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? prim vals))
(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? bool?))
(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))
@ -339,16 +314,13 @@
(struct vm:global-varref (var))
(struct vm:bucket (var))
(struct vm:per-load-statics-table ())
(struct vm:per-invoke-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-invoke-static-varref ())
(struct vm:per-load-static-varref-from-lift (lambda))
(struct vm:per-invoke-static-varref-from-lift (lambda))
(struct vm:primitive-varref (var))
(struct vm:symbol-varref (var))
(struct vm:inexact-varref (var))
@ -408,7 +380,7 @@
(provide compiler:top-level^)
(define-signature compiler:top-level^
((struct block (source codes max-arity))
((struct block (source codes bytecodes magics max-arity))
make-empty-block
block:register-max-arity!
@ -427,8 +399,7 @@
vm->c:emit-symbol-list!
vm->c:emit-symbol-declarations!
vm->c:emit-symbol-definitions!
vm->c:emit-syntax-string-declarations!
vm->c:emit-syntax-string-definitions!
vm->c:emit-bytecode-string-definition!
vm->c:emit-inexact-declarations!
vm->c:emit-inexact-definitions!
vm->c:emit-string-declarations!
@ -439,7 +410,6 @@
vm->c:emit-registration!
vm->c:emit-case-arities-definitions!
vm->c:emit-top-levels!
vm->c:emit-module-glue!
vm->c:emit-vehicle-prototype
vm->c:emit-vehicle-declaration
vm->c:emit-vehicle-header

371
collects/compiler/private/to-core.ss Normal file
View File

@ -0,0 +1,371 @@
(module to-core mzscheme
(require (lib "kerncase.ss" "syntax")
(lib "stx.ss" "syntax")
(lib "list.ss")
(lib "boundmap.ss" "syntax"))
(provide top-level-to-core)
(define (top-level-to-core stx lookup-stx set-stx safe-vector-ref-stx extract-stx)
(syntax-case stx (module begin)
[(module m lang (plain-module-begin decl ...))
(let-values ([(expr new-decls magic-sym)
(lift-sequence (flatten-decls (syntax->list #'(decl ...)))
lookup-stx set-stx safe-vector-ref-stx extract-stx
#t)])
(values (expand-syntax expr)
#`(module m lang (#%plain-module-begin #,@new-decls))
magic-sym))]
[(begin decl ...)
(let-values ([(expr new-decls magic-sym)
(lift-sequence (flatten-decls (syntax->list #'(decl ...)))
lookup-stx set-stx safe-vector-ref-stx extract-stx
#f)])
(values (expand-syntax expr)
#`(begin #,@new-decls)
magic-sym))]
[else
(top-level-to-core #`(begin #,stx) lookup-stx set-stx safe-vector-ref-stx extract-stx)]))
(define (flatten-decls l)
(apply append
(map (lambda (stx)
(syntax-case stx (begin)
[(begin . e)
(flatten-decls (syntax->list #'e))]
[else (list stx)]))
l)))
(define-struct lifted-info (counter id-map slot-map))
(define (make-vars)
(make-lifted-info
0
(make-module-identifier-mapping)
(make-hash-table 'equal)))
(define (is-id-ref? v)
(or (identifier? v)
(and (stx-pair? v)
(identifier? (stx-car v))
(module-identifier=? #'#%top (stx-car v)))))
(define (vars-sequence li)
(let loop ([i 0])
(if (= i (lifted-info-counter li))
null
(cons (let ([v (hash-table-get (lifted-info-slot-map li) i)])
(if (is-id-ref? v)
#`(#%variable-reference #,v)
v))
(loop (add1 i))))))
(define (extract-vars li vec-id extract-stx)
(let loop ([i 0])
(if (= i (lifted-info-counter li))
null
(let ([v (hash-table-get (lifted-info-slot-map li) i)])
(if (is-id-ref? v)
(cons #`(#,extract-stx #,vec-id #,i)
(loop (add1 i)))
(loop (add1 i)))))))
(define (is-run-time? stx)
(not (and (stx-pair? stx)
(or (module-identifier=? #'define-syntaxes (stx-car stx))
(module-identifier=? #'define-values-for-syntax (stx-car stx))))))
(define (has-symbol? decl magic-sym table)
(cond
[(hash-table-get table decl (lambda () #f))
;; cycle/graph
#f]
[else
(hash-table-put! table decl #t)
(cond
[(eq? magic-sym decl)
#t]
[(pair? decl)
(or (has-symbol? (car decl) magic-sym table)
(has-symbol? (cdr decl) magic-sym table))]
[(vector? decl)
(has-symbol? (vector->list decl) magic-sym table)]
[(box? decl)
(has-symbol? (unbox decl) magic-sym table)]
[else
#f])]))
(define (generate-magic decls)
(let ([magic-sym (string->symbol (format "magic~a~a"
(current-seconds)
(current-milliseconds)))])
(if (has-symbol? (map syntax-object->datum decls) magic-sym (make-hash-table))
(generate-magic decls)
magic-sym)))
(define (lift-sequence decls lookup-stx set-stx safe-vector-ref-stx extract-stx in-module?)
(let ([ct-vars (make-vars)]
[rt-vars (make-vars)]
[compile-time (datum->syntax-object #f (gensym 'compile-time))]
[run-time (datum->syntax-object #f (gensym 'run-time))]
[magic-sym (generate-magic decls)]
[magic-indirect (gensym)])
(let ([ct-converted
(map (lambda (stx)
#`(lambda ()
#,(syntax-case stx ()
[(def ids rhs)
(let ([cvted (convert #'rhs #t
lookup-stx set-stx safe-vector-ref-stx
compile-time ct-vars
in-module?)])
(if (and (not in-module?)
(module-identifier=? #'def #'define-syntaxes))
;; Don't try to name macro procedures, because it
;; inteferes with the 0-values hack at the top level
cvted
#`(let-values ([ids #,cvted])
(values . ids))))])))
(filter (lambda (x) (not (is-run-time? x))) decls))]
[rt-converted
(map (lambda (stx)
#`(lambda ()
#,(syntax-case stx (define-values provide require require-for-syntax require-for-template)
[(provide . _)
#'(void)]
[(require . _)
#'(void)]
[(require-for-syntax . _)
#'(void)]
[(require-for-template . _)
#'(void)]
[(define-values ids rhs)
#`(let-values ([ids
#,(convert #'rhs #f
lookup-stx set-stx safe-vector-ref-stx
run-time rt-vars
in-module?)])
(values . ids))]
[else
(convert stx #f
lookup-stx set-stx safe-vector-ref-stx
run-time rt-vars
in-module?)])))
(filter is-run-time? decls))]
[ct-rhs #`((let ([magic (car (cons '#,magic-sym 2))])
(if (symbol? magic)
(lambda (x) (make-vector #,(length decls) void))
(car magic)))
(vector #,@(vars-sequence ct-vars)))]
[rt-rhs #`((cdr '#,magic-sym) (vector #,@(vars-sequence rt-vars)))]
[just-one-ct? (>= 1 (apply +
(map (lambda (decl)
(syntax-case decl (define-syntaxes define-values-for-syntax)
[(define-values-for-syntax . _) 1]
[(define-syntaxes . _) 1]
[_else 0]))
decls)))]
[just-one-rt? (>= 1 (apply +
(map (lambda (decl)
(syntax-case decl (define-values provide require
require-for-syntax require-for-template
define-syntaxes define-values-for-syntax)
[(provide . _) 0]
[(require . _) 0]
[(require-for-syntax . _) 0]
[(define-values-for-syntax . _) 0]
[(define-syntaxes . _) 0]
[_else 1]))
decls)))])
(values
#`(cons (lambda (#,compile-time)
#,@(extract-vars ct-vars compile-time extract-stx)
(vector #,@ct-converted))
(lambda (#,run-time)
#,@(extract-vars rt-vars run-time extract-stx)
(vector #,@rt-converted)))
#`(;; Lift define-for-values binding to front, so they can be referenced
;; in compile-time definition
#,@(let ([ids (apply
append
(map (lambda (stx)
(syntax-case stx (define-values-for-syntax)
[(define-values-for-syntax ids . _)
(syntax->list #'ids)]
[_else null]))
decls))])
(if (null? ids)
null
#`((define-values-for-syntax #,ids
(values #,@(map (lambda (x) #'#f) ids))))))
#,@(if just-one-ct?
null
#`((define-values-for-syntax (#,compile-time) #,ct-rhs)))
#,@(if just-one-rt?
null
#`((define-values (#,run-time) #,rt-rhs)))
#,@(let loop ([decls decls][ct-pos 0][rt-pos 0])
(cond
[(null? decls) null]
[(is-run-time? (car decls))
(cons (syntax-case (car decls) (define-values provide require require-for-syntax require-for-template)
[(provide . _)
(car decls)]
[(require . _)
(car decls)]
[(require-for-syntax . _)
(car decls)]
[(require-for-template . _)
(car decls)]
[(define-values (id ...) rhs)
#`(define-values (id ...)
((vector-ref #,(if just-one-rt? rt-rhs run-time) #,rt-pos)))]
[else
#`((vector-ref #,(if just-one-rt? rt-rhs run-time) #,rt-pos))])
(loop (cdr decls) ct-pos (add1 rt-pos)))]
[else
(cons (syntax-case (car decls) (define-syntaxes define-values-for-syntax)
[(define-syntaxes (id ...) . rhs)
#`(define-syntaxes (id ...)
((vector-ref #,(if just-one-ct? ct-rhs compile-time) #,ct-pos)))]
[(define-values-for-syntax (id ...) . rhs)
#`(define-values-for-syntax ()
(begin
(set!-values (id ...) ((vector-ref #,(if just-one-ct? ct-rhs compile-time) #,ct-pos)))
(values)))])
(loop (cdr decls) (add1 ct-pos) rt-pos))])))
magic-sym))))
(define (local-identifier? stx trans?)
(eq? 'lexical ((if trans?
identifier-transformer-binding
identifier-binding)
stx)))
(define (simple-identifier stx trans?)
(let ([b ((if trans?
identifier-transformer-binding
identifier-binding)
stx)])
(cond
[(eq? b 'lexical) stx]
[(and (pair? b)
(eq? '#%kernel (car b)))
;; Generate a syntax object that has the right run-time binding:
(datum->syntax-object #'here (cadr b) stx stx)]
[else #f])))
(define (simple-constant? s)
(or (identifier? s)
(number? (syntax-e s))
(empty? (syntax-e s))
(memq (syntax-e s) '(#t #f))))
(define (add-literal/pos stx li)
(let ([pos (lifted-info-counter li)])
(hash-table-put! (lifted-info-slot-map li) pos stx)
(set-lifted-info-counter! li (add1 pos))
pos))
(define (add-literal stx li safe-vector-ref-stx id)
#`(#,safe-vector-ref-stx #,id #,(add-literal/pos stx li)))
(define (add-identifier/pos stx li trans?)
(if (identifier? stx)
;; id :
(or (module-identifier-mapping-get (lifted-info-id-map li)
stx
(lambda () #f))
(let ([pos (add-literal/pos (if (not ((if trans?
identifier-transformer-binding
identifier-binding)
stx))
#`(#%top . #,stx)
stx)
li)])
(module-identifier-mapping-put! (lifted-info-id-map li) stx pos)
pos))
;; (#%top . id) :
(add-literal/pos stx li)))
(define (add-identifier stx li trans? lookup-stx id)
#`(#,lookup-stx #,id #,(add-identifier/pos stx li trans?)))
(define (convert stx trans? lookup-stx set-stx safe-vector-ref-stx id li in-module?)
(define ((loop certs) stx)
(let ([loop (loop (apply-certs stx certs))])
(kernel-syntax-case stx trans?
[_
(identifier? stx)
(or (simple-identifier stx trans?)
(add-identifier (apply-certs certs stx) li trans? lookup-stx id))]
[(provide . _)
stx]
[(lambda formals e ...)
(quasisyntax/loc stx
(lambda formals #,@(map loop (syntax->list #'(e ...)))))]
[(case-lambda [formals e ...] ...)
(with-syntax ([((e ...) ...)
(map (lambda (l)
(map loop (syntax->list l)))
(syntax->list #'((e ...) ...)))])
(quasisyntax/loc stx
(case-lambda [formals e ...] ...)))]
[(let-values ([(id ...) rhs] ...) e ...)
(with-syntax ([(rhs ...)
(map loop (syntax->list #'(rhs ...)))])
(quasisyntax/loc stx
(let-values ([(id ...) rhs] ...) #,@(map loop (syntax->list #'(e ...))))))]
[(letrec-values ([(id ...) rhs] ...) e ...)
(with-syntax ([(rhs ...)
(map loop (syntax->list #'(rhs ...)))])
(quasisyntax/loc stx
(letrec-values ([(id ...) rhs] ...) #,@(map loop (syntax->list #'(e ...))))))]
[(quote e)
(if (simple-constant? #'e)
#'(quote e)
(add-literal stx li safe-vector-ref-stx id))]
[(quote-syntax e)
(add-literal stx li safe-vector-ref-stx id)]
[(#%top . tid)
(let ([target (let ([b ((if trans?
identifier-transformer-binding
identifier-binding)
#'tid)])
(if (or (eq? b 'lexical)
(and (not in-module?)
b))
#`(#%top . tid)
#'tid))])
(add-identifier (apply-certs certs target) li trans? lookup-stx id))]
[(#%datum . e)
(if (simple-constant? #'e)
#'(#%datum . e)
(add-literal stx li safe-vector-ref-stx id))]
[(set! x e)
(if (local-identifier? #'x trans?)
(quasisyntax/loc stx (set! x #,(loop #'e)))
(quasisyntax/loc stx
(#,set-stx #,id #,(add-identifier/pos (apply-certs certs #'x) li trans?) #,(loop #'e))))]
#;
[(#%variable-reference e)
(add-literal stx li)]
[(if e ...)
(quasisyntax/loc stx
(if #,@(map loop (syntax->list #'(e ...)))))]
[(begin e ...)
(quasisyntax/loc stx
(begin #,@(map loop (syntax->list #'(e ...)))))]
[(begin0 e ...)
(quasisyntax/loc stx
(begin0 #,@(map loop (syntax->list #'(e ...)))))]
[(with-continuation-mark e ...)
(quasisyntax/loc stx
(with-continuation-mark #,@(map loop (syntax->list #'(e ...)))))]
[(#%app e ...)
(quasisyntax/loc stx
(#%app #,@(map loop (syntax->list #'(e ...)))))])))
((loop #'certs) stx))
(define (apply-certs from to)
(syntax-recertify to from (current-code-inspector) #f)))

4
collects/compiler/private/toplevel.ss
View File

@ -21,8 +21,10 @@
;;
(define-struct block (source ; list of top-level ASTs
codes ; list of `code' structures (in parallel with source)
bytecodes ; list of S-exps in parallel
magics ; list of symbols in parallel
max-arity))
(define make-empty-block (lambda () (make-block null null 0)))
(define make-empty-block (lambda () (make-block null null null null 0)))
(define block:register-max-arity!
(lambda (b n)

6
collects/compiler/private/vehicle.ss
View File

@ -221,12 +221,6 @@
[(zodiac:with-continuation-mark-form? ast)
(relate! current-lambda (zodiac:with-continuation-mark-form-body ast))]
;;-----------------------------------------------------------
;; MODULE
;;
[(zodiac:module-form? ast)
(relate! current-lambda (zodiac:module-form-body ast))]
;;-----------------------------------------------------------------
;; APPLICATIONS
;;

316
collects/compiler/private/vm2c.ss
View File

@ -122,17 +122,13 @@
(vm->c:SYMBOLS-name)
(const:get-symbol-counter))))
(define (vm->c:emit-syntax-string-declarations! port)
(let ([l (const:get-syntax-strings)])
(unless (null? l)
(fprintf port "static Scheme_Object *SS[~a];~n~n" (length l))
(for-each
(lambda (ss)
(emit-string port
"char"
(syntax-string-str ss)
(format "SYNTAX_STRING_~a" (syntax-string-id ss))))
l))))
(define (vm->c:emit-bytecode-string-definition! name bytecode port)
(emit-string port
"char"
(let ([p (open-output-bytes)])
(display bytecode p)
(get-output-bytes p))
name))
(define (vm->c:emit-inexact-list! port comma comment?)
(vm->c:emit-list! port comma comment? (const:get-inexact-table) (const:get-inexact-counter)
@ -199,23 +195,6 @@
(fprintf port " SYMBOLS[~a] = scheme_make_exact_symbol(SYMBOL_STRS[~a], SYMBOL_LENS[~a]); /* uninterned */~n"
pos pos pos)))))))
(define (vm->c:emit-syntax-string-definitions! port)
(let ([l (const:get-syntax-strings)])
(unless (null? l)
(for-each
(lambda (ss)
(let ([id (syntax-string-id ss)]
[symbols (vm->c:SYMBOLS-name)])
(fprintf port " SS[~a] = scheme_load_compiled_stx_string(SYNTAX_STRING_~a, ~a);~n"
id id (bytes-length (syntax-string-str ss)))
;; Reset uninterned symbols:
(let loop ([uposes (syntax-string-uposes ss)][i (syntax-string-ustart ss)])
(unless (null? uposes)
(fprintf port " ~a[~a] = scheme_compiled_stx_symbol(SCHEME_VEC_ELS(SS[~a])[~a]);~n"
symbols (car uposes) id i)
(loop (cdr uposes) (add1 i))))))
l))))
(define (vm->c:emit-inexact-definitions! port)
(unless (zero? (const:get-inexact-counter))
(fprintf port " int i;~n")
@ -309,44 +288,7 @@
(fprintf port " int dummy;~n")
(emit-static-variable-fields! port (compiler:get-per-load-static-list)))
(fprintf port "} Scheme_Per_Load_Statics;~n")
(newline port)
(let ([ht (make-hash-table)])
;; Gather per-invoke statics with the same invoke id
(let ([l (compiler:get-per-invoke-static-list)])
(for-each (lambda (p)
(let ([mi (cdr p)]
[var (car p)])
(hash-table-put! ht (varref:module-invoke-id mi)
(cons (cons var (varref:module-invoke-syntax? mi))
(hash-table-get
ht
(varref:module-invoke-id mi)
(lambda () null))))))
l)
;; Make sure that every module has a struct:
(let loop ([i 0])
(unless (= i (get-num-module-invokes))
(hash-table-get ht i (lambda ()
(hash-table-put! ht i null)))
(loop (add1 i))))
(hash-table-for-each
ht
(lambda (id vars)
(fprintf port "/* compiler-written per-invoke variables for module ~a */~n" id)
(let ([vars (map car (filter (lambda (i) (not (cdr i))) vars))]
[syntax-vars (map car (filter (lambda (i) (cdr i)) vars))])
(fprintf port "typedef struct Scheme_Per_Invoke_Statics_~a {~n" id)
(if (null? vars)
(fprintf port " int dummy;~n")
(emit-static-variable-fields! port vars))
(fprintf port "} Scheme_Per_Invoke_Statics_~a;~n" id)
(fprintf port "typedef struct Scheme_Per_Invoke_Syntax_Statics_~a {~n" id)
(if (null? syntax-vars)
(fprintf port " int dummy;~n")
(emit-static-variable-fields! port syntax-vars))
(fprintf port "} Scheme_Per_Invoke_Syntax_Statics_~a;~n" id)
(newline port))))))))
(newline port)))
;; when statics have binding information, this need only register
;; pointer declarations
@ -365,9 +307,7 @@
(unless (set-empty? (compiler:get-primitive-refs))
(register "P"))
(unless (not (compiler:any-statics?))
(register "S"))
(unless (null? (const:get-syntax-strings))
(register "SS")))
(register "S")))
(newline port)))
(define (vm->c:emit-case-arities-definitions! port)
@ -397,7 +337,7 @@
(fprintf port "~a}~n" vm->c:indent-spaces))))
(caloop (cdr l) (add1 pos)))))
(define (vm->c:emit-top-levels! kind return? per-load? null-self-modidx? count vm-list locals-list
(define (vm->c:emit-top-levels! kind return? per-load? null-self-modidx? count vm-list locals-list
globals-list max-arity module mod-syntax? c-port)
;; count == -1 => go to the end of the list
(let tls-loop ([i 0]
@ -406,24 +346,16 @@
[ll locals-list]
[bl globals-list])
(fprintf c-port
"static ~a ~a_~a(Scheme_Env * env~a~a)~n{~n"
"static ~a ~a_~a(Scheme_Env * env~a)~n{~n"
(if return? "Scheme_Object *" "void")
kind i
(if (or per-load? module) ", Scheme_Per_Load_Statics *PLS" "")
(if module
(format
", long phase_shift, Scheme_Object *self_modidx, Scheme_Per_Invoke_~aStatics_~a *PMIS"
(if mod-syntax? "Syntax_" "")
module)
""))
(if (or per-load? module) ", Scheme_Per_Load_Statics *PLS" ""))
(when null-self-modidx? (fprintf c-port "#define self_modidx NULL~n"))
(when (> max-arity 0)
(fprintf c-port
"~aScheme_Object * arg[~a];~n"
vm->c:indent-spaces
max-arity)
(fprintf c-port "~aScheme_Thread * pr = scheme_current_thread;~n"
vm->c:indent-spaces)
(fprintf c-port "~aScheme_Object ** tail_buf;~n"
vm->c:indent-spaces))
(let loop ([c (compiler:option:max-exprs-per-top-level-set)][n n][vml vml][ll ll][bl bl])
@ -437,12 +369,7 @@
(if (or (null? vml) (= n count))
i
(tls-loop (add1 i) n vml ll bl)))
(if (not (or (and (not module)
(not (vm:module-body? (car vml))))
(and module
(vm:module-body? (car vml))
(is-module-invoke? (vm:module-body-invoke (car vml)) module)
(eq? (vm:module-body-syntax? (car vml)) mod-syntax?))))
(if module
(loop c n (cdr vml) (cdr ll) (cdr bl))
(begin
(let ([start (zodiac:zodiac-start (car vml))])
@ -463,33 +390,12 @@
(string-append vm->c:indent-spaces vm->c:indent-spaces)
c-port)
(vm->c-expression (car vml) #f c-port vm->c:indent-by #t)
(vm->c-expression (car vml) #f c-port vm->c:indent-by #t n)
(fprintf c-port "~a}~n" vm->c:indent-spaces)
(loop (sub1 c) (add1 n) (cdr vml) (cdr ll) (cdr bl))))))))
(define (vm->c:emit-module-glue! port id num num-syntax)
(define (out syntax? n)
(fprintf port "static void module_invoke~a_~a("
(if syntax? "_syntax" "") id)
(fprintf port "Scheme_Env *env, long phase_shift, Scheme_Object *self_modidx, void *pls)~n")
(fprintf port "{~n~aScheme_Per_Invoke_~aStatics_~a *PMIS;~n"
vm->c:indent-spaces (if syntax? "Syntax_" "") id)
(let ([s (format "Scheme_Per_Invoke_~aStatics_~a"
(if syntax? "Syntax_" "") id)])
(fprintf port "~aPMIS = (~a *)scheme_malloc(sizeof(~a));~n"
vm->c:indent-spaces s s))
(let loop ([j 0])
(unless (j . > . n)
(fprintf port "~amodule_~abody_~a_~a(env, (Scheme_Per_Load_Statics *)pls, phase_shift, self_modidx, PMIS);~n"
vm->c:indent-spaces (if syntax? "syntax_" "") id j)
(loop (add1 j))))
(fprintf port "}~n~n"))
(out #f num)
(out #t num-syntax))
(define vm->c:emit-vehicle-prototype
(lambda (port number)
(let ([v (get-vehicle number)])
@ -536,8 +442,6 @@
(loop (+ n 1)))))
(when (> max-arity 0)
; tail-buffer-setup
(fprintf port "~aScheme_Thread * pr = scheme_current_thread;~n"
vm->c:indent-spaces)
(fprintf port "~aScheme_Object ** tail_buf;~n"
vm->c:indent-spaces)))
@ -577,13 +481,6 @@
[(scheme-object) "Scheme_Object *"]
[(scheme-bucket) "Scheme_Bucket *"]
[(scheme-per-load-static) "struct Scheme_Per_Load_Statics *"]
[(scheme-per-invoke-static)
(let ([mi (rep:atomic/invoke-module-invoke rep)])
(format "struct Scheme_Per_Invoke_~aStatics_~a *"
(if (varref:module-invoke-syntax? mi)
"Syntax_"
"")
(varref:module-invoke-id mi)))]
[(label) "int"]
[(prim) "Scheme_Closed_Primitive_Proc"]
[(prim-case) "Scheme_Closed_Case_Primitive_Proc"]
@ -633,10 +530,6 @@
(unless top-level?
(fprintf port "~aScheme_Per_Load_Statics * PLS;~n"
indent))]
[(varref:module-invoke? var)
(unless top-level?
(fprintf port "~aScheme_Per_Invoke_Statics_~a * PMIS;~n"
indent (varref:module-invoke-id var)))]
[else
(fprintf port "~aScheme_Bucket * G~a;~n"
indent
@ -647,8 +540,7 @@
(lambda (globals indent port)
(for-each
(lambda (var)
(unless (or (const:per-load-statics-table? var)
(varref:module-invoke? var))
(unless (const:per-load-statics-table? var)
(let* ([name (vm->c:convert-symbol (mod-glob-cname var))]
[et? (mod-glob-exp-time? var)]
[ed? (mod-glob-exp-def? var)]
@ -673,7 +565,6 @@
"~a~a"
(cond
[(varref:has-attribute? modidx varref:per-load-static) "PLS->"]
[(varref:has-attribute? modidx varref:per-invoke-static) "PMIS->"]
[else "S."])
(vm->c:convert-symbol (zodiac:varref-var modidx))))
"")
@ -874,17 +765,6 @@
(if (compiler:option:unpack-environments)
undefines
(cons "PLS" undefines))))]
[(varref:module-invoke? var)
(begin
(fprintf port
(if (compiler:option:unpack-environments)
"~aPMIS = env->pmis;~n"
"#~adefine PMIS env->pmis~n")
indent)
(loop (cdr vars)
(if (compiler:option:unpack-environments)
undefines
(cons "PMIS" undefines))))]
[else
(let* ([vname (mod-glob-cname var)]
[name (vm->c:convert-symbol vname)]
@ -1038,7 +918,7 @@
(define vm->c:block-statement?
(one-of vm:if? vm:sequence? vm:module-body?))
(one-of vm:if? vm:sequence?))
(define vm->c:extract-inferred-name
(let ([nullsym (string->symbol "NULL")])
@ -1076,7 +956,7 @@
(one-of primitive? primitive-closure?))
(define vm->c-expression
(lambda (ast code port indent-level no-seq-braces?)
(lambda (ast code port indent-level no-seq-braces? top_level_n)
(let process ([ast ast] [indent-level indent-level] [own-line? #t] [braces? (not no-seq-braces?)])
(letrec ([emit-indentation (lambda () (display
(make-string indent-level #\ )
@ -1099,9 +979,8 @@
(cond
;; (%sequence V ...) -> { M; ... }
[(or (vm:sequence? ast)
(vm:module-body? ast))
(let* ([seq ((if (vm:sequence? ast) vm:sequence-vals vm:module-body-vals) ast)])
[(vm:sequence? ast)
(let* ([seq (vm:sequence-vals ast)])
(when braces? (emit-indentation) (emit "{~n"))
(for-each (lambda (v)
(process v (indent) #t #t)
@ -1153,6 +1032,8 @@
(emit-indentation)
(emit "if (~a.val == SCHEME_MULTIPLE_VALUES) {~n" var)
(emit-indentation)
(emit " Scheme_Thread *pr = scheme_current_thread;\n")
(emit-indentation)
(emit " ~a.array = pr->ku.multiple.array;~n" var)
(emit-indentation)
(emit " ~a.count = pr->ku.multiple.count;~n" var)
@ -1163,8 +1044,8 @@
[(vm:begin0-extract? ast)
(let ([var (vm->c:convert-symbol
(vm:local-varref-var (vm:begin0-extract-var ast)))])
(emit "(pr->ku.multiple.array = ~a.array," var)
(emit " pr->ku.multiple.count = ~a.count, " var)
(emit "(scheme_current_thread->ku.multiple.array = ~a.array," var)
(emit " scheme_current_thread->ku.multiple.count = ~a.count, " var)
(emit " ~a.val)" var))]
;; single value: (set! L R) -> L = R;
@ -1239,82 +1120,36 @@
(emit ";~n")
(aloop (cdr vars) (+ n 1))))
))))]
;; (define-syntax! x R) or (define-for-syntax! x R)
[(vm:syntax!? ast)
(let* ([process-set!
(lambda (target val process-val? return-arity-ok?)
(let ([sym
(vm->c:make-symbol-const-string
(compiler:get-symbol-const! #f (zodiac:varref-var target)))]
[in-module? (varref:has-attribute? target varref:in-module)])
(when process-val?
(emit "{ Scheme_Object *mcv = ")
(process val indent-level #f #t)
(emit "; "))
(unless return-arity-ok?
(emit " if (mcv != SCHEME_MULTIPLE_VALUES || scheme_multiple_count) {")
(emit " NO_MULTIPLE_VALUES(mcv); "))
(let ([for-stx? (zodiac:top-level-varref-expdef? target)])
(emit "scheme_~a(~ascheme_global_~abucket(~a, ~a), "
(if for-stx? "set_global_bucket" "install_macro")
(if for-stx? "NULL, " "")
(if for-stx? "" "keyword_")
sym
(if in-module? "env" "SCHEME_CURRENT_ENV(pr)"))
(if process-val?
(emit "mcv")
(emit val))
(when for-stx?
(emit ", 1"))
(emit ")"))
(when (or (not return-arity-ok?) process-val?)
(emit ";"))
(unless return-arity-ok?
(emit " }"))
(when process-val?
(emit " }"))))]
[vars (vm:syntax!-vars ast)]
[val (vm:syntax!-val ast)]
[in-mod? (vm:syntax!-in-mod? ast)]
[num-to-set (length vars)]
[return-arity (if (single-arity? val)
1
#f)])
(emit-indentation)
(let ([return-arity-ok?
(and return-arity
(number? return-arity)
(= return-arity num-to-set))])
(if (= num-to-set 1)
(process-set! (car vars) val #t return-arity-ok?)
(begin
(emit "{ Scheme_Object * res = ")
(process val indent-level #f #t)
(emit "; ")
(unless return-arity-ok?
(unless in-mod?
(emit "if (res != SCHEME_MULTIPLE_VALUES || scheme_multiple_count) "))
(emit "CHECK_MULTIPLE_VALUES(res, ~a);" num-to-set))
(emit "}")
(if (not (null? vars))
(emit "~n"))
(unless in-mod?
(emit-indentation)
(emit "if (scheme_multiple_count) {~n"))
(let aloop ([vars vars] [n 0])
(unless (null? vars)
(emit-indentation)
(process-set! (car vars) (format "scheme_multiple_array[~a]" n) #f #t)
(emit ";~n")
(aloop (cdr vars) (+ n 1))))
(unless in-mod?
(emit-indentation)
(emit "}~n"))
))))]
[(or (vm:global-prepare? ast)
(vm:global-lookup? ast)
(vm:global-assign? ast)
(vm:safe-vector-ref? ast))
(let-values ([(get-vec get-pos proc)
(cond
[(vm:global-prepare? ast)
(values vm:global-prepare-vec
vm:global-prepare-pos
"MZC_GLOBAL_PREPARE")]
[(vm:global-lookup? ast)
(values vm:global-lookup-vec
vm:global-lookup-pos
"MZC_GLOBAL_LOOKUP")]
[(vm:global-assign? ast)
(values vm:global-assign-vec
vm:global-assign-pos
"MZC_GLOBAL_ASSIGN")]
[(vm:safe-vector-ref? ast)
(values vm:safe-vector-ref-vec
vm:safe-vector-ref-pos
"MZC_KNOWN_SAFE_VECTOR_REF")])])
(emit "~a(" proc)
(process (get-vec ast) indent-level #f #t)
(emit ", ~a" (get-pos ast))
(when (vm:global-assign? ast)
(emit ", ")
(process (vm:global-assign-val ast) indent-level #f #t))
(emit ")"))]
;; (%args A ...) -> arg[0] = A; ...
[(vm:args? ast)
@ -1322,7 +1157,7 @@
(when (and (eq? arg-type:tail-arg (vm:args-type ast))
(not (null? (vm:args-vals ast))))
(emit-indentation)
(emit "tail_buf = scheme_tail_apply_buffer_wp(~a, pr);~n"
(emit "tail_buf = scheme_tail_apply_buffer_wp(~a, scheme_current_thread);~n"
(length (vm:args-vals ast))))
(if (null? (vm:args-vals ast))
(emit-indentation)
@ -1421,13 +1256,6 @@
(emit-expr (format "CHECK_GLOBAL_BOUND(G~a)"
(vm->c:convert-symbol
(mod-glob-cname (vm:check-global-var ast)))))]
[(vm:module-create? ast)
(emit-expr "scheme_declare_module(")
(process (vm:module-create-shape ast) indent-level #f #f)
(emit ", module_invoke_~a, module_invoke_syntax_~a, PLS, SCHEME_CURRENT_ENV(pr)"
(vm:module-create-id ast) (vm:module-create-id ast))
(emit ")")]
;; with-continuation-mark
[(vm:wcm-mark!? ast)
@ -1474,7 +1302,7 @@
(emit-expr "return _scheme_tail_apply_no_copy_wp(")
(process (vm:tail-apply-closure ast) indent-level #f #t)
(let ([c (vm:tail-apply-argc ast)])
(emit ", ~a, ~a, pr)" c (if (zero? c) "NULL" 'tail_buf)))]
(emit ", ~a, ~a, scheme_current_thread)" c (if (zero? c) "NULL" 'tail_buf)))]
;; (tail-call <label> <closure>) -> void_param = SCHEME_CLSD_PRIM_DATA(<closure>);
;; goto LOC<label>;
@ -1500,13 +1328,21 @@
[(vm:return? ast)
(emit-indentation)
(emit "return ")
(process (vm:return-val ast) indent-level #f #t)]
(when (vm:return-magic? ast)
(emit "MZC_APPLY_MAGIC("))
(process (vm:return-val ast) indent-level #f #t)
(when (vm:return-magic? ast)
(emit ", ~a)" top_level_n))]
;; fortunately, void contexts can accept any number of values,
;; so there's no need to check for return arity
[(vm:void? ast)
(emit-indentation)
(process (vm:void-val ast) indent-level #f #t)]
(when (vm:void-magic? ast)
(emit "MZC_APPLY_MAGIC("))
(process (vm:void-val ast) indent-level #f #t)
(when (vm:void-magic? ast)
(emit ", ~a)" top_level_n))]
;; (global-varref x) --> GLOBAL_VARREF(x)
[(vm:global-varref? ast)
@ -1523,9 +1359,6 @@
[(vm:per-load-statics-table? ast)
(emit-expr "PLS")]
[(vm:per-invoke-statics-table? ast)
(emit-expr "PMIS")]
;; use apply-known? flag
;; 0 args => pass NULL for arg vector
;; (apply A <argc>) --> _scheme_apply(A, argc, arg)
@ -1569,9 +1402,13 @@
(emit-expr "")
(when (vm:macro-apply-tail? ast)
(emit "return "))
(when (vm:macro-apply-magic? ast)
(emit "MZC_APPLY_MAGIC("))
(when (vm:macro-apply-bool? ast) (emit "(("))
(emit-macro-application ast)
(when (vm:macro-apply-bool? ast) (emit ") ? scheme_true : scheme_false)"))]
(when (vm:macro-apply-bool? ast) (emit ") ? scheme_true : scheme_false)"))
(when (vm:macro-apply-magic? ast)
(emit ", ~a)" top_level_n))]
[(vm:call? ast)
(emit-expr "_scheme_force_value(compiled(SCHEME_CLSD_PRIM_DATA(")
@ -1603,9 +1440,6 @@
[(vm:per-load-static-varref? ast)
(emit-expr "PLS->~a" (vm->c:convert-symbol (vm:static-varref-var ast)))]
[(vm:per-invoke-static-varref? ast)
(emit-expr "PMIS->~a" (vm->c:convert-symbol (vm:static-varref-var ast)))]
[(vm:static-varref? ast)
(emit-expr "S.~a" (vm->c:convert-symbol (vm:static-varref-var ast)))]
@ -1708,16 +1542,6 @@
(c-lambda-arity cl)
(c-lambda-arity cl)))]
;; HACK! - abused constants to communicate
;; a direct call to scheme_read_compiled_stx_string():
[(syntax-string? (zodiac:zread-object ast))
(let ([id (syntax-string-id (zodiac:zread-object ast))]
[for-mod? (syntax-string-mi (zodiac:zread-object ast))])
(emit-expr "scheme_eval_compiled_stx_string(SS[~a], SCHEME_CURRENT_ENV(pr), ~a, ~a)"
id
(if for-mod? "phase_shift" "0")
(if for-mod? "self_modidx" "NULL")))]
;; HACK! - abused constants to communicate
;; a direct call to scheme_eval_compiled_string():
[(compiled-string? (zodiac:zread-object ast))

33
collects/compiler/private/vmopt.ss
View File

@ -64,7 +64,7 @@
(define a-val/l-val/immediate? (one-of vm:global-varref? vm:primitive-varref? vm:local-varref?
vm:symbol-varref? vm:inexact-varref?
vm:static-varref? vm:bucket?
vm:per-load-statics-table? vm:per-invoke-statics-table?
vm:per-load-statics-table?
vm:struct-ref? vm:deref? vm:immediate?))
(define vm-optimize!
@ -77,8 +77,7 @@
(cond
[(or (vm:local-varref? closure)
(vm:static-varref-from-lift? closure)
(vm:per-load-static-varref-from-lift? closure)
(vm:per-invoke-static-varref-from-lift? closure))
(vm:per-load-static-varref-from-lift? closure))
(let ([known
(cond
[(vm:local-varref? closure) (extract-varref-known-val
@ -86,9 +85,7 @@
[(vm:static-varref-from-lift? closure)
(vm:static-varref-from-lift-lambda closure)]
[(vm:per-load-static-varref-from-lift? closure)
(vm:per-load-static-varref-from-lift-lambda closure)]
[else
(vm:per-invoke-static-varref-from-lift-lambda closure)])])
(vm:per-load-static-varref-from-lift-lambda closure)])])
(and known
(zodiac:case-lambda-form? known)
(begin (set! L known) #t)
@ -149,12 +146,6 @@
(apply append!
(map process! (vm:sequence-vals ast))))
ast]
[(vm:module-body? ast)
(set-vm:module-body-vals! ast
(apply append!
(map process! (vm:module-body-vals ast))))
ast]
;;--------------------------------------------------------------------
;; IF STATEMENTS
@ -422,7 +413,7 @@
;; Normal set
(let*-values ([(vref)
(zodiac:binding->lexical-varref binding)]
[(vm _) (vm-phase vref #f #f identity #f)]
[(vm _) (vm-phase vref #f #f identity #f #f)]
[(vm) (car (vm:sequence-vals vm))])
(cons (make-vm:set!
(zodiac:zodiac-stx val)
@ -536,9 +527,21 @@
[(vm:macro-apply? ast) (list ast)]
;;--------------------------------------------------------------------
;; MODULE CONSTRUCTION
;; GLOBALS
;;
[(vm:module-create? ast) (list ast)]
[(vm:global-prepare? ast)
(set-vm:global-prepare-vec! ast (car (process! (vm:global-prepare-vec ast))))
(list ast)]
[(vm:global-lookup? ast)
(set-vm:global-lookup-vec! ast (car (process! (vm:global-lookup-vec ast))))
(list ast)]
[(vm:global-assign? ast)
(set-vm:global-assign-vec! ast (car (process! (vm:global-assign-vec ast))))
(set-vm:global-assign-val! ast (car (process! (vm:global-assign-val ast))))
(list ast)]
[(vm:safe-vector-ref? ast)
(set-vm:safe-vector-ref-vec! ast (car (process! (vm:safe-vector-ref-vec ast))))
(list ast)]
;;--------------------------------------------------------------------
;; WITH-CONTINUATION-MARK

85
collects/compiler/private/vmphase.ss
View File

@ -140,7 +140,7 @@
;; 1) a vm-scheme sequence
;; 2) new local variables introduced
(define vm-phase
(define (vm-phase ast multi? leaf tail-pos tail? magic?)
(letrec
([new-locals empty-set]
[add-new-local! (lambda (l)
@ -223,9 +223,6 @@
[(const:per-load-statics-table?
(rep:struct-field-orig-name field))
(make-vm:per-load-statics-table #f)]
[(varref:module-invoke?
(rep:struct-field-orig-name field))
(make-vm:per-invoke-statics-table #f)]
[else
(make-vm:bucket #f var)])])
(make-vm:set! #f
@ -263,7 +260,7 @@
(lambda (b) (convert b
#t
list
(lambda (x) (make-vm:void #f x))
(lambda (x) (make-vm:void #f x #f))
#f
#f))
;; tail
@ -605,7 +602,7 @@
[get-args (if (null? make-args)
()
(list (make-vm:generic-args (zodiac:zodiac-stx ast)
#f #f #f make-args)))])
#f #f #f #f make-args)))])
(set-closure-code-label! code label)
(when new-bound
(add-new-local! new-bound))
@ -627,7 +624,7 @@
;;-----------------------------------------------------------------
;; SET! FORM
;;
;; we need to distinguish between setting a global & reffing it
;; we need to distinguish between setting a global & reffing it;
;; if we are in tail position, we need to do the void thing
;;
[(zodiac:set!-form? ast)
@ -860,11 +857,13 @@
closure
arg-locals
tail?
magic?
bool?)))))
(lambda ()
(cons (make-vm:generic-args (zodiac:zodiac-stx ast)
closure
(and tail? (not simple-tail-prim?))
magic?
prim
converted-args)
(if tail?
@ -921,15 +920,11 @@
[(top-level-varref/bind-from-lift? ast)
(lambda (a d ast)
((if (top-level-varref/bind-from-lift-pls? ast)
(if (varref:module-invoke? (top-level-varref/bind-from-lift-pls? ast))
make-vm:per-invoke-static-varref-from-lift
make-vm:per-load-static-varref-from-lift)
make-vm:per-load-static-varref-from-lift
make-vm:static-varref-from-lift)
a d (top-level-varref/bind-from-lift-lambda ast)))]
[(varref:has-attribute? ast varref:per-load-static)
(ignore-ast make-vm:per-load-static-varref)]
[(varref:has-attribute? ast varref:per-invoke-static)
(ignore-ast make-vm:per-invoke-static-varref)]
[(varref:has-attribute? ast varref:primitive)
(convert-global make-vm:primitive-varref)]
[(varref:has-attribute? ast varref:symbol)
@ -960,45 +955,55 @@
(if tail-pos
(leaf (tail-pos vm))
(leaf vm)))]
;;-----------------------------------------------------------------
;; MODULE
;;-----------------------------------------------------------
;; GLOBALS
;;
;; If we get here, this is the module construction/registration
;;
[(zodiac:module-form? ast)
(let ([vm (make-vm:module-create
(zodiac:zodiac-stx ast)
;; constant reprsenting the module form:
(car (convert (zodiac:module-form-body ast) #f list #f #f #t))
(varref:module-invoke-id (module-info-invoke (get-annotation ast))))])
[(zodiac:global-prepare? ast)
(let ([expr (make-vm:global-prepare
(zodiac:zodiac-stx ast)
(convert (zodiac:global-prepare-vec ast) #f identity #f #f #t)
(zodiac:global-prepare-pos ast))])
(if tail-pos
(leaf (tail-pos vm))
(leaf vm)))]
(leaf (tail-pos expr))
(leaf expr)))]
[(zodiac:global-lookup? ast)
(let ([expr (make-vm:global-lookup
(zodiac:zodiac-stx ast)
(convert (zodiac:global-lookup-vec ast) #f identity #f #f #t)
(zodiac:global-lookup-pos ast))])
(if tail-pos
(leaf (tail-pos expr))
(leaf expr)))]
[(zodiac:global-assign? ast)
(let ([expr (make-vm:global-assign
(zodiac:zodiac-stx ast)
(convert (zodiac:global-assign-vec ast) #f identity #f #f #t)
(convert (zodiac:global-assign-expr ast) #f identity #f #f #t)
(zodiac:global-assign-pos ast))])
(if tail-pos
(leaf (tail-pos expr))
(leaf expr)))]
[(zodiac:safe-vector-ref? ast)
(let ([expr (make-vm:safe-vector-ref
(zodiac:zodiac-stx ast)
(convert (zodiac:safe-vector-ref-vec ast) #f identity #f #f #t)
(zodiac:safe-vector-ref-pos ast))])
(if tail-pos
(leaf (tail-pos expr))
(leaf expr)))]
[else
(compiler:internal-error
ast
(format "vm-phase: form not supported ~a" ast))]))])
(lambda (ast multi? leaf tail-pos tail?)
(begin
(set! new-locals empty-set)
;; l->r evaluation necessary for convert to get called before new-locals
;; is evaluated
(values ((if (zodiac:module-form? ast)
(let ([info (get-annotation ast)])
(if (eq? 'constructor (module-info-part info))
make-vm:sequence
(lambda (stx vals)
(make-vm:module-body
stx vals
(module-info-invoke info)
(eq? 'syntax-body (module-info-part info))))))
make-vm:sequence)
(values (make-vm:sequence
(zodiac:zodiac-stx ast)
(convert (if (and (zodiac:module-form? ast)
(not (eq? 'constructor (module-info-part (get-annotation ast)))))
(zodiac:module-form-body ast)
ast)
(convert ast
multi? (or leaf list) tail-pos tail? (not tail?)))
new-locals)))))))

17
collects/compiler/private/vmscheme.ss
View File

@ -27,24 +27,28 @@
;; Block statements
(define-struct (vm:sequence zodiac:zodiac) (vals))
(define-struct (vm:if zodiac:zodiac) (test then else))
(define-struct (vm:module-body zodiac:zodiac) (vals invoke syntax?))
;; Tail position statements
(define-struct (vm:void zodiac:zodiac) (val))
(define-struct (vm:return zodiac:zodiac) (val))
(define-struct (vm:void zodiac:zodiac) (val magic?))
(define-struct (vm:return zodiac:zodiac) (val magic?))
(define-struct (vm:tail-apply zodiac:zodiac) (closure argc prim))
(define-struct (vm:tail-call zodiac:zodiac) (label closure set-env?))
(define-struct (vm:continue zodiac:zodiac) ())
;; non-tail imperative statements
(define-struct (vm:set! zodiac:zodiac) (vars val mode))
(define-struct (vm:generic-args zodiac:zodiac) (closure tail? prim vals))
(define-struct (vm:generic-args zodiac:zodiac) (closure tail? magic? prim vals))
(define-struct (vm:register-args zodiac:zodiac) (vars vals))
(define-struct (vm:args zodiac:zodiac) (type vals))
(define-struct (vm:begin0-mark! zodiac:zodiac) (var val))
(define-struct (vm:begin0-setup! zodiac:zodiac) (var))
(define-struct (vm:syntax! zodiac:zodiac) (vars val in-mod?))
(define-struct (vm:global-prepare zodiac:zodiac) (vec pos))
(define-struct (vm:global-lookup zodiac:zodiac) (vec pos))
(define-struct (vm:global-assign zodiac:zodiac) (vec val pos))
(define-struct (vm:safe-vector-ref zodiac:zodiac) (vec pos))
;; r-values (1 step computations)
(define-struct (vm:alloc zodiac:zodiac) (type))
(define-struct (vm:build-constant zodiac:zodiac) (text))
@ -56,7 +60,7 @@
(define-struct (vm:apply zodiac:zodiac)
(closure argc known? multi? prim simple-tail-prim?))
(define-struct (vm:macro-apply zodiac:zodiac)
(name primitive args tail? bool?))
(name primitive args tail? magic? bool?))
(define-struct (vm:call zodiac:zodiac) (label closure))
(define-struct (vm:begin0-extract zodiac:zodiac) (var))
(define-struct (vm:wcm-mark! zodiac:zodiac) (key val))
@ -71,7 +75,6 @@
(define-struct (vm:global-varref zodiac:zodiac) (var))
(define-struct (vm:bucket zodiac:zodiac) (var))
(define-struct (vm:per-load-statics-table zodiac:zodiac) ())
(define-struct (vm:per-invoke-statics-table zodiac:zodiac) ())
(define-struct (vm:cast zodiac:zodiac) (val rep)) ; last resort
;; l-values (locations in memory)
@ -79,9 +82,7 @@
(define-struct (vm:static-varref zodiac:zodiac) (var))
(define-struct (vm:static-varref-from-lift vm:static-varref) (lambda))
(define-struct (vm:per-load-static-varref vm:static-varref) ())
(define-struct (vm:per-invoke-static-varref vm:static-varref) ())
(define-struct (vm:per-load-static-varref-from-lift vm:per-load-static-varref) (lambda))
(define-struct (vm:per-invoke-static-varref-from-lift vm:per-invoke-static-varref) (lambda))
(define-struct (vm:primitive-varref zodiac:zodiac) (var))
(define-struct (vm:symbol-varref zodiac:zodiac) (var))
(define-struct (vm:inexact-varref zodiac:zodiac) (var))

12
collects/syntax/zodiac-sig.ss
View File

@ -91,6 +91,18 @@
create-module-form
(struct require/provide-form ()) create-require/provide-form
;; These forms are highly mzc-specific. They are recongized
;; as applications of the corresponding quoted symbols to the
;; right kinds of arguments.
(struct global-prepare (vec pos)) create-global-prepare
(struct global-lookup (vec pos)) create-global-lookup
(struct global-assign (vec pos expr)) create-global-assign
(struct safe-vector-ref (vec pos)) create-safe-vector-ref
global-prepare-id
global-lookup-id
global-assign-id
safe-vector-ref-id
;; args:
(struct arglist (vars))
(struct sym-arglist ())

55
collects/syntax/zodiac-unit.ss
View File

@ -22,6 +22,11 @@
p))
l))
(define global-prepare-id (gensym))
(define global-lookup-id (gensym))
(define global-assign-id (gensym))
(define safe-vector-ref-id (gensym))
;; Back boxes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-struct secure-box (value))
@ -473,6 +478,40 @@
(loop (syntax v) env trans?)
(loop (syntax body) env trans?))]
[(#%app 'gp vec (#%datum . pos))
(and (eq? (syntax-e #'gp) global-prepare-id)
(number? (syntax-e #'pos)))
(make-global-prepare
stx
(mk-back)
(loop (syntax vec) env trans?)
(syntax-e #'pos))]
[(#%app 'gl vec (#%datum . pos))
(and (eq? (syntax-e #'gl) global-lookup-id)
(number? (syntax-e #'pos)))
(make-global-lookup
stx
(mk-back)
(loop (syntax vec) env trans?)
(syntax-e #'pos))]
[(#%app 'ga vec (#%datum . pos) val)
(and (eq? (syntax-e #'ga) global-assign-id)
(number? (syntax-e #'pos)))
(make-global-assign
stx
(mk-back)
(loop (syntax vec) env trans?)
(syntax-e #'pos)
(loop (syntax val) env trans?))]
[(#%app 'svr vec (#%datum . pos))
(and (eq? (syntax-e #'svr) safe-vector-ref-id)
(number? (syntax-e #'pos)))
(make-safe-vector-ref
stx
(mk-back)
(loop (syntax vec) env trans?)
(syntax-e #'pos))]
[(#%app)
(make-quote-form
(syntax/loc stx ())
@ -725,6 +764,22 @@
(define-struct (require/provide-form parsed) ())
(define (create-require/provide-form z)
(make-require/provide-form (zodiac-stx z) (mk-back)))
(define-struct (global-prepare parsed) (vec pos))
(define (create-global-prepare z vec pos)
(make-global-prepare (zodiac-stx z) (mk-back) vec pos))
(define-struct (global-lookup parsed) (vec pos))
(define (create-global-lookup z vec pos)
(make-global-lookup (zodiac-stx z) (mk-back) vec pos))
(define-struct (global-assign parsed) (vec pos expr))
(define (create-global-assign z vec pos expr)
(make-global-assign (zodiac-stx z) (mk-back) vec pos expr))
(define-struct (safe-vector-ref parsed) (vec pos))
(define (create-safe-vector-ref z vec pos)
(make-safe-vector-ref (zodiac-stx z) (mk-back) vec pos))
(define-struct arglist (vars))
(define-struct (sym-arglist arglist) ())

2
src/mred/mred.h
View File

@ -182,7 +182,7 @@ MRED_EXTERN MrEd_Run_From_Cmd_Line_Proc mred_run_from_cmd_line;
#else
# define MRED3M ""
#endif
#define BANNER "MrEd" MRED3M " version " MZSCHEME_VERSION ", Copyright (c) 2004-2005 PLT Scheme, Inc.\n"
#define BANNER "MrEd" MRED3M " version " MZSCHEME_VERSION ", Copyright (c) 2004-2005 PLT Scheme Inc.\n"
#ifndef WINDOW_STDIO
/* Removing "|| defined(wx_msw)" below uses the Windows console.

1
src/mzscheme/include/mzscheme.exp
View File

@ -139,6 +139,7 @@ scheme_eval_compiled_stx_string
scheme_load_compiled_stx_string
scheme_compiled_stx_symbol
scheme_eval_compiled_sized_string
scheme_eval_compiled_sized_string_with_magic
GC_malloc
GC_malloc_atomic
GC_malloc_stubborn

1
src/mzscheme/include/mzscheme3m.exp
View File

@ -139,6 +139,7 @@ scheme_eval_compiled_stx_string
scheme_load_compiled_stx_string
scheme_compiled_stx_symbol
scheme_eval_compiled_sized_string
scheme_eval_compiled_sized_string_with_magic
GC_malloc
GC_malloc_atomic
GC_malloc_one_tagged

1
src/mzscheme/include/mzwin.def
View File

@ -135,6 +135,7 @@ EXPORTS
scheme_load_compiled_stx_string
scheme_compiled_stx_symbol
scheme_eval_compiled_sized_string
scheme_eval_compiled_sized_string_with_magic
scheme_malloc_eternal
scheme_end_stubborn_change
scheme_calloc

21
src/mzscheme/sconfig.h
View File

@ -232,6 +232,14 @@
# define USE_TIMEZONE_VAR
# include <linux/version.h>
# if LINUX_VERSION_CODE > KERNEL_VERSION(2,4,20)
# define MZ_TCP_LISTEN_IPV6_ONLY_SOCKOPT
# define MZ_TCP_LISTEN_IPV4_DEFAULT
# else
# define MZ_TCP_LISTEN_IPV4_ONLY
# endif
# define FLAGS_ALREADY_SET
#endif
@ -1013,6 +1021,19 @@
/* MZ_BINARY is combinaed with other flags in all calls to open();
it can be defined to O_BINARY in Cygwin, for example. */
/* MZ_TCP_LISTEN_IPV6_ONLY_SOCKOPT uses IPV6_V6ONLY for IPv6 listeners,
which means that the listener accepts only IPv6 connections. This is
used with Linux, for example, because a port cannot have both an
IPv4 and IPv6 listener if the IPv6 one doesn't use IPV6_V6ONLY. */
/* MZ_TCP_LISTEN_IPV4_DEFAULT creates an IPv4 listener, only, when no
hostname is specified. */
/* MZ_TCP_LISTEN_IPV4_ONLY ignores any IPv6 addresses for an listener
hostname. This is used for Linux versions that do not support
IPV6_V6ONLY, which is needed to support both IPv6 and IPv4
listeners. */
/***********************/
/* Threads & Signals */
/***********************/

16
src/mzscheme/src/builtin.c
View File

@ -32,7 +32,9 @@
#endif
#endif
Scheme_Object *scheme_eval_compiled_sized_string(const char *str, int len, Scheme_Env *env)
Scheme_Object *scheme_eval_compiled_sized_string_with_magic(const char *str, int len, Scheme_Env *env,
Scheme_Object *magic_sym, Scheme_Object *magic_val,
int multi_ok)
{
Scheme_Object *port, *expr;
Scheme_Config *config;
@ -44,9 +46,17 @@ Scheme_Object *scheme_eval_compiled_sized_string(const char *str, int len, Schem
if (!env)
env = scheme_get_env(NULL);
expr = scheme_internal_read(port, NULL, 1, 1, 0, 0, -1, NULL);
expr = scheme_internal_read(port, NULL, 1, 1, 0, 0, -1, NULL, magic_sym, magic_val);
return _scheme_eval_compiled(expr, env);
if (multi_ok)
return _scheme_eval_compiled_multi(expr, env);
else
return _scheme_eval_compiled(expr, env);
}
Scheme_Object *scheme_eval_compiled_sized_string(const char *str, int len, Scheme_Env *env)
{
return scheme_eval_compiled_sized_string_with_magic(str, len, env, NULL, NULL, 0);
}
void scheme_add_embedded_builtins(Scheme_Env *env)

2794
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

21
src/mzscheme/src/env.c
View File

@ -209,6 +209,7 @@ Scheme_Env *scheme_basic_env()
#ifndef MZ_PRECISE_GC
scheme_init_setjumpup();
scheme_init_ephemerons();
#endif
#ifdef TIME_STARTUP_PROCESS
@ -1472,10 +1473,10 @@ static Scheme_Local *get_frame_loc(Scheme_Comp_Env *frame,
/* Generates a Scheme_Local record for a static distance coodinate, and also
marks the variable as used for closures. */
{
COMPILE_DATA(frame)->use[i] |= (((flags & (SCHEME_APP_POS | SCHEME_SETTING))
COMPILE_DATA(frame)->use[i] |= (((flags & (SCHEME_APP_POS | SCHEME_SETTING | SCHEME_REFERENCING))
? CONSTRAINED_USE
: ARBITRARY_USE)
| ((flags & (SCHEME_SETTING | SCHEME_LINKING_REF))
| ((flags & (SCHEME_SETTING | SCHEME_REFERENCING | SCHEME_LINKING_REF))
? WAS_SET_BANGED
: 0));
@ -2241,8 +2242,11 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
if (genv->module && !genv->rename) {
/* Free variable. Maybe don't continue. */
if (flags & SCHEME_SETTING) {
scheme_wrong_syntax(scheme_set_stx_string, NULL, src_find_id, "unbound variable in module");
if (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) {
scheme_wrong_syntax(((flags & SCHEME_SETTING)
? scheme_set_stx_string
: scheme_var_ref_string),
NULL, src_find_id, "unbound variable in module");
return NULL;
}
if (flags & SCHEME_NULL_FOR_UNBOUND)
@ -2300,10 +2304,13 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
return NULL;
}
if (!modname && (flags & SCHEME_SETTING) && (genv->module && !genv->rename)) {
if (!modname && (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) && (genv->module && !genv->rename)) {
/* Check for set! of unbound variable: */
if (!scheme_lookup_in_table(genv->toplevel, (const char *)find_global_id)) {
scheme_wrong_syntax(scheme_set_stx_string, NULL, src_find_id, "unbound variable in module");
scheme_wrong_syntax(((flags & SCHEME_SETTING)
? scheme_set_stx_string
: scheme_var_ref_string),
NULL, src_find_id, "unbound variable in module");
return NULL;
}
}
@ -2333,7 +2340,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
modpos, mod_defn_phase);
}
if (!modname && (flags & SCHEME_SETTING) && genv->module) {
if (!modname && (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) && genv->module) {
/* Need to return a variable reference in this case, too. */
return scheme_hash_module_variable(env->genv, genv->module->self_modidx, find_global_id,
genv->module->insp,

2
src/mzscheme/src/error.c
View File

@ -1294,6 +1294,7 @@ const char *scheme_compile_stx_string = "compile";
const char *scheme_expand_stx_string = "expand";
const char *scheme_application_stx_string = "application";
const char *scheme_set_stx_string = "set!";
const char *scheme_var_ref_string = "#%variable-reference";
const char *scheme_begin_stx_string = "begin";
void scheme_wrong_syntax(const char *where,
@ -1337,6 +1338,7 @@ void scheme_wrong_syntax(const char *where,
nomwho = who;
mod = scheme_intern_symbol("mzscheme");
} else if ((where == scheme_set_stx_string)
|| (where == scheme_var_ref_string)
|| (where == scheme_begin_stx_string)) {
who = scheme_intern_symbol(where);
nomwho = who;

2
src/mzscheme/src/eval.c
View File

@ -4495,7 +4495,7 @@ Scheme_Object *scheme_load_compiled_stx_string(const char *str, long len)
port = scheme_make_sized_byte_string_input_port(str, -len);
expr = scheme_internal_read(port, NULL, 1, 0, 0, 0, -1, NULL);
expr = scheme_internal_read(port, NULL, 1, 0, 0, 0, -1, NULL, NULL, NULL);
expr = _scheme_eval_compiled(expr, scheme_get_env(NULL));

1
src/mzscheme/src/hash.c
View File

@ -826,6 +826,7 @@ void scheme_init_hash_key_procs(void)
PROC(scheme_config_type, hash_general);
PROC(scheme_thread_cell_type, hash_general);
PROC(scheme_thread_cell_values_type, hash_general);
PROC(scheme_global_ref_type, hash_general);
PROC(scheme_will_executor_type, hash_general);
PROC(scheme_stx_type, hash_general);
PROC(scheme_module_index_type, hash_general);

8
src/mzscheme/src/list.c
View File

@ -1897,4 +1897,12 @@ void scheme_clear_ephemerons()
done_ephemerons = NULL;
}
extern MZ_DLLIMPORT void (*GC_custom_finalize)(void);
void scheme_init_ephemerons(void)
{
/* symbol.c will overwrite this, later */
GC_custom_finalize = scheme_clear_ephemerons;
}
#endif

18
src/mzscheme/src/module.c
View File

@ -127,7 +127,7 @@ static Scheme_Object *require_for_template_stx;
static Scheme_Object *provide_stx;
static Scheme_Object *set_stx;
static Scheme_Object *app_stx;
static Scheme_Object *top_stx;
Scheme_Object *scheme_top_stx;
static Scheme_Object *lambda_stx;
static Scheme_Object *case_lambda_stx;
static Scheme_Object *let_values_stx;
@ -137,7 +137,7 @@ static Scheme_Object *begin0_stx;
static Scheme_Object *set_stx;
static Scheme_Object *with_continuation_mark_stx;
static Scheme_Object *letrec_syntaxes_stx;
static Scheme_Object *fluid_let_syntax_stx;
static Scheme_Object *var_ref_stx;
static Scheme_Env *initial_modules_env;
static int num_initial_modules;
@ -450,7 +450,7 @@ void scheme_finish_kernel(Scheme_Env *env)
REGISTER_SO(provide_stx);
REGISTER_SO(set_stx);
REGISTER_SO(app_stx);
REGISTER_SO(top_stx);
REGISTER_SO(scheme_top_stx);
REGISTER_SO(lambda_stx);
REGISTER_SO(case_lambda_stx);
REGISTER_SO(let_values_stx);
@ -460,7 +460,7 @@ void scheme_finish_kernel(Scheme_Env *env)
REGISTER_SO(set_stx);
REGISTER_SO(with_continuation_mark_stx);
REGISTER_SO(letrec_syntaxes_stx);
REGISTER_SO(fluid_let_syntax_stx);
REGISTER_SO(var_ref_stx);
w = scheme_sys_wraps0;
scheme_module_stx = scheme_datum_to_syntax(scheme_intern_symbol("module"), scheme_false, w, 0, 0);
@ -474,7 +474,7 @@ void scheme_finish_kernel(Scheme_Env *env)
provide_stx = scheme_datum_to_syntax(scheme_intern_symbol("provide"), scheme_false, w, 0, 0);
set_stx = scheme_datum_to_syntax(scheme_intern_symbol("set!"), scheme_false, w, 0, 0);
app_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%app"), scheme_false, w, 0, 0);
top_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%top"), scheme_false, w, 0, 0);
scheme_top_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%top"), scheme_false, w, 0, 0);
lambda_stx = scheme_datum_to_syntax(scheme_intern_symbol("lambda"), scheme_false, w, 0, 0);
case_lambda_stx = scheme_datum_to_syntax(scheme_intern_symbol("case-lambda"), scheme_false, w, 0, 0);
let_values_stx = scheme_datum_to_syntax(scheme_intern_symbol("let-values"), scheme_false, w, 0, 0);
@ -484,7 +484,7 @@ void scheme_finish_kernel(Scheme_Env *env)
set_stx = scheme_datum_to_syntax(scheme_intern_symbol("set!"), scheme_false, w, 0, 0);
with_continuation_mark_stx = scheme_datum_to_syntax(scheme_intern_symbol("with-continuation-mark"), scheme_false, w, 0, 0);
letrec_syntaxes_stx = scheme_datum_to_syntax(scheme_intern_symbol("letrec-syntaxes+values"), scheme_false, w, 0, 0);
fluid_let_syntax_stx = scheme_datum_to_syntax(scheme_intern_symbol("fluid-let-syntax"), scheme_false, w, 0, 0);
var_ref_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%variable-reference"), scheme_false, w, 0, 0);
REGISTER_SO(prefix_symbol);
REGISTER_SO(only_symbol);
@ -3572,7 +3572,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
scheme_set_local_syntax(7, provide_stx, stop, xenv);
scheme_set_local_syntax(8, set_stx, stop, xenv);
scheme_set_local_syntax(9, app_stx, stop, xenv);
scheme_set_local_syntax(10, top_stx, stop, xenv);
scheme_set_local_syntax(10, scheme_top_stx, stop, xenv);
scheme_set_local_syntax(11, case_lambda_stx, stop, xenv);
scheme_set_local_syntax(12, let_values_stx, stop, xenv);
scheme_set_local_syntax(13, letrec_values_stx, stop, xenv);
@ -3581,7 +3581,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
scheme_set_local_syntax(16, set_stx, stop, xenv);
scheme_set_local_syntax(17, with_continuation_mark_stx, stop, xenv);
scheme_set_local_syntax(18, letrec_syntaxes_stx, stop, xenv);
scheme_set_local_syntax(19, fluid_let_syntax_stx, stop, xenv);
scheme_set_local_syntax(19, var_ref_stx, stop, xenv);
}
first = scheme_null;
@ -4522,7 +4522,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
if ((reprovide_kernel == (kernel->num_provides - 1))
&& SCHEME_FALSEP(exclude_hint)) {
exclude_hint = scheme_make_pair(module_begin_symbol, scheme_null);
exclude_hint = scheme_datum_to_syntax(exclude_hint, scheme_false, top_stx, 0, 0);
exclude_hint = scheme_datum_to_syntax(exclude_hint, scheme_false, scheme_top_stx, 0, 0);
}
/* Re-providing all of the kernel without prefixing? */

8
src/mzscheme/src/mzmark.c
View File

@ -3964,6 +3964,8 @@ int mark_cport_MARK(void *p) {
gcMARK(cp->ht);
gcMARK(cp->symtab);
gcMARK(cp->insp);
gcMARK(cp->magic_sym);
gcMARK(cp->magic_val);
return
gcBYTES_TO_WORDS(sizeof(CPort));
}
@ -3975,6 +3977,8 @@ int mark_cport_FIXUP(void *p) {
gcFIXUP(cp->ht);
gcFIXUP(cp->symtab);
gcFIXUP(cp->insp);
gcFIXUP(cp->magic_sym);
gcFIXUP(cp->magic_val);
return
gcBYTES_TO_WORDS(sizeof(CPort));
}
@ -4016,6 +4020,8 @@ int mark_read_params_SIZE(void *p) {
int mark_read_params_MARK(void *p) {
ReadParams *rp = (ReadParams *)p;
gcMARK(rp->table);
gcMARK(rp->magic_sym);
gcMARK(rp->magic_val);
return
gcBYTES_TO_WORDS(sizeof(ReadParams));
}
@ -4023,6 +4029,8 @@ int mark_read_params_MARK(void *p) {
int mark_read_params_FIXUP(void *p) {
ReadParams *rp = (ReadParams *)p;
gcFIXUP(rp->table);
gcFIXUP(rp->magic_sym);
gcFIXUP(rp->magic_val);
return
gcBYTES_TO_WORDS(sizeof(ReadParams));
}

4
src/mzscheme/src/mzmarksrc.c
View File

@ -1598,6 +1598,8 @@ mark_cport {
gcMARK(cp->ht);
gcMARK(cp->symtab);
gcMARK(cp->insp);
gcMARK(cp->magic_sym);
gcMARK(cp->magic_val);
size:
gcBYTES_TO_WORDS(sizeof(CPort));
}
@ -1615,6 +1617,8 @@ mark_read_params {
mark:
ReadParams *rp = (ReadParams *)p;
gcMARK(rp->table);
gcMARK(rp->magic_sym);
gcMARK(rp->magic_val);
size:
gcBYTES_TO_WORDS(sizeof(ReadParams));
}

55
src/mzscheme/src/network.c
View File

@ -407,10 +407,10 @@ void scheme_init_network(Scheme_Env *env)
#define UNREGISTER_SOCKET(s) /**/
#ifdef USE_UNIX_SOCKETS_TCP
typedef struct sockaddr_in tcp_address;
typedef struct sockaddr_in mz_unspec_address;
#endif
#ifdef USE_WINSOCK_TCP
typedef struct SOCKADDR_IN tcp_address;
typedef struct SOCKADDR_IN mz_unspec_address;
# undef REGISTER_SOCKET
# undef UNREGISTER_SOCKET
# define REGISTER_SOCKET(s) winsock_remember(s)
@ -1796,7 +1796,17 @@ tcp_listen(int argc, Scheme_Object *argv[])
int err, count = 0, pos = 0, i;
listener_t *l = NULL;
tcp_listen_addr = scheme_get_host_address(address, id, &err, -1, 1, 1);
tcp_listen_addr = scheme_get_host_address(address, id, &err,
#ifdef MZ_TCP_LISTEN_IPV4_ONLY
MZ_PF_INET,
#else
# ifdef MZ_TCP_LISTEN_IPV4_DEFAULT
!address ? MZ_PF_INET : -1,
# else
-1,
# endif
#endif
1, 1);
for (addr = tcp_listen_addr; addr; addr = addr->ai_next) {
count++;
@ -1808,6 +1818,12 @@ tcp_listen(int argc, Scheme_Object *argv[])
errid = 0;
for (addr = tcp_listen_addr; addr; addr = addr->ai_next) {
s = socket(addr->ai_family, addr->ai_socktype, addr->ai_protocol);
#ifdef MZ_TCP_LISTEN_IPV6_ONLY_SOCKOPT
if (addr->ai_family == PF_INET6) {
int on = 1;
setsockopt(s, IPPROTO_IPV6, IPV6_V6ONLY, &on, sizeof(on));
}
#endif
if (s != INVALID_SOCKET) {
#ifdef USE_WINSOCK_TCP
@ -2474,8 +2490,8 @@ static Scheme_Object *udp_bind_or_connect(const char *name, int argc, Scheme_Obj
scheme_wrong_type(name, "udp socket", 0, argc, argv);
#ifdef UDP_IS_SUPPORTED
if ((!do_bind || !SCHEME_FALSEP(argv[1])) && !SCHEME_CHAR_STRINGP(argv[1]))
scheme_wrong_type(name, (do_bind ? "string or #f" : "string"), 1, argc, argv);
if (!SCHEME_FALSEP(argv[1]) && !SCHEME_CHAR_STRINGP(argv[1]))
scheme_wrong_type(name, "string or #f", 1, argc, argv);
if ((do_bind || !SCHEME_FALSEP(argv[2])) && !CHECK_PORT_ID(argv[2]))
scheme_wrong_type(name, (do_bind ? PORT_ID_TYPE : PORT_ID_TYPE " or #f"), 2, argc, argv);
@ -2517,8 +2533,12 @@ static Scheme_Object *udp_bind_or_connect(const char *name, int argc, Scheme_Obj
id = origid;
udp_bind_addr = scheme_get_host_address(address, id, &err, -1, do_bind, 0);
if (udp_bind_addr) {
if (address || id)
udp_bind_addr = scheme_get_host_address(address, id, &err, -1, do_bind, 0);
else
udp_bind_addr = NULL;
if (udp_bind_addr || !origid) {
if (do_bind) {
if (!bind(udp->s, udp_bind_addr->ai_addr, udp_bind_addr->ai_addrlen)) {
udp->bound = 1;
@ -2537,7 +2557,20 @@ static Scheme_Object *udp_bind_or_connect(const char *name, int argc, Scheme_Obj
ok = 1;
} else
#endif
ok = !connect(udp->s, udp_bind_addr->ai_addr, udp_bind_addr->ai_addrlen);
{
if (udp_bind_addr)
ok = !connect(udp->s, udp_bind_addr->ai_addr, udp_bind_addr->ai_addrlen);
#ifndef USE_NULL_TO_DISCONNECT_UDP
else {
GC_CAN_IGNORE mz_unspec_address ua;
ua.sin_family = AF_UNSPEC;
ua.sin_port = 0;
memset(&(ua.sin_addr), 0, sizeof(ua.sin_addr));
memset(&(ua.sin_zero), 0, sizeof(ua.sin_zero));
ok = !connect(udp->s, (struct sockaddr *)&ua, sizeof(ua));
}
#endif
}
if (!ok)
errid = SOCK_ERRNO();
@ -2554,12 +2587,14 @@ static Scheme_Object *udp_bind_or_connect(const char *name, int argc, Scheme_Obj
udp->connected = 1;
else
udp->connected = 0;
freeaddrinfo(udp_bind_addr);
if (udp_bind_addr)
freeaddrinfo(udp_bind_addr);
return scheme_void;
}
}
freeaddrinfo(udp_bind_addr);
if (udp_bind_addr)
freeaddrinfo(udp_bind_addr);
scheme_raise_exn(MZEXN_FAIL_NETWORK,
"%s: can't %s to port: %d on address: %s (%E)",

10
src/mzscheme/src/portfun.c
View File

@ -2778,7 +2778,7 @@ static Scheme_Object *sch_default_read_handler(void *ignore, int argc, Scheme_Ob
else
src = NULL;
return scheme_internal_read(argv[0], src, -1, 0, 0, 0, -1, NULL);
return scheme_internal_read(argv[0], src, -1, 0, 0, 0, -1, NULL, NULL, NULL);
}
static int extract_recur_args(const char *who, int argc, Scheme_Object **argv, int delta, Scheme_Object **_readtable)
@ -2829,7 +2829,7 @@ static Scheme_Object *do_read_f(const char *who, int argc, Scheme_Object *argv[]
if (port == scheme_orig_stdin_port)
scheme_flush_orig_outputs();
return scheme_internal_read(port, NULL, -1, 0, honu_mode, recur, pre_char, readtable);
return scheme_internal_read(port, NULL, -1, 0, honu_mode, recur, pre_char, readtable, NULL, NULL);
}
}
@ -2892,7 +2892,7 @@ static Scheme_Object *do_read_syntax_f(const char *who, int argc, Scheme_Object
if (port == scheme_orig_stdin_port)
scheme_flush_orig_outputs();
return scheme_internal_read(port, src, -1, 0, honu_mode, recur, pre_char, readtable);
return scheme_internal_read(port, src, -1, 0, honu_mode, recur, pre_char, readtable, NULL, NULL);
}
}
@ -4061,7 +4061,7 @@ static Scheme_Object *do_load_handler(void *data)
Scheme_Env *genv;
int save_count = 0, got_one = 0;
while ((obj = scheme_internal_read(port, lhd->stxsrc, 1, 0, 0, 0, -1, NULL))
while ((obj = scheme_internal_read(port, lhd->stxsrc, 1, 0, 0, 0, -1, NULL, NULL, NULL))
&& !SCHEME_EOFP(obj)) {
save_array = NULL;
got_one = 1;
@ -4134,7 +4134,7 @@ static Scheme_Object *do_load_handler(void *data)
}
/* Check no more expressions: */
d = scheme_internal_read(port, lhd->stxsrc, 1, 0, 0, 0, -1, NULL);
d = scheme_internal_read(port, lhd->stxsrc, 1, 0, 0, 0, -1, NULL, NULL, NULL);
if (!SCHEME_EOFP(d)) {
scheme_raise_exn(MZEXN_FAIL,
"default-load-handler: expected only a `module' declaration for `%S', but found an extra expression in: %V",

44
src/mzscheme/src/read.c
View File

@ -121,6 +121,7 @@ typedef struct ReadParams {
int can_read_quasi;
int honu_mode;
Readtable *table;
Scheme_Object *magic_sym, *magic_val;
} ReadParams;
#define THREAD_FOR_LOCALS scheme_current_thread
@ -203,7 +204,8 @@ static Scheme_Object *read_reader(Scheme_Object *port, Scheme_Object *stxsrc,
Scheme_Object *indentation,
ReadParams *params);
static Scheme_Object *read_compiled(Scheme_Object *port,
Scheme_Hash_Table **ht);
Scheme_Hash_Table **ht,
ReadParams *params);
static void unexpected_closer(int ch,
Scheme_Object *port, Scheme_Object *stxsrc,
long line, long col, long pos,
@ -1167,7 +1169,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
if (!params->honu_mode) {
if (params->can_read_compiled) {
Scheme_Object *cpld;
cpld = read_compiled(port, ht);
cpld = read_compiled(port, ht, params);
if (stxsrc)
cpld = scheme_make_stx_w_offset(cpld, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG);
return cpld;
@ -1768,7 +1770,8 @@ static Scheme_Object *resolve_references(Scheme_Object *obj,
Scheme_Object *
_scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int honu_mode,
int recur, int extra_char, Scheme_Object *init_readtable)
int recur, int extra_char, Scheme_Object *init_readtable,
Scheme_Object *magic_sym, Scheme_Object *magic_val)
{
Scheme_Object *v, *v2;
Scheme_Config *config;
@ -1806,6 +1809,8 @@ _scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int h
params.honu_mode = honu_mode;
if (honu_mode)
params.table = NULL;
params.magic_sym = magic_sym;
params.magic_val = magic_val;
ht = NULL;
if (recur) {
@ -1889,18 +1894,24 @@ static void *scheme_internal_read_k(void)
Scheme_Object *port = (Scheme_Object *)p->ku.k.p1;
Scheme_Object *stxsrc = (Scheme_Object *)p->ku.k.p2;
Scheme_Object *init_readtable = (Scheme_Object *)p->ku.k.p3;
Scheme_Object *magic_sym = (Scheme_Object *)p->ku.k.p4;
Scheme_Object *magic_val = (Scheme_Object *)p->ku.k.p5;
p->ku.k.p1 = NULL;
p->ku.k.p2 = NULL;
p->ku.k.p3 = NULL;
p->ku.k.p4 = NULL;
p->ku.k.p5 = NULL;
return (void *)_scheme_internal_read(port, stxsrc, p->ku.k.i1, p->ku.k.i2,
p->ku.k.i3, p->ku.k.i4, init_readtable);
p->ku.k.i3, p->ku.k.i4, init_readtable,
magic_sym, magic_val);
}
Scheme_Object *
scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int cantfail, int honu_mode,
int recur, int pre_char, Scheme_Object *init_readtable)
int recur, int pre_char, Scheme_Object *init_readtable,
Scheme_Object *magic_sym, Scheme_Object *magic_val)
{
Scheme_Thread *p = scheme_current_thread;
@ -1912,7 +1923,7 @@ scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int ca
scheme_alloc_list_stack(p);
if (cantfail) {
return _scheme_internal_read(port, stxsrc, crc, honu_mode, recur, -1, NULL);
return _scheme_internal_read(port, stxsrc, crc, honu_mode, recur, -1, NULL, magic_sym, magic_val);
} else {
p->ku.k.p1 = (void *)port;
p->ku.k.p2 = (void *)stxsrc;
@ -1921,6 +1932,8 @@ scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int ca
p->ku.k.i3 = recur;
p->ku.k.i4 = pre_char;
p->ku.k.p3 = (void *)init_readtable;
p->ku.k.p4 = (void *)magic_sym;
p->ku.k.p5 = (void *)magic_val;
return (Scheme_Object *)scheme_top_level_do(scheme_internal_read_k, 0);
}
@ -1928,12 +1941,12 @@ scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int ca
Scheme_Object *scheme_read(Scheme_Object *port)
{
return scheme_internal_read(port, NULL, -1, 0, 0, 0, -1, NULL);
return scheme_internal_read(port, NULL, -1, 0, 0, 0, -1, NULL, NULL, NULL);
}
Scheme_Object *scheme_read_syntax(Scheme_Object *port, Scheme_Object *stxsrc)
{
return scheme_internal_read(port, stxsrc, -1, 0, 0, 0, -1, NULL);
return scheme_internal_read(port, stxsrc, -1, 0, 0, 0, -1, NULL, NULL, NULL);
}
Scheme_Object *scheme_resolve_placeholders(Scheme_Object *obj, int mkstx)
@ -3622,6 +3635,7 @@ typedef struct CPort {
Scheme_Hash_Table **ht;
Scheme_Object **symtab;
Scheme_Object *insp; /* inspector for module-variable access */
Scheme_Object *magic_sym, *magic_val;
} CPort;
#define CP_GETC(cp) ((int)(cp->start[cp->pos++]))
#define CP_TELL(port) (port->pos + port->base)
@ -3819,6 +3833,9 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
s = read_compact_chars(port, buffer, BLK_BUF_SIZE, l);
v = scheme_intern_exact_symbol(s, l);
if (SAME_OBJ(v, port->magic_sym))
v = port->magic_val;
l = read_compact_number(port);
RANGE_CHECK(l, < port->symtab_size);
port->symtab[l] = v;
@ -4150,6 +4167,9 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
s = read_compact_chars(port, buffer, BLK_BUF_SIZE, l);
v = scheme_intern_exact_symbol(s, l);
if (SAME_OBJ(v, port->magic_sym))
v = port->magic_val;
l = read_compact_number(port);
RANGE_CHECK(l, < port->symtab_size);
port->symtab[l] = v;
@ -4444,7 +4464,8 @@ static long read_compact_number_from_port(Scheme_Object *port)
/* "#~" has been read */
static Scheme_Object *read_compiled(Scheme_Object *port,
Scheme_Hash_Table **ht)
Scheme_Hash_Table **ht,
ReadParams *params)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *result, *insp;
@ -4533,10 +4554,13 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
rp->symtab_size = symtabsize;
rp->ht = ht;
rp->symtab = symtab;
insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
rp->insp = insp;
rp->magic_sym = params->magic_sym;
rp->magic_val = params->magic_val;
result = read_marshalled(scheme_compilation_top_type, rp);
local_rename_memory = NULL;

3
src/mzscheme/src/schemef.h
View File

@ -293,6 +293,9 @@ MZ_EXTERN Scheme_Object *scheme_load_compiled_stx_string(const char *str, long l
MZ_EXTERN Scheme_Object *scheme_compiled_stx_symbol(Scheme_Object *stx);
MZ_EXTERN Scheme_Object *scheme_eval_compiled_sized_string(const char *str, int len, Scheme_Env *env);
MZ_EXTERN Scheme_Object *scheme_eval_compiled_sized_string_with_magic(const char *str, int len, Scheme_Env *env,
Scheme_Object *magic_symbol, Scheme_Object *magic_val,
int multi_ok);
/*========================================================================*/
/* memory management */

3
src/mzscheme/src/schemex.h
View File

@ -234,6 +234,9 @@ Scheme_Object *(*scheme_eval_compiled_stx_string)(Scheme_Object *expr, Scheme_En
Scheme_Object *(*scheme_load_compiled_stx_string)(const char *str, long len);
Scheme_Object *(*scheme_compiled_stx_symbol)(Scheme_Object *stx);
Scheme_Object *(*scheme_eval_compiled_sized_string)(const char *str, int len, Scheme_Env *env);
Scheme_Object *(*scheme_eval_compiled_sized_string_with_magic)(const char *str, int len, Scheme_Env *env,
Scheme_Object *magic_symbol, Scheme_Object *magic_val,
int multi_ok);
/*========================================================================*/
/* memory management */
/*========================================================================*/

1
src/mzscheme/src/schemex.inc
View File

@ -147,6 +147,7 @@
scheme_extension_table->scheme_load_compiled_stx_string = scheme_load_compiled_stx_string;
scheme_extension_table->scheme_compiled_stx_symbol = scheme_compiled_stx_symbol;
scheme_extension_table->scheme_eval_compiled_sized_string = scheme_eval_compiled_sized_string;
scheme_extension_table->scheme_eval_compiled_sized_string_with_magic = scheme_eval_compiled_sized_string_with_magic;
#ifndef SCHEME_NO_GC
# ifndef SCHEME_NO_GC_PROTO
scheme_extension_table->GC_malloc = GC_malloc;

1
src/mzscheme/src/schemexm.h
View File

@ -147,6 +147,7 @@
#define scheme_load_compiled_stx_string (scheme_extension_table->scheme_load_compiled_stx_string)
#define scheme_compiled_stx_symbol (scheme_extension_table->scheme_compiled_stx_symbol)
#define scheme_eval_compiled_sized_string (scheme_extension_table->scheme_eval_compiled_sized_string)
#define scheme_eval_compiled_sized_string_with_magic (scheme_extension_table->scheme_eval_compiled_sized_string_with_magic)
#ifndef SCHEME_NO_GC
# ifndef SCHEME_NO_GC_PROTO
#define GC_malloc (scheme_extension_table->GC_malloc)

13
src/mzscheme/src/schpriv.h
View File

@ -239,6 +239,7 @@ extern Scheme_Object *scheme_module_stx;
extern Scheme_Object *scheme_begin_stx;
extern Scheme_Object *scheme_define_values_stx;
extern Scheme_Object *scheme_define_syntaxes_stx;
extern Scheme_Object *scheme_top_stx;
extern Scheme_Object *scheme_recur_symbol, *scheme_display_symbol, *scheme_write_special_symbol;
@ -797,7 +798,11 @@ void scheme_ensure_stack_start(Scheme_Thread *p, void *d);
void scheme_jmpup_free(Scheme_Jumpup_Buf *);
void *scheme_enlarge_runstack(long size, void *(*k)());
int scheme_check_runstack(long size);
#ifndef MZ_PRECISE_GC
void scheme_init_setjumpup(void);
void scheme_init_ephemerons(void);
#endif
#ifdef MZ_PRECISE_GC
void scheme_flush_stack_copy_cache(void);
@ -1346,7 +1351,8 @@ Scheme_Object *_scheme_apply_to_list (Scheme_Object *rator, Scheme_Object *rands
Scheme_Object *_scheme_tail_apply_to_list (Scheme_Object *rator, Scheme_Object *rands);
Scheme_Object *scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int cantfail,
int honu_mode, int recur, int pre_char, Scheme_Object *readtable);
int honu_mode, int recur, int pre_char, Scheme_Object *readtable,
Scheme_Object *magic_sym, Scheme_Object *magic_val);
void scheme_internal_display(Scheme_Object *obj, Scheme_Object *port);
void scheme_internal_write(Scheme_Object *obj, Scheme_Object *port);
void scheme_internal_print(Scheme_Object *obj, Scheme_Object *port);
@ -1599,7 +1605,8 @@ int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env);
#define REQUIRE_EXPD 8
#define QUOTE_SYNTAX_EXPD 9
#define DEFINE_FOR_SYNTAX_EXPD 10
#define _COUNT_EXPD_ 11
#define REF_EXPD 11
#define _COUNT_EXPD_ 12
#define scheme_register_syntax(i, fr, fv, fe, pa) \
(scheme_syntax_resolvers[i] = fr, \
@ -1718,6 +1725,7 @@ int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count);
#define SCHEME_NULL_FOR_UNBOUND 512
#define SCHEME_RESOLVE_MODIDS 1024
#define SCHEME_NO_CERT_CHECKS 2048
#define SCHEME_REFERENCING 4096
Scheme_Hash_Table *scheme_map_constants_to_globals(void);
@ -1997,6 +2005,7 @@ extern const char *scheme_compile_stx_string;
extern const char *scheme_expand_stx_string;
extern const char *scheme_application_stx_string;
extern const char *scheme_set_stx_string;
extern const char *scheme_var_ref_string;
extern const char *scheme_begin_stx_string;
void scheme_wrong_rator(Scheme_Object *rator, int argc, Scheme_Object **argv);

4
src/mzscheme/src/schvers.h
View File

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 299
#define MZSCHEME_VERSION_MINOR 405
#define MZSCHEME_VERSION_MINOR 406
#define MZSCHEME_VERSION "299.405" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "299.406" _MZ_SPECIAL_TAG

2
src/mzscheme/src/string.c
View File

@ -1879,7 +1879,7 @@ char *scheme_banner(void)
"3m"
#endif
" version " MZSCHEME_VERSION VERSION_SUFFIX
", Copyright (c) 2004-2005 PLT Scheme, Inc.\n";
", Copyright (c) 2004-2005 PLT Scheme Inc.\n";
}
void scheme_set_banner(char *s)

115
src/mzscheme/src/stypes.h
View File

@ -147,66 +147,67 @@ enum {
scheme_intdef_context_type, /* 129 */
scheme_lexical_rib_type, /* 130 */
scheme_thread_cell_values_type, /* 131 */
scheme_global_ref_type, /* 132 */
#ifdef MZTAG_REQUIRED
_scheme_last_normal_type_, /* 132 */
_scheme_last_normal_type_, /* 133 */
scheme_rt_comp_env, /* 133 */
scheme_rt_constant_binding, /* 134 */
scheme_rt_resolve_info, /* 135 */
scheme_rt_compile_info, /* 136 */
scheme_rt_cont_mark, /* 137 */
scheme_rt_saved_stack, /* 138 */
scheme_rt_reply_item, /* 139 */
scheme_rt_closure_info, /* 140 */
scheme_rt_overflow, /* 141 */
scheme_rt_dyn_wind_cell, /* 142 */
scheme_rt_cont_mark_chain, /* 143 */
scheme_rt_dyn_wind_info, /* 144 */
scheme_rt_dyn_wind, /* 145 */
scheme_rt_dup_check, /* 146 */
scheme_rt_thread_memory, /* 147 */
scheme_rt_input_file, /* 148 */
scheme_rt_input_fd, /* 149 */
scheme_rt_oskit_console_input, /* 150 */
scheme_rt_tested_input_file, /* 151 */
scheme_rt_tested_output_file, /* 152 */
scheme_rt_indexed_string, /* 153 */
scheme_rt_output_file, /* 154 */
scheme_rt_load_handler_data, /* 155 */
scheme_rt_pipe, /* 156 */
scheme_rt_beos_process, /* 157 */
scheme_rt_system_child, /* 158 */
scheme_rt_tcp, /* 159 */
scheme_rt_write_data, /* 160 */
scheme_rt_tcp_select_info, /* 161 */
scheme_rt_namespace_option, /* 162 */
scheme_rt_param_data, /* 163 */
scheme_rt_will, /* 164 */
scheme_rt_will_registration, /* 165 */
scheme_rt_struct_proc_info, /* 166 */
scheme_rt_linker_name, /* 167 */
scheme_rt_param_map, /* 168 */
scheme_rt_finalization, /* 169 */
scheme_rt_finalizations, /* 170 */
scheme_rt_cpp_object, /* 171 */
scheme_rt_cpp_array_object, /* 172 */
scheme_rt_stack_object, /* 173 */
scheme_rt_preallocated_object, /* 174 */
scheme_thread_hop_type, /* 175 */
scheme_rt_srcloc, /* 176 */
scheme_rt_evt, /* 177 */
scheme_rt_syncing, /* 178 */
scheme_rt_comp_prefix, /* 179 */
scheme_rt_user_input, /* 180 */
scheme_rt_user_output, /* 181 */
scheme_rt_compact_port, /* 182 */
scheme_rt_read_special_dw, /* 183 */
scheme_rt_regwork, /* 184 */
scheme_rt_buf_holder, /* 185 */
scheme_rt_parameterization, /* 186 */
scheme_rt_print_params, /* 187 */
scheme_rt_read_params, /* 188 */
scheme_rt_comp_env, /* 134 */
scheme_rt_constant_binding, /* 135 */
scheme_rt_resolve_info, /* 136 */
scheme_rt_compile_info, /* 137 */
scheme_rt_cont_mark, /* 138 */
scheme_rt_saved_stack, /* 139 */
scheme_rt_reply_item, /* 140 */
scheme_rt_closure_info, /* 141 */
scheme_rt_overflow, /* 142 */
scheme_rt_dyn_wind_cell, /* 143 */
scheme_rt_cont_mark_chain, /* 144 */
scheme_rt_dyn_wind_info, /* 145 */
scheme_rt_dyn_wind, /* 146 */
scheme_rt_dup_check, /* 147 */
scheme_rt_thread_memory, /* 148 */
scheme_rt_input_file, /* 149 */
scheme_rt_input_fd, /* 150 */
scheme_rt_oskit_console_input, /* 151 */
scheme_rt_tested_input_file, /* 152 */
scheme_rt_tested_output_file, /* 153 */
scheme_rt_indexed_string, /* 154 */
scheme_rt_output_file, /* 155 */
scheme_rt_load_handler_data, /* 156 */
scheme_rt_pipe, /* 157 */
scheme_rt_beos_process, /* 158 */
scheme_rt_system_child, /* 159 */
scheme_rt_tcp, /* 160 */
scheme_rt_write_data, /* 161 */
scheme_rt_tcp_select_info, /* 162 */
scheme_rt_namespace_option, /* 163 */
scheme_rt_param_data, /* 164 */
scheme_rt_will, /* 165 */
scheme_rt_will_registration, /* 166 */
scheme_rt_struct_proc_info, /* 167 */
scheme_rt_linker_name, /* 168 */
scheme_rt_param_map, /* 169 */
scheme_rt_finalization, /* 170 */
scheme_rt_finalizations, /* 171 */
scheme_rt_cpp_object, /* 172 */
scheme_rt_cpp_array_object, /* 173 */
scheme_rt_stack_object, /* 174 */
scheme_rt_preallocated_object, /* 175 */
scheme_thread_hop_type, /* 176 */
scheme_rt_srcloc, /* 177 */
scheme_rt_evt, /* 178 */
scheme_rt_syncing, /* 179 */
scheme_rt_comp_prefix, /* 180 */
scheme_rt_user_input, /* 181 */
scheme_rt_user_output, /* 182 */
scheme_rt_compact_port, /* 183 */
scheme_rt_read_special_dw, /* 184 */
scheme_rt_regwork, /* 185 */
scheme_rt_buf_holder, /* 186 */
scheme_rt_parameterization, /* 187 */
scheme_rt_print_params, /* 188 */
scheme_rt_read_params, /* 189 */
#endif
_scheme_last_type_

118
src/mzscheme/src/syntax.c
View File

@ -33,6 +33,7 @@
/* globals */
Scheme_Object *scheme_define_values_syntax, *scheme_define_syntaxes_syntax;
Scheme_Object *scheme_ref_syntax;
Scheme_Object *scheme_begin_syntax;
Scheme_Object *scheme_lambda_syntax;
Scheme_Object *scheme_compiled_void_code;
@ -48,6 +49,8 @@ static Scheme_Object *lambda_syntax(Scheme_Object *form, Scheme_Comp_Env *env, S
static Scheme_Object *lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
static Scheme_Object *define_values_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
static Scheme_Object *define_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
static Scheme_Object *ref_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
static Scheme_Object *ref_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
static Scheme_Object *quote_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
static Scheme_Object *quote_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
static Scheme_Object *if_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
@ -89,6 +92,7 @@ static Scheme_Object *letrec_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_En
static Scheme_Object *letrec_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
static Scheme_Object *define_values_execute(Scheme_Object *data);
static Scheme_Object *ref_execute(Scheme_Object *data);
static Scheme_Object *set_execute(Scheme_Object *data);
static Scheme_Object *define_syntaxes_execute(Scheme_Object *expr);
static Scheme_Object *define_for_syntaxes_execute(Scheme_Object *expr);
@ -100,6 +104,7 @@ static Scheme_Object *bangboxenv_execute(Scheme_Object *data);
static Scheme_Object *bangboxvalue_execute(Scheme_Object *data);
static Scheme_Object *define_values_resolve(Scheme_Object *data, Resolve_Info *info);
static Scheme_Object *ref_resolve(Scheme_Object *data, Resolve_Info *info);
static Scheme_Object *set_resolve(Scheme_Object *data, Resolve_Info *info);
static Scheme_Object *define_syntaxes_resolve(Scheme_Object *expr, Resolve_Info *info);
static Scheme_Object *define_for_syntaxes_resolve(Scheme_Object *expr, Resolve_Info *info);
@ -108,6 +113,8 @@ static Scheme_Object *begin0_resolve(Scheme_Object *data, Resolve_Info *info);
static void define_values_validate(Scheme_Object *data, Mz_CPort *port, char *stack, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes);
static void ref_validate(Scheme_Object *data, Mz_CPort *port, char *stack, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes);
static void set_validate(Scheme_Object *data, Mz_CPort *port, char *stack, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes);
static void define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, char *stack, int depth, int letlimit, int delta,
@ -212,6 +219,9 @@ scheme_init_syntax (Scheme_Env *env)
scheme_register_syntax(SET_EXPD,
set_resolve, set_validate,
set_execute, 2);
scheme_register_syntax(REF_EXPD,
ref_resolve, ref_validate,
ref_execute, 0);
scheme_register_syntax(DEFINE_SYNTAX_EXPD,
define_syntaxes_resolve, define_syntaxes_validate,
define_syntaxes_execute, 4);
@ -285,6 +295,10 @@ scheme_init_syntax (Scheme_Env *env)
scheme_make_compiled_syntax(set_syntax,
set_expand),
env);
scheme_add_global_keyword("#%variable-reference",
scheme_make_compiled_syntax(ref_syntax,
ref_expand),
env);
scheme_add_global_keyword("case-lambda",
scheme_make_compiled_syntax(case_lambda_syntax,
@ -1366,6 +1380,110 @@ set_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec,
0, 2);
}
/**********************************************************************/
/* #%variable-reference */
/**********************************************************************/
static Scheme_Object *
ref_execute (Scheme_Object *tl)
{
Scheme_Object **toplevels, *o;
Scheme_Bucket *var;
toplevels = (Scheme_Object **)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(tl)];
var = (Scheme_Bucket *)toplevels[SCHEME_TOPLEVEL_POS(tl)];
o = scheme_alloc_small_object();
o->type = scheme_global_ref_type;
SCHEME_PTR_VAL(o) = (Scheme_Object *)var;
return o;
}
static void ref_validate(Scheme_Object *tl, Mz_CPort *port,
char *stack, int depth, int letlimit, int delta, int num_toplevels, int num_stxes)
{
scheme_validate_toplevel(tl, port, stack, depth, delta, num_toplevels, num_stxes);
}
static Scheme_Object *
ref_resolve(Scheme_Object *tl, Resolve_Info *rslv)
{
return scheme_make_syntax_resolved(REF_EXPD, scheme_resolve_expr(tl, rslv));
}
static Scheme_Object *
ref_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
{
Scheme_Env *menv = NULL;
Scheme_Object *var, *name, *rest;
int l, ok;
l = check_form(form, form);
if (l != 2)
bad_form(form, l);
rest = SCHEME_STX_CDR(form);
name = SCHEME_STX_CAR(rest);
if (SCHEME_STX_PAIRP(name)) {
rest = SCHEME_STX_CAR(name);
if (env->genv->phase == 0) {
var = scheme_top_stx;
} else {
var = scheme_datum_to_syntax(SCHEME_STX_VAL(scheme_top_stx), scheme_false, scheme_sys_wraps(env), 0, 0);
}
ok = scheme_stx_module_eq(rest, var, env->genv->phase);
} else
ok = SCHEME_STX_SYMBOLP(name);
if (!ok) {
scheme_wrong_syntax("#%variable-reference", name,
form,
"not an identifier or #%%top form");
return NULL;
}
if (SCHEME_STX_PAIRP(name)) {
var = scheme_expand_expr(name, env, rec, drec);
} else {
scheme_rec_add_certs(rec, drec, form);
var = scheme_lookup_binding(name, env,
SCHEME_REFERENCING
+ SCHEME_GLOB_ALWAYS_REFERENCE
+ (rec[drec].dont_mark_local_use
? SCHEME_DONT_MARK_USE
: 0)
+ (rec[drec].resolve_module_ids
? SCHEME_RESOLVE_MODIDS
: 0),
rec[drec].certs, env->in_modidx,
&menv, NULL);
if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)
|| SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) {
var = scheme_register_toplevel_in_prefix(var, env, rec, drec);
} else {
scheme_wrong_syntax(NULL, name, form, "identifier does not refer to a top-level or module variable");
}
scheme_compile_rec_done_local(rec, drec);
}
return scheme_make_syntax_compiled(REF_EXPD, var);
}
static Scheme_Object *
ref_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
{
/* Error checking: */
ref_syntax(form, env, erec, drec);
/* No change: */
return form;
}
/**********************************************************************/
/* case-lambda */
/**********************************************************************/

2
src/mzscheme/src/thread.c
View File

@ -3105,7 +3105,7 @@ static int check_sleep(int need_activity, int sleep_now)
}
scheme_sleep(mst, fds);
} else
} else if (scheme_wakeup_on_input)
scheme_wakeup_on_input(fds);
return 1;

6
src/mzscheme/src/type.c
View File

@ -226,6 +226,8 @@ scheme_init_type (Scheme_Env *env)
set_name(scheme_certifications_type, "<certifications>");
set_name(scheme_global_ref_type, "<variable-reference>");
set_name(scheme_intdef_context_type, "<internal-definition-context>");
set_name(scheme_lexical_rib_type, "<internal:lexical-rib>");
@ -529,8 +531,10 @@ void scheme_register_traversers(void)
GC_REG_TRAV(scheme_progress_evt_type, twoptr_obj);
GC_REG_TRAV(scheme_already_comp_type, iptr_obj);
GC_REG_TRAV(scheme_thread_cell_values_type, small_object);
GC_REG_TRAV(scheme_global_ref_type, small_object);
}
END_XFORM_SKIP;