diff --git a/collects/compiler/mzc.h b/collects/compiler/mzc.h index 6d24a04498..dce893466d 100644 --- a/collects/compiler/mzc.h +++ b/collects/compiler/mzc.h @@ -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) diff --git a/collects/compiler/option-unit.ss b/collects/compiler/option-unit.ss index 514f1a5ce7..4644d6916d 100644 --- a/collects/compiler/option-unit.ss +++ b/collects/compiler/option-unit.ss @@ -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)) diff --git a/collects/compiler/private/driver.ss b/collects/compiler/private/driver.ss index 8143b3aedc..91a10d5ee4 100644 --- a/collects/compiler/private/driver.ss +++ b/collects/compiler/private/driver.ss @@ -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) - 'same - basedir) - "compiled" - "native" - (system-library-subpath))]) + (let* ([d0 (build-path (if (eq? basedir 'relative) + 'same + basedir) + "compiled" + "native" + (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? + (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) diff --git a/collects/compiler/private/rep.ss b/collects/compiler/private/rep.ss index 42306909c2..d943250971 100644 --- a/collects/compiler/private/rep.ss +++ b/collects/compiler/private/rep.ss @@ -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))) - (make-rep:atomic 'prim) - (make-rep:atomic 'prim-case))))] + (if struct + (make-rep:atomic 'prim) + (make-rep:atomic 'prim-empty)) + (if struct + (make-rep:atomic 'prim-case) + (make-rep:atomic 'prim-case-empty)))))] [else (compiler:internal-error #f diff --git a/collects/compiler/private/vm2c.ss b/collects/compiler/private/vm2c.ss index 311d284cb8..2d59f607e4 100644 --- a/collects/compiler/private/vm2c.ss +++ b/collects/compiler/private/vm2c.ss @@ -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) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index b351979c1c..f21117d961 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -22,6 +22,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 diff --git a/collects/compiler/start.ss b/collects/compiler/start.ss index 5bf279c4fb..4cf3cc7dd7 100644 --- a/collects/compiler/start.ss +++ b/collects/compiler/start.ss @@ -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)) diff --git a/collects/compiler/to-core.ss b/collects/compiler/to-core.ss index 5b4c966dd1..c445715992 100644 --- a/collects/compiler/to-core.ss +++ b/collects/compiler/to-core.ss @@ -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,79 +326,108 @@ (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))]) - (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 ...)))))]))) + (if (ormap (lambda (prop) + (syntax-property stx prop)) + stop-properties) + stx + (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+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+props + stx + (case-lambda [formals e ...] ...)))] + [(let-values ([(id ...) rhs] ...) e ...) + (with-syntax ([(rhs ...) + (map loop (syntax->list #'(rhs ...)))]) + (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+props + 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+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+props + stx + (if #,@(map loop (syntax->list #'(e ...)))))] + [(begin e ...) + (quasisyntax/loc+props + stx + (begin #,@(map loop (syntax->list #'(e ...)))))] + [(begin0 e ...) + (quasisyntax/loc+props + stx + (begin0 #,@(map loop (syntax->list #'(e ...)))))] + [(with-continuation-mark e ...) + (quasisyntax/loc+props + stx + (with-continuation-mark #,@(map loop (syntax->list #'(e ...)))))] + [(#%app e ...) + (quasisyntax/loc+props + stx + (#%app #,@(map loop (syntax->list #'(e ...)))))])))) ((loop #'certs) stx)) (define (apply-certs from to) diff --git a/src/mzscheme/include/mzscheme.exp b/src/mzscheme/include/mzscheme.exp index 41155527c8..c4cd213c65 100644 --- a/src/mzscheme/include/mzscheme.exp +++ b/src/mzscheme/include/mzscheme.exp @@ -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 diff --git a/src/mzscheme/include/mzscheme3m.exp b/src/mzscheme/include/mzscheme3m.exp index cb40425180..d8fd1f147e 100644 --- a/src/mzscheme/include/mzscheme3m.exp +++ b/src/mzscheme/include/mzscheme3m.exp @@ -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 diff --git a/src/mzscheme/include/mzwin.def b/src/mzscheme/include/mzwin.def index 6df0263896..4814cca35a 100644 --- a/src/mzscheme/include/mzwin.def +++ b/src/mzscheme/include/mzwin.def @@ -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 diff --git a/src/mzscheme/include/scheme.h b/src/mzscheme/include/scheme.h index f423bc9151..cfd348a2df 100644 --- a/src/mzscheme/include/scheme.h +++ b/src/mzscheme/include/scheme.h @@ -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) diff --git a/src/mzscheme/macglue.inc b/src/mzscheme/macglue.inc deleted file mode 100644 index dedf3df3f4..0000000000 --- a/src/mzscheme/macglue.inc +++ /dev/null @@ -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 */ diff --git a/src/mzscheme/main.c b/src/mzscheme/main.c index 910b511c77..1e30f3757f 100644 --- a/src/mzscheme/main.c +++ b/src/mzscheme/main.c @@ -150,12 +150,6 @@ extern Scheme_Object *scheme_initialize(Scheme_Env *env); #include "cmdline.inc" -/*========================================================================*/ -/* MacOS glue */ -/*========================================================================*/ - -#include "macglue.inc" - /*========================================================================*/ /* OSKit glue */ /*========================================================================*/ diff --git a/src/mzscheme/src/list.c b/src/mzscheme/src/list.c index 55bf75b8b9..14809d031e 100644 --- a/src/mzscheme/src/list.c +++ b/src/mzscheme/src/list.c @@ -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; diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index 2481f00ef4..a18c821a01 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -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 diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index 5869057efa..50336c08e0 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -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 { diff --git a/src/mzscheme/src/schemef.h b/src/mzscheme/src/schemef.h index 96b218b450..3cbf9952aa 100644 --- a/src/mzscheme/src/schemef.h +++ b/src/mzscheme/src/schemef.h @@ -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); diff --git a/src/mzscheme/src/schemex.h b/src/mzscheme/src/schemex.h index 9a3c7da3f9..03971b24de 100644 --- a/src/mzscheme/src/schemex.h +++ b/src/mzscheme/src/schemex.h @@ -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); diff --git a/src/mzscheme/src/schemex.inc b/src/mzscheme/src/schemex.inc index 0fd325f550..4d78287e37 100644 --- a/src/mzscheme/src/schemex.inc +++ b/src/mzscheme/src/schemex.inc @@ -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; diff --git a/src/mzscheme/src/schemexm.h b/src/mzscheme/src/schemexm.h index 9767a7b33f..2fb151db92 100644 --- a/src/mzscheme/src/schemexm.h +++ b/src/mzscheme/src/schemexm.h @@ -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)