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

3m and mzc

Browse Source 
svn: r1353
This commit is contained in:
Matthew Flatt 2005-11-19 16:19:42 +00:00
parent 5ee0710166
commit 58b6198fa5
21 changed files with 486 additions and 267 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
collects/compiler/mzc.h
View File

@ -67,14 +67,28 @@ static void closure_alloc_inc()
# define CLOSURE_ALLOC_PP /**/
#endif
#ifdef MZ_PRECISE_GC
# define MZC_INSTALL_DATA_PTR(rec) rec
# define MZC_PARAM_TO_SWITCH(void_param) *(unsigned int *)((Scheme_Closed_Primitive_Post_Ext_Proc *)void_param)->a
# define MZC_ENV_POINTER(t, ct, void_param) (&(((const ct *)void_param)->data))
#else
# define MZC_INSTALL_DATA_PTR(rec) &rec->data
# define MZC_PARAM_TO_SWITCH(void_param) *(unsigned int*)void_param
# define MZC_ENV_POINTER(t, ct, void_param) ((const t *)void_param)
#endif
#define _scheme_make_c_proc_closure(cfunc, rec, name, amin, amax, flags) \
(CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_closure(&rec->prim, cfunc, &rec->data, name, amin, amax, flags))
(CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_closure_post(&rec->prim, cfunc, MZC_INSTALL_DATA_PTR(rec), \
name, amin, amax, flags, \
sizeof(rec->data)>>2))
#define _scheme_make_c_proc_closure_empty(cfunc, rec, name, amin, amax, flags) \
(CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_closure(&rec->prim, cfunc, NULL, name, amin, amax, flags))
#define _scheme_make_c_case_proc_closure(cfunc, rec, name, ccnt, cses, flags) \
(CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_case_closure(&rec->prim, cfunc, &rec->data, name, ccnt, cses, flags))
(CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_case_closure_post(&rec->prim, cfunc, MZC_INSTALL_DATA_PTR(rec), \
name, ccnt, cses, flags, \
sizeof(rec->data)>>2))
#define _scheme_make_c_case_proc_closure_empty(cfunc, rec, name, ccnt, cses, flags) \
(CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_case_closure(&rec->prim, cfunc, NULL, name, ccnt, cses, flags))
@ -301,3 +315,42 @@ static Scheme_Object *DEBUG_CHECK(Scheme_Object *v)
return v;
}
#endif
#ifdef MZ_PRECISE_GC
START_XFORM_SUSPEND;
static MZC_INLINE Scheme_Object *
_mzc_direct_apply_primitive_multi(Scheme_Object *prim, int argc, Scheme_Object **argv)
{
return _scheme_direct_apply_primitive_multi(prim, argc, argv);
}
static MZC_INLINE Scheme_Object *
_mzc_direct_apply_primitive(Scheme_Object *prim, int argc, Scheme_Object **argv)
{
return _scheme_direct_apply_primitive(prim, argc, argv);
}
static MZC_INLINE Scheme_Object *
_mzc_direct_apply_closed_primitive_multi(Scheme_Object *prim, int argc, Scheme_Object **argv)
{
return _scheme_direct_apply_closed_primitive_multi(prim, argc, argv);
}
static MZC_INLINE Scheme_Object *
_mzc_direct_apply_closed_primitive(Scheme_Object *prim, int argc, Scheme_Object **argv)
{
return _scheme_direct_apply_closed_primitive(prim, argc, argv);
}
END_XFORM_SUSPEND;
#else
# define _mzc_direct_apply_primitive_multi(prim, argc, argv) \
_scheme_direct_apply_primitive_multi(prim, argc, argv)
# define _mzc_direct_apply_primitive(prim, argc, argv) \
_scheme_direct_apply_primitive(prim, argc, argv)
# define _mzc_direct_apply_closed_primitive_multi(prim, argc, argv) \
_scheme_direct_apply_closed_primitive_multi(prim, argc, argv)
# define _mzc_direct_apply_closed_primitive(prim, argc, argv) \
_scheme_direct_apply_closed_primitive(prim, argc, argv)
#endif
#define _mzc_apply(r,n,rs) _scheme_apply(r,n,rs)
#define _mzc_apply_multi(r,n,rs) _scheme_apply_multi(r,n,rs)
#define _mzc_apply_known_closed_prim(r,n,rs) _scheme_apply_known_closed_prim(r,n,rs)
#define _mzc_apply_known_closed_prim_multi(r,n,rs) _scheme_apply_known_closed_prim_multi(r,n,rs)

1
collects/compiler/option-unit.ss
View File

@ -29,6 +29,7 @@
(define debug (make-parameter #f))
(define test (make-parameter #f))
(define clean-intermediate-files (make-parameter #t))
(define 3m (make-parameter #f))
(define max-exprs-per-top-level-set (make-parameter 25))

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

@ -71,11 +71,13 @@
(lib "toplevel.ss" "syntax")
(lib "compile-sig.ss" "dynext")
(lib "link-sig.ss" "dynext")
(lib "file-sig.ss" "dynext"))
(lib "file-sig.ss" "dynext")
(lib "plthome.ss" "setup"))
(require "../sig.ss"
"sig.ss"
"../to-core.ss")
"../to-core.ss"
"../xform.ss")
(provide driver@)
@ -118,7 +120,7 @@
;; FILE PROCESSING FUNCTIONS
;;
;; takes an input-name from the compile command and returns 4 values
;; takes an input-name from the compile command and returns many values:
;; 1) an input path
;; 2) a C output path
;; 3) a constant pool output path
@ -126,30 +128,41 @@
;; 5) a dll output path
;; 6) a scheme_setup suffix
(define s:process-filenames
(lambda (input-name dest-dir from-c? tmp-c? tmp-o?)
(lambda (input-name dest-dir from-c? 3m? tmp-c? tmp-c3m? tmp-o?)
(let-values ([(basedir file dir?) (split-path input-name)])
(let* ([dest-dir (if (eq? dest-dir 'auto)
(let ([d (build-path (if (eq? basedir 'relative)
(let* ([d0 (build-path (if (eq? basedir 'relative)
'same
basedir)
"compiled"
"native"
(system-library-subpath))])
(system-library-subpath #f))]
[d (if 3m?
(build-path d0 "3m")
d0)])
(unless (directory-exists? d)
(make-directory* d))
d)
dest-dir)]
[path-prefix (lambda (a b)
(bytes->path (bytes-append a (path->bytes b))))]
[path-suffix (lambda (b a)
(bytes->path (bytes-append (path->bytes b) a)))]
[sbase (extract-base-filename/ss file (if from-c? #f 'mzc))]
[cbase (extract-base-filename/c file (if from-c? 'mzc #f))]
[base (or sbase cbase)]
[c-dir (if tmp-c?
(find-system-path 'temp-dir)
dest-dir)]
[c3m-dir (if tmp-c3m?
(find-system-path 'temp-dir)
dest-dir)]
[c-prefix (if tmp-c?
(lambda (s) (path-prefix #"mzcTMP" s))
values)]
[c3m-prefix (if tmp-c3m?
(lambda (s) (path-prefix #"mzcTMP" s))
values)]
[o-dir (if tmp-o?
(find-system-path 'temp-dir)
dest-dir)]
@ -164,6 +177,8 @@
(if cbase
input-name
(build-path c-dir (c-prefix (append-c-suffix base))))
(and 3m?
(build-path c3m-dir (c-prefix (append-c-suffix (path-suffix base #"3m")))))
(build-path o-dir (o-prefix (append-constant-pool-suffix base)))
(build-path o-dir (o-prefix (append-object-suffix base)))
(build-path dest-dir (append-extension-suffix base))
@ -569,12 +584,14 @@
(const:init-tables!)
(compiler:init-closure-lists!)
; process the input string - try to open the input file
(let-values ([(input-path c-output-path
(let-values ([(input-path c-output-path c3m-output-path
constant-pool-output-path obj-output-path dll-output-path
setup-suffix)
(s:process-filenames input-name dest-directory from-c?
(compiler:option:3m)
(and (compiler:option:clean-intermediate-files)
(not c-only?))
(compiler:option:clean-intermediate-files)
(and (compiler:option:clean-intermediate-files)
(not multi-o?)))])
(unless (or (not input-path) (file-exists? input-path))
@ -588,6 +605,7 @@
(when (file-exists? path) (delete-file path)))
(list (if input-path c-output-path obj-output-path)
(if input-path constant-pool-output-path obj-output-path)
(or c3m-output-path obj-output-path)
obj-output-path dll-output-path))
(when (compiler:option:debug)
@ -692,7 +710,8 @@
#`'#,zodiac:global-assign-id
#`'#,zodiac:safe-vector-ref-id
#`'#,zodiac:global-prepare-id
simple-constant?)])
simple-constant?
'(mzc-cffi))])
(list (zodiac:syntax->zodiac src)
bytecode magic-sym)))
(block-source s:file-block))])
@ -1036,10 +1055,10 @@
(parameterize ([read-case-sensitive #t]) ;; so symbols containing uppercase print like we want
(let ([c-port #f])
(dynamic-wind
;pre
;;pre
(lambda () (set! c-port (open-output-file c-output-path)))
;value
;;value
(lambda ()
(fprintf c-port "#define MZC_SRC_FILE ~s~n" input-name)
(when (compiler:option:unsafe) (fprintf c-port "#define MZC_UNSAFE 1~n"))
@ -1310,6 +1329,37 @@
(vm->c:emit-symbol-list! port "" #f)
(fprintf port " )~n )~n")))))))
;;-----------------------------------------------------------------------
;; 3m xform
;;
(when c3m-output-path
(when (compiler:option:verbose)
(printf " [xforming C to \"~a\"]~n"
c3m-output-path))
(let ([clean-up-src-c
(lambda ()
(when (and (compiler:option:clean-intermediate-files)
(not from-c?)
(file-exists? c-output-path))
(delete-file c-output-path)))])
(with-handlers ([void
(lambda (exn)
(when (compiler:option:clean-intermediate-files)
(when (file-exists? c3m-output-path)
(delete-file c3m-output-path)))
(clean-up-src-c)
(raise exn))])
(xform (not (compiler:option:verbose))
(path->string c-output-path)
c3m-output-path
(list (build-path plthome "include")
(collection-path "compiler")))
(clean-up-src-c))))
;;--------------------------------------------------------------------
;; COMPILATION TO NATIVE CODE
;;
@ -1319,7 +1369,7 @@
(begin
(unless input-path
(printf "\"~a\": ~n" c-output-path))
(printf "\"~a\": ~n" (or c3m-output-path c-output-path)))
(when (compiler:option:verbose) (printf " [compiling native code to \"~a\"]~n"
obj-output-path))
@ -1329,6 +1379,7 @@
(lambda ()
(with-handlers
([void (lambda (exn)
(exit)
(compiler:fatal-error
#f
(string-append
@ -1337,14 +1388,16 @@
(exn-message exn)))
(compiler:report-messages! #t))])
(compile-extension (not (compiler:option:verbose))
c-output-path obj-output-path
(or c3m-output-path c-output-path) obj-output-path
(list (collection-path "compiler")))))])
(verbose-time compile-thunk))
;; clean-up
(when (and (compiler:option:clean-intermediate-files)
input-path)
(delete-file c-output-path))
(if c3m-output-path
(delete-file c3m-output-path)
(delete-file c-output-path)))
(if multi-o?
(printf " [output to \"~a\"]~n" obj-output-path)

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

@ -47,7 +47,9 @@
;; 'scheme-per-load-static
;; 'label
;; 'prim
;; 'prim-empty
;; 'prim-case
;; 'prim-case-empty
;; 'begin0-saver
;; 'wcm-saver
(define-struct rep:pointer (to))
@ -199,8 +201,12 @@
(make-rep:struct-field 'prim
'prim
(if (= 1 (length (procedure-code-case-codes code)))
(if struct
(make-rep:atomic 'prim)
(make-rep:atomic 'prim-case))))]
(make-rep:atomic 'prim-empty))
(if struct
(make-rep:atomic 'prim-case)
(make-rep:atomic 'prim-case-empty)))))]
[else
(compiler:internal-error
#f

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

@ -183,23 +183,28 @@
(define (vm->c:emit-symbol-definitions! port)
(unless (zero? (const:get-symbol-counter))
(fprintf port " int i;~n")
(fprintf port " for (i = ~a; i--; )~n SYMBOLS[i] = scheme_intern_exact_symbol(SYMBOL_STRS[i], SYMBOL_LENS[i]);~n"
(fprintf port " int i;\n Scheme_Object *s;\n")
(fprintf port " for (i = ~a; i--; ) {\n"
(const:get-symbol-counter))
(fprintf port " s = scheme_intern_exact_symbol(SYMBOL_STRS[i], SYMBOL_LENS[i]);\n")
(fprintf port " SYMBOLS[i] = s; \n }\n")
;; Some symbols might be uninterned...
(hash-table-for-each
(const:get-symbol-table)
(lambda (sym b)
(unless (interned? sym)
(let ([pos (zodiac:varref-var b)])
(fprintf port " SYMBOLS[~a] = scheme_make_exact_symbol(SYMBOL_STRS[~a], SYMBOL_LENS[~a]); /* uninterned */~n"
pos pos pos)))))))
(fprintf port " s = scheme_make_exact_symbol(SYMBOL_STRS[~a], SYMBOL_LENS[~a]); /* uninterned */~n"
pos pos)
(fprintf port " SYMBOLS[~a] = s;\n" pos)))))))
(define (vm->c:emit-inexact-definitions! port)
(unless (zero? (const:get-inexact-counter))
(fprintf port " int i;~n")
(fprintf port " for (i = ~a; i--; )~n INEXACTS[i] = scheme_make_double(INEXACT_NUMBERS[i]);~n"
(const:get-inexact-counter))))
(fprintf port " int i;\n Scheme_Object *n;\n")
(fprintf port " for (i = ~a; i--; ) {\n"
(const:get-inexact-counter))
(fprintf port " n = scheme_make_double(INEXACT_NUMBERS[i]);\n")
(fprintf port " INEXACTS[i] = n; \n }\n")))
(define vm->c:emit-prim-ref-declarations!
(lambda (port)
@ -255,6 +260,7 @@
(define (emit-static-variable-fields! port l)
(unless (null? l)
(fprintf port "#ifndef MZ_PRECISE_GC~n")
(fprintf port " /* Write fields as an array to help C compilers */~n")
(fprintf port " /* that don't like really big records. */~n")
(fprintf port " Scheme_Object * _consts_[~a];~n" (length l))
@ -262,7 +268,13 @@
(unless (null? l)
(fprintf port "# define ~a _consts_[~a]~n"
(vm->c:convert-symbol (car l)) n)
(svloop (cdr l) (add1 n))))))
(svloop (cdr l) (add1 n))))
(fprintf port "#else~n")
(for-each (lambda (c)
(fprintf port " Scheme_Object * ~a;~n"
(vm->c:convert-symbol c)))
l)
(fprintf port "#endif~n")))
;; when statics have binding information, this will look more like
;; emit-local-variable-declarations!
@ -430,18 +442,18 @@
(procedure-vehicle-max-args vehicle)
0)])
(when (> max-arity 0)
; emit declaration of argument stack
;; emit declaration of argument stack
(fprintf port "~aScheme_Object * arg[~a];~n"
vm->c:indent-spaces
max-arity))
(when (> max-args 0)
; emit declaration of global variables for argument passing
;; emit declaration of global variables for argument passing
(let loop ([n 0])
(unless (= n max-args)
(fprintf port "~aregister long reg~a;~n" vm->c:indent-spaces n)
(loop (+ n 1)))))
(when (> max-arity 0)
; tail-buffer-setup
;; tail-buffer-setup
(fprintf port "~aScheme_Object ** tail_buf;~n"
vm->c:indent-spaces)))
@ -452,10 +464,10 @@
(vm->c:emit-local-variable-declarations! locals vm->c:indent-spaces port)))
(vehicle-lambdas vehicle)))
; emit jump to function...
;; emit jump to function...
(when (> (vehicle-total-labels vehicle) 1)
; emit switch dispatcher
(fprintf port "~aswitch(*(unsigned int*)void_param)~n~a{ "
;; emit switch dispatcher
(fprintf port "~aswitch(MZC_PARAM_TO_SWITCH(void_param))~n~a{ "
vm->c:indent-spaces
vm->c:indent-spaces )
(let loop ([n 0])
@ -482,8 +494,10 @@
[(scheme-bucket) "Scheme_Bucket *"]
[(scheme-per-load-static) "struct Scheme_Per_Load_Statics *"]
[(label) "int"]
[(prim) "Scheme_Closed_Primitive_Proc"]
[(prim-case) "Scheme_Closed_Case_Primitive_Proc"]
[(prim) "Scheme_Closed_Primitive_Post_Proc"]
[(prim-empty) "Scheme_Closed_Primitive_Proc"]
[(prim-case) "Scheme_Closed_Case_Primitive_Post_Proc"]
[(prim-case-empty) "Scheme_Closed_Case_Primitive_Proc"]
[(begin0-saver) "_Scheme_Begin0_Rec"]
[(wcm-saver) "_Scheme_WCM_Rec"]
[else (compiler:internal-error
@ -505,8 +519,19 @@
(lambda (rep)
(let ([s (if (rep:struct? rep)
(string-append "struct " (vm->c:convert-symbol (rep:struct-name rep)))
(vm->c:convert-type-definition rep))])
(format "(~a *)scheme_malloc(sizeof(~a))" s s))))
(vm->c:convert-type-definition rep))]
[tagged (if (let tagged? ([rep rep])
(or (and (rep:atomic? rep)
(memq (rep:atomic-type rep)
'(prim prim-empty prim-case prim-case-empty)))
(and (rep:struct? rep)
(pair? (rep:struct-fields rep))
(tagged? (car (rep:struct-fields rep))))
(and (rep:struct-field? rep)
(tagged? (rep:struct-field-rep rep)))))
"_tagged"
"")])
(format "(~a *)scheme_malloc~a(sizeof(~a))" s tagged s))))
(define vm->c:emit-local-variable-declarations!
(lambda (locals indent port)
@ -617,7 +642,7 @@
(get-dest n)
(get-cast n #f)))
(fprintf port
"~a~a~a = ~ascheme_build_list(argc-~a, argv+~a);~n"
"~a~a~a = ~ascheme_build_list_offset(argc, argv, ~a);~n"
indent
(if (dest-boxed? n)
"*(Scheme_Object * *)"
@ -626,7 +651,6 @@
(if (dest-boxed? n)
""
(get-cast n #t))
n
n)
(loop (cdr args) (sub1 n) #f)]))))))
@ -820,10 +844,13 @@
(let ([r (closure-code-rep code)])
(when r
; (fprintf port "~aconst ~a * env;~n" indent (vm->c:convert-type-definition r))
(fprintf port "#~adefine env ((const ~a *)void_param)~n" indent (vm->c:convert-type-definition r))))
;; (fprintf port "~aconst ~a * env;~n" indent (vm->c:convert-type-definition r))
(fprintf port "#~adefine env MZC_ENV_POINTER(~a, ~a, void_param)~n"
indent
(vm->c:convert-type-definition r)
(vm->c:convert-type-definition (closure-code-alloc-rep code)))))
; Registers into local vars
;; Registers into local vars
(let* ([args (zodiac:arglist-vars (list-ref (zodiac:case-lambda-form-args L) which))])
(vm->c:extract-arguments-into-variables!
args
@ -1105,7 +1132,7 @@
(process-set! (car vars) val #t)
(begin
(emit "{ Scheme_Object * res = ")
(emit "{ Scheme_Object * res; res = ")
(process val indent-level #f #t)
(emit "; ")
(unless return-arity-ok?
@ -1366,7 +1393,7 @@
(emit-expr "")
(when (vm:apply-simple-tail-prim? ast)
(emit "return "))
(emit "_scheme_~a("
(emit "_mzc_~a("
(let ([v (global-defined-value* (vm:apply-prim ast))])
(cond
[(and (primitive-closure? v)

3
collects/compiler/sig.ss
View File

@ -23,6 +23,9 @@
clean-intermediate-files ; #t => keep intermediate .c/.o files
; default = #f
3m ; #t => build for 3m
; default = #f
compile-subcollections ; #t => use 'compile-subcollections
; from infor for collection compiling
; default = #t

10
collects/compiler/start.ss
View File

@ -56,8 +56,6 @@
(define plt-setup-collections (make-parameter null))
(define plt-include-compiled (make-parameter #f))
(define use-3m (make-parameter #f))
(define (extract-suffix appender)
(bytes->string/latin-1
(subbytes
@ -144,7 +142,7 @@
,(lambda (f) (module-mode #t))
("Skip eval of top-level syntax, etc. for -e/-c/-o/-z")]
[("--3m")
,(lambda (f) (use-3m #t))
,(lambda (f) (compiler:option:3m #t))
("Compile/link for 3m, with -e/-c/-o/etc.")]
[("--embedded")
,(lambda (f) (compiler:option:compile-for-embedded #t))
@ -167,7 +165,7 @@
(auto-dest-dir #t))
(,(format "Output -z to \"compiled\", -e to ~s"
(path->string
(build-path "compiled" "native" (system-library-subpath)))))]]
(build-path "compiled" "native" (system-library-subpath #f)))))]]
[help-labels
"------------------- compiler/linker configuration flags ---------------------"]
@ -385,7 +383,7 @@
(void)))))))
(list "file/directory/collection" "file/directory/sub-collection")))
(printf "MzScheme compiler (mzc) version ~a, Copyright (c) 2005 PLT Scheme, Inc.~n"
(printf "mzc version ~a, Copyright (c) 2004-2005 PLT Scheme Inc.~n"
(version))
(define-values (mode source-files prefix)
@ -399,7 +397,7 @@
(when (compiler:option:compile-for-embedded)
(error 'mzc "cannot ~a an extension for an embedded MzScheme" action)))
(when (use-3m)
(when (compiler:option:3m)
(link-variant '3m)
(compile-variant '3m))

72
collects/compiler/to-core.ss
View File

@ -11,14 +11,15 @@
;; `require-for-syntax', it's a timing issue. For `module', it's
;; because the transformation can only handle a single `module'
;; declaration.
(define (top-level-to-core stx lookup-stx set-stx safe-vector-ref-stx extract-stx simple-constant?)
(define (top-level-to-core stx lookup-stx set-stx safe-vector-ref-stx extract-stx
simple-constant? stop-properties)
(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
simple-constant?)])
simple-constant? stop-properties)])
(values (expand-syntax expr)
#`(module m lang (#%plain-module-begin #,@new-decls))
magic-sym))]
@ -27,13 +28,13 @@
(lift-sequence (flatten-decls (syntax->list #'(decl ...)))
lookup-stx set-stx safe-vector-ref-stx extract-stx
#f
simple-constant?)])
simple-constant? stop-properties)])
(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
simple-constant?)]))
simple-constant? stop-properties)]))
(define (flatten-decls l)
(apply append
@ -117,7 +118,7 @@
(module-identifier=? #'case-lambda (stx-car rhs))))))
(define (lift-sequence decls lookup-stx set-stx safe-vector-ref-stx extract-stx
in-module? simple-constant?)
in-module? simple-constant? stop-properties)
(let ([ct-vars (make-vars)]
[rt-vars (make-vars)]
[compile-time (datum->syntax-object #f (gensym 'compile-time))]
@ -133,7 +134,7 @@
lookup-stx set-stx safe-vector-ref-stx
compile-time ct-vars
in-module?
simple-constant?)])
simple-constant? stop-properties)])
(if (and (not in-module?)
(module-identifier=? #'def #'define-syntaxes))
;; Don't try to name macro procedures, because it
@ -158,7 +159,7 @@
lookup-stx set-stx safe-vector-ref-stx
run-time rt-vars
in-module?
simple-constant?)])
simple-constant? stop-properties)])
(if (need-thunk? #'rhs)
#`(lambda () #,converted)
#`(let-values ([ids #,converted])
@ -169,7 +170,7 @@
lookup-stx set-stx safe-vector-ref-stx
run-time rt-vars
in-module?
simple-constant?))]))
simple-constant? stop-properties))]))
(filter is-run-time? decls))]
[ct-rhs #`((let ([magic (car (cons '#,magic-sym 2))])
(if (symbol? magic)
@ -325,9 +326,28 @@
(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? simple-constant?)
(define-syntax quasisyntax/loc+props
(syntax-rules ()
[(_ stx e) (let ([old-s stx]
[new-s (quasisyntax e)])
(syntax-recertify
(datum->syntax-object new-s
(syntax-e new-s)
old-s
old-s)
new-s
code-insp
#f))]))
(define code-insp (current-code-inspector))
(define (convert stx trans? lookup-stx set-stx safe-vector-ref-stx id li in-module?
simple-constant? stop-properties)
(define ((loop certs) stx)
(let ([loop (loop (apply-certs stx certs))])
(if (ormap (lambda (prop)
(syntax-property stx prop))
stop-properties)
stx
(kernel-syntax-case stx trans?
[_
(identifier? stx)
@ -336,24 +356,28 @@
[(provide . _)
stx]
[(lambda formals e ...)
(quasisyntax/loc stx
(quasisyntax/loc+props
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
(quasisyntax/loc+props
stx
(case-lambda [formals e ...] ...)))]
[(let-values ([(id ...) rhs] ...) e ...)
(with-syntax ([(rhs ...)
(map loop (syntax->list #'(rhs ...)))])
(quasisyntax/loc stx
(quasisyntax/loc+props
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
(quasisyntax/loc+props
stx
(letrec-values ([(id ...) rhs] ...) #,@(map loop (syntax->list #'(e ...))))))]
[(quote e)
(if (simple-constant? #'e)
@ -378,26 +402,32 @@
(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
(quasisyntax/loc+props stx (set! x #,(loop #'e)))
(quasisyntax/loc+props
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
(quasisyntax/loc+props
stx
(if #,@(map loop (syntax->list #'(e ...)))))]
[(begin e ...)
(quasisyntax/loc stx
(quasisyntax/loc+props
stx
(begin #,@(map loop (syntax->list #'(e ...)))))]
[(begin0 e ...)
(quasisyntax/loc stx
(quasisyntax/loc+props
stx
(begin0 #,@(map loop (syntax->list #'(e ...)))))]
[(with-continuation-mark e ...)
(quasisyntax/loc stx
(quasisyntax/loc+props
stx
(with-continuation-mark #,@(map loop (syntax->list #'(e ...)))))]
[(#%app e ...)
(quasisyntax/loc stx
(#%app #,@(map loop (syntax->list #'(e ...)))))])))
(quasisyntax/loc+props
stx
(#%app #,@(map loop (syntax->list #'(e ...)))))]))))
((loop #'certs) stx))
(define (apply-certs from to)

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

@ -454,6 +454,7 @@ scheme_equal
scheme_equal_hash_key
scheme_equal_hash_key2
scheme_build_list
scheme_build_list_offset
scheme_make_list_immutable
scheme_list_length
scheme_proper_list_length

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

@ -462,6 +462,7 @@ scheme_hash_key
scheme_equal_hash_key
scheme_equal_hash_key2
scheme_build_list
scheme_build_list_offset
scheme_make_list_immutable
scheme_list_length
scheme_proper_list_length

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

@ -446,6 +446,7 @@ EXPORTS
scheme_equal_hash_key
scheme_equal_hash_key2
scheme_build_list
scheme_build_list_offset
scheme_make_list_immutable
scheme_list_length
scheme_proper_list_length

76
src/mzscheme/include/scheme.h
View File

@ -573,6 +573,7 @@ typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Pr
#define SCHEME_PRIM_IS_GENERIC 512
#define SCHEME_PRIM_IS_USER_PARAMETER 1024
#define SCHEME_PRIM_IS_METHOD 2048
#define SCHEME_PRIM_IS_POST_DATA 4096
typedef struct Scheme_Object *
(Scheme_Prim)(int argc, struct Scheme_Object *argv[]);
@ -608,13 +609,58 @@ typedef struct {
typedef struct {
Scheme_Closed_Primitive_Proc p;
mzshort minr, maxr;
} Scheme_Closed_Prim_W_Result_Arity;
mzshort *cases;
} Scheme_Closed_Case_Primitive_Proc;
typedef struct {
Scheme_Closed_Primitive_Proc p;
mzshort *cases;
} Scheme_Closed_Case_Primitive_Proc;
mzshort minr, maxr;
} Scheme_Closed_Prim_W_Result_Arity;
/* ------------------------------------------------- */
/* mzc closure glue
The following structures are used by mzc to implement closures
where the closure data is allocated as part of the
Scheme_Closed_Primitive_Proc record. In 3m mode, a length must be
included, and all of the closur-data elements are assumed to be
pointers. Furthermore, in 3m mode, a cases and non-cases closure
must have closure data starting at the same point, since two
kinds can flow to the same MZC_PARAM_TO_SWITCH().
*/
typedef struct {
union {
Scheme_Closed_Primitive_Proc p;
#ifdef MZ_PRECISE_GC
Scheme_Closed_Case_Primitive_Proc other;
#endif
} u;
#ifdef MZ_PRECISE_GC
mzshort len;
#endif
} Scheme_Closed_Primitive_Post_Proc;
typedef struct {
Scheme_Closed_Primitive_Post_Proc p;
void *a[1];
} Scheme_Closed_Primitive_Post_Ext_Proc;
typedef struct {
union {
Scheme_Closed_Case_Primitive_Proc p;
#ifdef MZ_PRECISE_GC
Scheme_Closed_Primitive_Proc other;
#endif
} u;
#ifdef MZ_PRECISE_GC
mzshort len;
#endif
} Scheme_Closed_Case_Primitive_Post_Proc;
typedef struct {
Scheme_Closed_Case_Primitive_Post_Proc p;
void *a[1];
} Scheme_Closed_Case_Primitive_Post_Ext_Proc;
#define _scheme_fill_prim_closure(rec, cfunc, dt, nm, amin, amax, flgs) \
((rec)->pp.so.type = scheme_closed_prim_type, \
@ -626,6 +672,16 @@ typedef struct {
(rec)->pp.flags = flgs, \
rec)
#ifdef MZ_PRECISE_GC
# define _scheme_fill_prim_closure_post(rec, cfunc, dt, nm, amin, amax, flgs, ln) \
((rec)->len = ln, \
_scheme_fill_prim_closure(&(rec)->u.p, cfunc, dt, nm, amin, amax, \
flgs | SCHEME_PRIM_IS_POST_DATA))
#else
# define _scheme_fill_prim_closure_post(rec, cfunc, dt, nm, amin, amax, flgs, ln) \
_scheme_fill_prim_closure(&(rec)->u.p, cfunc, dt, nm, amin, amax, flgs)
#endif
#define _scheme_fill_prim_case_closure(rec, cfunc, dt, nm, ccount, cses, flgs) \
((rec)->p.pp.so.type = scheme_closed_prim_type, \
(rec)->p.prim_val = cfunc, \
@ -637,6 +693,18 @@ typedef struct {
(rec)->cases = cses, \
rec)
#ifdef MZ_PRECISE_GC
# define _scheme_fill_prim_case_closure_post(rec, cfunc, dt, nm, ccount, cses, flgs, ln) \
((rec)->len = ln, \
_scheme_fill_prim_case_closure(&(rec)->u.p, cfunc, dt, nm, ccount, cses, \
flgs | SCHEME_PRIM_IS_POST_DATA))
#else
# define _scheme_fill_prim_case_closure_post(rec, cfunc, dt, nm, ccount, cses, flgs, ln) \
_scheme_fill_prim_case_closure(&(rec)->u.p, cfunc, dt, nm, ccount, cses, flgs)
#endif
/* ------------------------------------------------- */
#define SCHEME_PROCP(obj) (!SCHEME_INTP(obj) && ((_SCHEME_TYPE(obj) >= scheme_prim_type) && (_SCHEME_TYPE(obj) <= scheme_proc_struct_type)))
#define SCHEME_SYNTAXP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_syntax_compiler_type)
#define SCHEME_PRIMP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_prim_type)

117
src/mzscheme/macglue.inc
View File

@ -1,117 +0,0 @@
#ifndef NO_USER_BREAK_HANDLER
# ifdef MAC_MZ_GUI_ENABLED
extern void (*GC_out_of_memory)(void);
static void MacOutOfMemory(void)
{
Alert(101, NULL);
ExitToShell();
}
static int WeAreFront()
{
static int inited;
static ProcessSerialNumber us;
ProcessSerialNumber front;
Boolean r;
if (!inited) {
GetCurrentProcess(&us);
inited = 1;
}
GetFrontProcess(&front);
SameProcess(&us, &front, &r);
return r;
}
static int is_break_event(EventRecord *e)
{
if ((e->what == keyDown)
&& ((((e->message & charCodeMask) == '.')
&& (e->modifiers & cmdKey))
|| (((e->message & charCodeMask) == 3)
&& (e->modifiers & controlKey))))
return 1;
else
return 0;
}
static int check_break_flag()
{
# ifdef MACINTOSH_GIVE_TIME
static long last_time;
static int front = 1;
if (TickCount() > last_time + (front ? 30 : 0)) {
EventRecord e;
front = WeAreFront();
while (WaitNextEvent(everyEvent, &e, front ? 0 : 30, NULL)) {
if (is_break_event(&e)) {
return 1;
}
# ifdef MACINTOSH_SIOUX
SIOUXHandleOneEvent(&e);
# endif
}
last_time = TickCount();
}
# endif
return 0;
}
static void handle_one(EventRecord *e)
{
if (is_break_event(e))
scheme_break_thread(NULL);
# ifdef MACINTOSH_SIOUX
SIOUXHandleOneEvent(e);
# endif
}
static void MacSleep(float secs, void *fds)
{
EventRecord e;
if (WaitNextEvent(everyEvent, &e, secs * 60, NULL)) {
if (is_break_event(&e))
scheme_break_thread(NULL);
handle_one(&e);
}
}
# endif
#endif
#ifdef MAC_MZ_GUI_ENABLED
void Drop_Runtime(char **argv, int argc)
{
int i;
for (i = 0; i < argc; i++) {
printf("(load \"%s\") ", argv[i]);
}
if (argc) printf("\n");
}
void Drop_Quit()
{
ExitToShell();
}
#endif
#ifndef DONT_PARSE_COMMAND_LINE
# ifdef MACINTOSH_SIOUX
static void SetSIOUX(void)
{
SIOUXSettings.initializeTB = 0;
}
# endif
#endif /* DONT_PARSE_COMMAND_LINE */

6
src/mzscheme/main.c
View File

@ -150,12 +150,6 @@ extern Scheme_Object *scheme_initialize(Scheme_Env *env);
#include "cmdline.inc"
/*========================================================================*/
/* MacOS glue */
/*========================================================================*/
#include "macglue.inc"
/*========================================================================*/
/* OSKit glue */
/*========================================================================*/

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

@ -565,6 +565,18 @@ Scheme_Object *scheme_build_list(int size, Scheme_Object **argv)
return pair;
}
Scheme_Object *scheme_build_list_offset(int size, Scheme_Object **argv, int delta)
{
Scheme_Object *pair = scheme_null;
int i;
for (i = size; i-- > delta; ) {
pair = scheme_make_pair(argv[i], pair);
}
return pair;
}
Scheme_Object *scheme_alloc_list(int size)
{
Scheme_Object *pair = scheme_null;

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

@ -680,8 +680,14 @@ int closed_prim_proc_SIZE(void *p) {
((c->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Prim_W_Result_Arity))
: ((c->mina == -2)
? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc))
: gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc))));
? ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Post_Ext_Proc))
+ ((Scheme_Closed_Case_Primitive_Post_Proc *)c)->len - 1)
: gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc)))
: ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Post_Ext_Proc))
+ ((Scheme_Closed_Primitive_Post_Proc *)c)->len - 1)
: gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc)))));
}
int closed_prim_proc_MARK(void *p) {
@ -689,13 +695,39 @@ int closed_prim_proc_MARK(void *p) {
gcMARK(c->name);
gcMARK(SCHEME_CLSD_PRIM_DATA(c));
if (c->pp.flags & SCHEME_PRIM_IS_POST_DATA) {
if (c->mina == -2) {
Scheme_Closed_Case_Primitive_Post_Ext_Proc *cc;
int i;
cc = (Scheme_Closed_Case_Primitive_Post_Ext_Proc *)c;
for (i = cc->p.len; i--; ) {
gcMARK(cc->a[i]);
}
} else {
Scheme_Closed_Primitive_Post_Ext_Proc *cc;
int i;
cc = (Scheme_Closed_Primitive_Post_Ext_Proc *)c;
for (i = cc->p.len; i--; ) {
gcMARK(cc->a[i]);
}
}
}
if (c->mina == -2) {
gcMARK(((Scheme_Closed_Case_Primitive_Proc *)c)->cases);
}
return
((c->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Prim_W_Result_Arity))
: ((c->mina == -2)
? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc))
: gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc))));
? ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Post_Ext_Proc))
+ ((Scheme_Closed_Case_Primitive_Post_Proc *)c)->len - 1)
: gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc)))
: ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Post_Ext_Proc))
+ ((Scheme_Closed_Primitive_Post_Proc *)c)->len - 1)
: gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc)))));
}
int closed_prim_proc_FIXUP(void *p) {
@ -703,13 +735,39 @@ int closed_prim_proc_FIXUP(void *p) {
gcFIXUP(c->name);
gcFIXUP(SCHEME_CLSD_PRIM_DATA(c));
if (c->pp.flags & SCHEME_PRIM_IS_POST_DATA) {
if (c->mina == -2) {
Scheme_Closed_Case_Primitive_Post_Ext_Proc *cc;
int i;
cc = (Scheme_Closed_Case_Primitive_Post_Ext_Proc *)c;
for (i = cc->p.len; i--; ) {
gcFIXUP(cc->a[i]);
}
} else {
Scheme_Closed_Primitive_Post_Ext_Proc *cc;
int i;
cc = (Scheme_Closed_Primitive_Post_Ext_Proc *)c;
for (i = cc->p.len; i--; ) {
gcFIXUP(cc->a[i]);
}
}
}
if (c->mina == -2) {
gcFIXUP(((Scheme_Closed_Case_Primitive_Proc *)c)->cases);
}
return
((c->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Prim_W_Result_Arity))
: ((c->mina == -2)
? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc))
: gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc))));
? ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Post_Ext_Proc))
+ ((Scheme_Closed_Case_Primitive_Post_Proc *)c)->len - 1)
: gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc)))
: ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Post_Ext_Proc))
+ ((Scheme_Closed_Primitive_Post_Proc *)c)->len - 1)
: gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc)))));
}
#define closed_prim_proc_IS_ATOMIC 0

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

@ -253,13 +253,39 @@ closed_prim_proc {
mark:
gcMARK(c->name);
gcMARK(SCHEME_CLSD_PRIM_DATA(c));
if (c->pp.flags & SCHEME_PRIM_IS_POST_DATA) {
if (c->mina == -2) {
Scheme_Closed_Case_Primitive_Post_Ext_Proc *cc;
int i;
cc = (Scheme_Closed_Case_Primitive_Post_Ext_Proc *)c;
for (i = cc->p.len; i--; ) {
gcMARK(cc->a[i]);
}
} else {
Scheme_Closed_Primitive_Post_Ext_Proc *cc;
int i;
cc = (Scheme_Closed_Primitive_Post_Ext_Proc *)c;
for (i = cc->p.len; i--; ) {
gcMARK(cc->a[i]);
}
}
}
if (c->mina == -2) {
gcMARK(((Scheme_Closed_Case_Primitive_Proc *)c)->cases);
}
size:
((c->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Prim_W_Result_Arity))
: ((c->mina == -2)
? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc))
: gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc))));
? ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Post_Ext_Proc))
+ ((Scheme_Closed_Case_Primitive_Post_Proc *)c)->len - 1)
: gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc)))
: ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Post_Ext_Proc))
+ ((Scheme_Closed_Primitive_Post_Proc *)c)->len - 1)
: gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc)))));
}
scm_closure {

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

@ -914,6 +914,7 @@ MZ_EXTERN long scheme_equal_hash_key(Scheme_Object *o);
MZ_EXTERN long scheme_equal_hash_key2(Scheme_Object *o);
MZ_EXTERN Scheme_Object *scheme_build_list(int argc, Scheme_Object **argv);
MZ_EXTERN Scheme_Object *scheme_build_list_offset(int argc, Scheme_Object **argv, int delta);
MZ_EXTERN void scheme_make_list_immutable(Scheme_Object *l);
MZ_EXTERN int scheme_list_length(Scheme_Object *list);

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

@ -752,6 +752,7 @@ long (*scheme_hash_key)(Scheme_Object *o);
long (*scheme_equal_hash_key)(Scheme_Object *o);
long (*scheme_equal_hash_key2)(Scheme_Object *o);
Scheme_Object *(*scheme_build_list)(int argc, Scheme_Object **argv);
Scheme_Object *(*scheme_build_list_offset)(int argc, Scheme_Object **argv, int delta);
void (*scheme_make_list_immutable)(Scheme_Object *l);
int (*scheme_list_length)(Scheme_Object *list);
int (*scheme_proper_list_length)(Scheme_Object *list);

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

@ -506,6 +506,7 @@
scheme_extension_table->scheme_equal_hash_key = scheme_equal_hash_key;
scheme_extension_table->scheme_equal_hash_key2 = scheme_equal_hash_key2;
scheme_extension_table->scheme_build_list = scheme_build_list;
scheme_extension_table->scheme_build_list_offset = scheme_build_list_offset;
scheme_extension_table->scheme_make_list_immutable = scheme_make_list_immutable;
scheme_extension_table->scheme_list_length = scheme_list_length;
scheme_extension_table->scheme_proper_list_length = scheme_proper_list_length;

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

@ -506,6 +506,7 @@
#define scheme_equal_hash_key (scheme_extension_table->scheme_equal_hash_key)
#define scheme_equal_hash_key2 (scheme_extension_table->scheme_equal_hash_key2)
#define scheme_build_list (scheme_extension_table->scheme_build_list)
#define scheme_build_list_offset (scheme_extension_table->scheme_build_list_offset)
#define scheme_make_list_immutable (scheme_extension_table->scheme_make_list_immutable)
#define scheme_list_length (scheme_extension_table->scheme_list_length)
#define scheme_proper_list_length (scheme_extension_table->scheme_proper_list_length)