diff --git a/collects/compiler/embed-unit.ss b/collects/compiler/embed-unit.ss index 42e954021b..e0d4f7efa6 100644 --- a/collects/compiler/embed-unit.ss +++ b/collects/compiler/embed-unit.ss @@ -1008,10 +1008,12 @@ mac-mred-collects-path-adjust values) collects-path))) + (define word-size (if (fixnum? (expt 2 32)) 8 4)) (unless (or long-cmdline? - ((apply + (length cmdline) (map (lambda (s) - (bytes-length (string->bytes/utf-8 s))) - cmdline)) . < . 50)) + ((apply + + (map (lambda (s) + (+ word-size (bytes-length (string->bytes/utf-8 s)))) + cmdline)) . < . 60)) (error 'create-embedding-executable "command line too long")) (check-collects-path 'create-embedding-executable collects-path collects-path-bytes) (let ([exe (find-exe mred? variant)]) diff --git a/collects/compiler/private/xform.ss b/collects/compiler/private/xform.ss index d84cd33860..190ad51e5c 100644 --- a/collects/compiler/private/xform.ss +++ b/collects/compiler/private/xform.ss @@ -585,20 +585,22 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define per-block-push? #t) - (define gc-var-stack-through-table? + (define gc-var-stack-mode (ormap (lambda (e) - (and (pragma? e) - (regexp-match #rx"GC_VARIABLE_STACK_THOUGH_TABLE" (pragma-s e)))) - e-raw)) - (define gc-var-stack-through-thread-local? - (ormap (lambda (e) - (and (tok? e) - (eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL))) - e-raw)) - (define gc-var-stack-through-getspecific? - (ormap (lambda (e) - (and (tok? e) - (eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_GETSPECIFIC))) + (cond + [(and (pragma? e) + (regexp-match #rx"GC_VARIABLE_STACK_THOUGH_TABLE" (pragma-s e))) + 'table] + [(and (tok? e) + (eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL)) + 'thread-local] + [(and (tok? e) + (eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_GETSPECIFIC)) + 'getspecific] + [(and (tok? e) + (eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_FUNCTION)) + 'function] + [else #f])) e-raw)) ;; The code produced by xform uses a number of macros. These macros @@ -608,12 +610,14 @@ (when (and pgc? (not precompiled-header)) ;; Setup GC_variable_stack macro - (printf (cond - [gc-var-stack-through-table? + (printf (case gc-var-stack-mode + [(table) "#define GC_VARIABLE_STACK (scheme_extension_table->GC_variable_stack)~n"] - [gc-var-stack-through-getspecific? + [(getspecific) "#define GC_VARIABLE_STACK (((Thread_Local_Variables *)pthread_getspecific(scheme_thread_local_key))->GC_variable_stack_)~n"] - [gc-var-stack-through-thread-local? + [(function) + "#define GC_VARIABLE_STACK ((scheme_get_thread_local_variables())->GC_variable_stack_)~n"] + [(thread-local) "#define GC_VARIABLE_STACK ((&scheme_thread_locals)->GC_variable_stack_)~n"] [else "#define GC_VARIABLE_STACK GC_variable_stack~n"])) @@ -726,6 +730,7 @@ (printf "#define XFORM_END_SKIP /**/~n") (printf "#define XFORM_START_SUSPEND /**/~n") (printf "#define XFORM_END_SUSPEND /**/~n") + (printf "#define XFORM_SKIP_PROC /**/~n") ;; For avoiding warnings: (printf "#define XFORM_OK_PLUS +~n") (printf "#define XFORM_OK_MINUS -~n") @@ -1075,8 +1080,7 @@ (set! non-gcing-functions (hash-table-copy (list-ref l 7))) - (set! gc-var-stack-through-thread-local? (list-ref l 8)) - (set! gc-var-stack-through-getspecific? (list-ref l 9)))))) + (set! gc-var-stack-mode (list-ref l 8)))))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Pretty-printing output @@ -1519,43 +1523,45 @@ null e))))] [(function? e) - (let ([name (register-proto-information e)]) - (when (eq? (tok-n (car e)) '__xform_nongcing__) - (hash-table-put! non-gcing-functions name #t)) - (when show-info? (printf "/* FUNCTION ~a */~n" name)) - (if (or (positive? suspend-xform) - (not pgc?) - (and where - (regexp-match re:h where) - (let loop ([e e][prev #f]) - (cond - [(null? e) #t] - [(and (eq? '|::| (tok-n (car e))) - prev - (eq? (tok-n prev) (tok-n (cadr e)))) - ;; inline constructor: need to convert - #f] - [else (loop (cdr e) (car e))])))) - ;; Not pgc, xform suspended, - ;; or still in headers and probably a simple inlined function - (let ([palm-static? (and palm? (eq? 'static (tok-n (car e))))]) - (when palm? - (fprintf map-port "(~aimpl ~s)~n" - (if palm-static? "s" "") - name) - (call-graph name e)) - (append - (if palm-static? - ;; Need to make sure prototype is there for section - (add-segment-label - name - (let loop ([e e]) - (if (braces? (car e)) - (list (make-tok semi #f #f)) - (cons (car e) (loop (cdr e)))))) - null) - e)) - (convert-function e name)))] + (if (skip-function? e) + e + (let ([name (register-proto-information e)]) + (when (eq? (tok-n (car e)) '__xform_nongcing__) + (hash-table-put! non-gcing-functions name #t)) + (when show-info? (printf "/* FUNCTION ~a */~n" name)) + (if (or (positive? suspend-xform) + (not pgc?) + (and where + (regexp-match re:h where) + (let loop ([e e][prev #f]) + (cond + [(null? e) #t] + [(and (eq? '|::| (tok-n (car e))) + prev + (eq? (tok-n prev) (tok-n (cadr e)))) + ;; inline constructor: need to convert + #f] + [else (loop (cdr e) (car e))])))) + ;; Not pgc, xform suspended, + ;; or still in headers and probably a simple inlined function + (let ([palm-static? (and palm? (eq? 'static (tok-n (car e))))]) + (when palm? + (fprintf map-port "(~aimpl ~s)~n" + (if palm-static? "s" "") + name) + (call-graph name e)) + (append + (if palm-static? + ;; Need to make sure prototype is there for section + (add-segment-label + name + (let loop ([e e]) + (if (braces? (car e)) + (list (make-tok semi #f #f)) + (cons (car e) (loop (cdr e)))))) + null) + e)) + (convert-function e name))))] [(var-decl? e) (when show-info? (printf "/* VAR */~n")) (if (and can-drop-vars? @@ -1611,6 +1617,7 @@ (define (threadlocal-decl? e) (and (pair? e) (or (eq? 'XFORM_GC_VARIABLE_STACK_THROUGH_GETSPECIFIC (tok-n (car e))) + (eq? 'XFORM_GC_VARIABLE_STACK_THROUGH_FUNCTION (tok-n (car e))) (eq? 'XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL (tok-n (car e)))))) (define (access-modifier? e) @@ -1705,12 +1712,16 @@ (and (braces? v) (let ([v (list-ref e (sub1 ll))]) (or (parens? v) + (eq? (tok-n v) 'XFORM_SKIP_PROC) ;; `const' can appear between the arg parens ;; and the function body; this happens in the ;; OS X headers (and (eq? 'const (tok-n v)) (positive? (sub1 ll)) (parens? (list-ref e (- ll 2)))))))))))) + + (define (skip-function? e) + (ormap (lambda (v) (eq? (tok-n v) 'XFORM_SKIP_PROC)) e)) ;; Recognize a top-level variable declaration: (define (var-decl? e) @@ -4003,8 +4014,7 @@ (marshall non-pointer-types) (marshall struct-defs) non-gcing-functions - gc-var-stack-through-thread-local? - gc-var-stack-through-getspecific?)]) + (list 'quote gc-var-stack-mode))]) (with-output-to-file (change-suffix file-out #".zo") (lambda () (let ([orig (current-namespace)]) diff --git a/collects/deinprogramm/DMdA.ss b/collects/deinprogramm/DMdA.ss index c8d197289e..a70bddc899 100644 --- a/collects/deinprogramm/DMdA.ss +++ b/collects/deinprogramm/DMdA.ss @@ -1006,8 +1006,8 @@ (stepper-syntax-property (check-expect-maker stx #'check-property-error #'?prop '() 'comes-from-check-property) - 'stepper-skip-completely - #t)) + 'stepper-replace + #'#t)) (_ (raise-syntax-error #f "`check-property' erwartet einen einzelnen Operanden" stx)))) diff --git a/collects/deinprogramm/convert-explicit.scm b/collects/deinprogramm/convert-explicit.scm index 41696e73c7..87e54978bd 100644 --- a/collects/deinprogramm/convert-explicit.scm +++ b/collects/deinprogramm/convert-explicit.scm @@ -63,7 +63,7 @@ ((null? v) (make-:empty-list)) ; prevent silly printing of sharing ((pair? v) (make-:list - (let recur ((v v)) + (let list-recur ((v v)) (cond ((null? v) v) @@ -71,7 +71,7 @@ (recur v)) (else (cons (recur (car v)) - (recur (cdr v)))))))) + (list-recur (cdr v)))))))) ((deinprogramm-struct? v) (or (hash-ref hash v #f) (let*-values (((ty skipped?) (struct-info v)) diff --git a/collects/dynext/compile-unit.ss b/collects/dynext/compile-unit.ss index ddc8783b7f..164c6baa7a 100644 --- a/collects/dynext/compile-unit.ss +++ b/collects/dynext/compile-unit.ss @@ -73,8 +73,8 @@ (define gcc-compile-flags (append '("-c" "-O2" "-fPIC") (case (string->symbol (path->string (system-library-subpath #f))) - [(ppc-macosx i386-macosx x86_64-macosx) '("-fno-common")] - [(ppc-darwin) '("-fno-common")] + [(i386-macosx i386-darwin) '("-m32" "-fno-common")] + [(ppc-macosx ppc-darwin x86_64-macosx x86_64-darwin) '("-fno-common")] [(win32\\i386) '("-DAS_MSVC_EXTENSION")] [else null]) gcc-cpp-flags)) diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss index b0e70f24a6..2ab8893eb3 100644 --- a/collects/framework/private/main.ss +++ b/collects/framework/private/main.ss @@ -76,13 +76,17 @@ '("local") (λ (x) (and (list? x) (andmap string? x)))) (preferences:set-default 'framework:square-bracket:letrec - '("let" - "let*" "let-values" "let*-values" - "let-syntax" "let-struct" "let-syntaxes" - "letrec" - "letrec-syntaxes" "letrec-syntaxes+values" "letrec-values" - "parameterize" - "with-syntax") + (let ([fors '("for" "for/list" "for/hash" "for/and" "for/or" "for/first" "for/last")]) + (append fors + (map (λ (x) (regexp-replace #rx"for" x "for*")) + fors) + '("let" + "let*" "let-values" "let*-values" + "let-syntax" "let-struct" "let-syntaxes" + "letrec" + "letrec-syntaxes" "letrec-syntaxes+values" "letrec-values" + "parameterize" + "with-syntax"))) (λ (x) (and (list? x) (andmap string? x)))) (preferences:set-default 'framework:white-on-black? #f boolean?) diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index 668834e816..c531f0bfb3 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -451,15 +451,18 @@ WARNING: printf is rebound in the body of the unit to always (super on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret) (when before (let-values ([(view-x view-y view-width view-height) - (let ([b1 (box 0)] - [b2 (box 0)] - [b3 (box 0)] - [b4 (box 0)]) - (send (get-admin) get-view b1 b2 b3 b4) - (values (unbox b1) - (unbox b2) - (unbox b3) - (unbox b4)))]) + (let ([admin (get-admin)]) + (if admin + (let ([b1 (box 0)] + [b2 (box 0)] + [b3 (box 0)] + [b4 (box 0)]) + (send admin get-view b1 b2 b3 b4) + (values (unbox b1) + (unbox b2) + (unbox b3) + (unbox b4))) + (values left-margin top-margin right-margin bottom-margin)))]) (let* ([old-pen (send dc get-pen)] [old-brush (send dc get-brush)] [old-smoothing (send dc get-smoothing)] diff --git a/collects/games/jewel/jewel.scm b/collects/games/jewel/jewel.scm index 3caf466e3c..b976b0d3c2 100644 --- a/collects/games/jewel/jewel.scm +++ b/collects/games/jewel/jewel.scm @@ -1431,7 +1431,12 @@ (counter 0) ) - + + ;; This shouldnt do anything, but it fixes drawing in + ;; Snow Leopard. Bug in the game or in Snow Leopard? + (glEnable GL_LIGHT2) + (glDisable GL_LIGHT2) + (glEnable GL_BLEND) (do ((iy 0 (+ iy 1))) ((= iy ey)) (set! x (* (- t) (- (/ ex 2.0) 0.5))) @@ -1461,7 +1466,7 @@ (set! xt nx) (set! yt ny) (set! zt nz) - + (if (and (equal? gamestate 'PLAYING) (= cposx ix) (= cposy iy)) (begin diff --git a/collects/lang/htdp-langs.ss b/collects/lang/htdp-langs.ss index f472763c63..5c099e69fc 100644 --- a/collects/lang/htdp-langs.ss +++ b/collects/lang/htdp-langs.ss @@ -514,16 +514,13 @@ keywords] [(drscheme:teachpack-menu-items) htdp-teachpack-callbacks] [(drscheme:special:insert-lambda) #f] - #; - ;; FIXME: disable context for now, re-enable when it is possible - ;; to have the context search the teachpack manual too. [(drscheme:help-context-term) (let* ([m (get-module)] [m (and m (pair? m) (pair? (cdr m)) (cadr m))] [m (and m (regexp-match #rx"^(lang/[^/.]+).ss$" m))] [m (and m (cadr m))]) (if m - (format "L:~a" m) + (format "O:{ L:~a T:teachpack }" m) (error 'drscheme:help-context-term "internal error: unexpected module spec")))] [(tests:test-menu tests:dock-menu) #t] diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss index 3cd9fa8308..6bdf409ec6 100644 --- a/collects/macro-debugger/model/reductions.ss +++ b/collects/macro-debugger/model/reductions.ss @@ -156,8 +156,8 @@ [(Wrap p:lambda (e1 e2 rs ?1 renames body)) (R [! ?1] [#:pattern (?lambda ?formals . ?body)] - [#:binders #'?formals] [#:rename (?formals . ?body) renames 'rename-lambda] + [#:binders #'?formals] [Block ?body body])] [(Wrap p:case-lambda (e1 e2 rs ?1 clauses)) (R [! ?1] diff --git a/collects/macro-debugger/syntax-browser/display.ss b/collects/macro-debugger/syntax-browser/display.ss index 2de3c18e93..173419929e 100644 --- a/collects/macro-debugger/syntax-browser/display.ss +++ b/collects/macro-debugger/syntax-browser/display.ss @@ -28,66 +28,33 @@ ;; FIXME: assumes text never moves ;; print-syntax-to-editor : syntax text controller<%> config number number -;; -> display<%> +;; -> display<%> (define (print-syntax-to-editor stx text controller config columns insertion-point) (begin-with-definitions - (define **entry (now)) (define output-port (open-output-string/count-lines)) (define range (pretty-print-syntax stx output-port (send: controller controller<%> get-primary-partition) - (send: config config<%> get-colors) + (length (send: config config<%> get-colors)) (send: config config<%> get-suffix-option) columns)) - (define **range (now)) (define output-string (get-output-string output-port)) (define output-length (sub1 (string-length output-string))) ;; skip final newline (fixup-parentheses output-string range) - (define **fixup (now)) + (send text begin-edit-sequence #f) + (send text insert output-length output-string insertion-point) (define display (new display% (text text) (controller controller) (config config) (range range) - (base-style (standard-font text config)) (start-position insertion-point) (end-position (+ insertion-point output-length)))) - (send text begin-edit-sequence #f) - (define **editing (now)) - (send text insert output-length output-string insertion-point) - (define **inserted (now)) - (add-clickbacks text range controller insertion-point) - (define **clickbacks (now)) (send display initialize) - (define **colorize (now)) (send text end-edit-sequence) - (define **finished (now)) - (when TIME-PRINTING? - (eprintf "** pretty-print: ~s\n" (- **range **entry)) - (eprintf "** fixup, begin-edit-sequence: ~s\n" (- **editing **range)) - (eprintf "** > insert: ~s\n" (- **inserted **editing)) - (eprintf "** > clickback: ~s\n" (- **clickbacks **inserted)) - (eprintf "** > colorize: ~s\n" (- **colorize **clickbacks)) - (eprintf "** finish: ~s\n" (- **finished **colorize)) - (eprintf "** total: ~s\n" (- **finished **entry)) - (eprintf "\n")) display)) -;; add-clickbacks : text% range% controller<%> number -> void -(define (add-clickbacks text range controller insertion-point) - (for ([range (send: range range<%> all-ranges)]) - (let ([stx (range-obj range)] - [start (range-start range)] - [end (range-end range)]) - (send text set-clickback (+ insertion-point start) (+ insertion-point end) - (lambda (_1 _2 _3) - (send: controller selection-manager<%> - set-selected-syntax stx)))))) - -(define (standard-font text config) - (code-style text (send: config config<%> get-syntax-font-size))) - ;; display% (define display% (class* object% (display<%>) @@ -95,18 +62,48 @@ [config config<%>] [range range<%>]) (init-field text - base-style start-position end-position) + (define base-style + (code-style text (send: config config<%> get-syntax-font-size))) + (define extra-styles (make-hasheq)) ;; initialize : -> void (define/public (initialize) (send text change-style base-style start-position end-position #f) (apply-primary-partition-styles) + (add-clickbacks) (refresh)) + ;; add-clickbacks : -> void + (define/private (add-clickbacks) + (define (the-clickback editor start end) + (send: controller selection-manager<%> set-selected-syntax + (clickback->stx + (- start start-position) (- end start-position)))) + (for ([range (send: range range<%> all-ranges)]) + (let ([stx (range-obj range)] + [start (range-start range)] + [end (range-end range)]) + (send text set-clickback (+ start-position start) (+ start-position end) + the-clickback)))) + + ;; clickback->stx : num num -> syntax + ;; FIXME: use vectors for treerange-subs and do binary search to narrow? + (define/private (clickback->stx start end) + (let ([treeranges (send: range range<%> get-treeranges)]) + (let loop* ([treeranges treeranges]) + (for/or ([tr treeranges]) + (cond [(and (= (treerange-start tr) start) + (= (treerange-end tr) end)) + (treerange-obj tr)] + [(and (<= (treerange-start tr) start) + (<= end (treerange-end tr))) + (loop* (treerange-subs tr))] + [else #f]))))) + ;; refresh : -> void ;; Clears all highlighting and reapplies all non-foreground styles. (define/public (refresh) diff --git a/collects/macro-debugger/syntax-browser/image.ss b/collects/macro-debugger/syntax-browser/image.ss new file mode 100644 index 0000000000..d8151c5fdb --- /dev/null +++ b/collects/macro-debugger/syntax-browser/image.ss @@ -0,0 +1,96 @@ +#lang scheme/base +(require scheme/contract + scheme/class + scheme/gui + framework + "prefs.ss" + "controller.ss" + "display.ss") + +#| + +Code for generating images that look like the contents of a syntax +browser, with the same pretty-printing, mark-based coloring, +suffixing, etc. + +TODO: tacked arrows + +|# + +(provide/contract + [print-syntax-columns + (parameter/c (or/c exact-positive-integer? 'infinity))] + [print-syntax-to-png + (->* (syntax? path-string?) + (#:columns (or/c exact-positive-integer? 'infinity)) + any)] + [print-syntax-to-bitmap + (->* (syntax?) + (#:columns (or/c exact-positive-integer? 'infinity)) + (is-a?/c bitmap%))] + [print-syntax-to-eps + (->* (syntax? path-string?) + (#:columns (or/c exact-positive-integer? 'infinity)) + any)]) + +;; print-syntax-columns : (parameter-of (U number 'infinity)) +(define print-syntax-columns (make-parameter 40)) + +(define standard-text% (editor:standard-style-list-mixin text%)) + +;; print-syntax-to-png : syntax path -> void +(define (print-syntax-to-png stx file + #:columns [columns (print-syntax-columns)]) + (let ([bmp (print-syntax-to-bitmap stx columns)]) + (send bmp save-file file 'png)) + (void)) + +;; print-syntax-to-bitmap : syntax -> (is-a?/c bitmap%) +(define (print-syntax-to-bitmap stx + #:columns [columns (print-syntax-columns)]) + (define t (prepare-editor stx columns)) + (define f (new frame% [label "dummy"])) + (define ec (new editor-canvas% (editor t) (parent f))) + (define dc (new bitmap-dc% (bitmap (make-object bitmap% 1 1)))) + (define char-width + (let* ([sl (send t get-style-list)] + [style (send sl find-named-style "Standard")] + [font (send style get-font)]) + (send dc set-font font) + (send dc get-char-width))) + (let ([ew (box 0.0)] + [eh (box 0.0)]) + (send t set-min-width (* columns char-width)) + (send t get-extent ew eh) + (let* ([w (inexact->exact (unbox ew))] + [h (inexact->exact (unbox eh))] + [bmp (make-object bitmap% w (+ 1 h))] + [ps (new ps-setup%)]) + (send dc set-bitmap bmp) + (send dc set-background (make-object color% "White")) + (send dc clear) + (send ps set-margin 0 0) + (send ps set-editor-margin 0 0) + (parameterize ((current-ps-setup ps)) + (send t print-to-dc dc 1)) + bmp))) + +;; print-syntax-to-eps : syntax path -> void +(define (print-syntax-to-eps stx file + #:columns [columns (print-syntax-columns)]) + (define t (prepare-editor stx columns)) + (define ps-setup (new ps-setup%)) + (send ps-setup set-mode 'file) + (send ps-setup set-file file) + (send ps-setup set-scaling 1 1) + (parameterize ((current-ps-setup ps-setup)) + (send t print #f #f 'postscript #f #f #t))) + +(define (prepare-editor stx columns) + (define t (new standard-text%)) + (define sl (send t get-style-list)) + (send t change-style (send sl find-named-style "Standard")) + (print-syntax-to-editor stx t + (new controller%) (new syntax-prefs/readonly%) + columns (send t last-position)) + t) diff --git a/collects/macro-debugger/syntax-browser/interfaces.ss b/collects/macro-debugger/syntax-browser/interfaces.ss index 5b72ce7eb5..d6bc811761 100644 --- a/collects/macro-debugger/syntax-browser/interfaces.ss +++ b/collects/macro-debugger/syntax-browser/interfaces.ss @@ -124,6 +124,7 @@ (define-struct range (obj start end)) ;; A TreeRange is (make-treerange syntax nat nat (listof TreeRange)) +;; where subs are disjoint, in order, and all contained within [start, end] (define-struct treerange (obj start end subs)) ;; syntax-prefs<%> diff --git a/collects/macro-debugger/syntax-browser/prefs.ss b/collects/macro-debugger/syntax-browser/prefs.ss index 9f570c57ef..81d1f338ad 100644 --- a/collects/macro-debugger/syntax-browser/prefs.ss +++ b/collects/macro-debugger/syntax-browser/prefs.ss @@ -29,17 +29,26 @@ (define-notify syntax-font-size (new notify-box% (value #f))) ;; colors : (listof string) - (define-notify colors - (new notify-box% - (value '("black" "red" "blue" - "mediumforestgreen" "darkgreen" - "darkred" - "cornflowerblue" "royalblue" "steelblue" "darkslategray" "darkblue" - "indigo" "purple" - "orange" "salmon" "darkgoldenrod" "olive")))) + (define-notify colors + (new notify-box% (value the-colors))) (super-new))) +(define alt-colors + '("black" + "red" "blue" "forestgreen" "purple" "brown" + "firebrick" "darkblue" "seagreen" "violetred" "chocolate" + "darkred" "cornflowerblue" "darkgreen" "indigo" "sandybrown" + "orange" "cadetblue" "olive" "mediumpurple" "goldenrod")) + +(define the-colors + '("black" "red" "blue" + "mediumforestgreen" "darkgreen" + "darkred" + "cornflowerblue" "royalblue" "steelblue" "darkslategray" "darkblue" + "indigo" "purple" + "orange" "salmon" "darkgoldenrod" "olive")) + (define syntax-prefs-base% (class* prefs-base% (config<%>) (init readonly?) diff --git a/collects/macro-debugger/syntax-browser/pretty-helper.ss b/collects/macro-debugger/syntax-browser/pretty-helper.ss index 73b22466e9..456eff080e 100644 --- a/collects/macro-debugger/syntax-browser/pretty-helper.ss +++ b/collects/macro-debugger/syntax-browser/pretty-helper.ss @@ -14,9 +14,9 @@ ;; Solution: Rather than map stx to (syntax-e stx), in the cases where ;; (syntax-e stx) is confusable, map it to a different, unique, value. -;; - stx is identifier : map it to an uninterned symbol w/ same rep -;; (Symbols are useful: see pretty-print's style table) -;; - else : map it to a syntax-dummy object +;; Use syntax-dummy, and extend pretty-print-remap-stylable to look inside. + +;; Old solution: same, except map identifiers to uninterned symbols instead ;; NOTE: Nulls are only wrapped when *not* list-terminators. ;; If they were always wrapped, the pretty-printer would screw up @@ -35,6 +35,7 @@ (pretty-print datum port))) (define-struct syntax-dummy (val)) +(define-struct (id-syntax-dummy syntax-dummy) (remap)) ;; A SuffixOption is one of ;; - 'never -- never @@ -58,16 +59,20 @@ ;; table : syntax maybe-partition% maybe-num SuffixOption -> (values s-expr hashtable hashtable) (define (table stx partition limit suffixopt) (define (make-identifier-proxy id) + (define sym (syntax-e id)) (case suffixopt - ((never) (unintern (syntax-e id))) + ((never) + (make-id-syntax-dummy sym sym)) ((always) (let ([n (send: partition partition<%> get-partition id)]) - (if (zero? n) (unintern (syntax-e id)) (suffix (syntax-e id) n)))) + (if (zero? n) + (make-id-syntax-dummy sym sym) + (make-id-syntax-dummy (suffix sym n) sym)))) ((over-limit) (let ([n (send: partition partition<%> get-partition id)]) (if (<= n limit) - (unintern (syntax-e id)) - (suffix (syntax-e id) n)))))) + (make-id-syntax-dummy sym sym) + (make-id-syntax-dummy (suffix sym n) sym)))))) (let/ec escape (let ([flat=>stx (make-hasheq)] @@ -111,7 +116,7 @@ (refold (map loop fields))) obj))] [(symbol? obj) - (unintern obj)] + (make-id-syntax-dummy obj obj)] [(null? obj) (make-syntax-dummy obj)] [(boolean? obj) @@ -169,8 +174,5 @@ '(quote quasiquote unquote unquote-splicing syntax)) ;; FIXME: quasisyntax unsyntax unsyntax-splicing -(define (unintern sym) - (string->uninterned-symbol (symbol->string sym))) - (define (suffix sym n) - (string->uninterned-symbol (format "~a:~a" sym n))) + (string->symbol (format "~a:~a" sym n))) diff --git a/collects/macro-debugger/syntax-browser/pretty-printer.ss b/collects/macro-debugger/syntax-browser/pretty-printer.ss index 12953907a6..f0aa609545 100644 --- a/collects/macro-debugger/syntax-browser/pretty-printer.ss +++ b/collects/macro-debugger/syntax-browser/pretty-printer.ss @@ -1,6 +1,3 @@ - -;; FIXME: Need to disable printing of structs with custom-write property - #lang scheme/base (require scheme/list scheme/class @@ -10,15 +7,14 @@ "interfaces.ss") (provide pretty-print-syntax) -;; pretty-print-syntax : -;; syntax port partition (listof string) SuffixOption number -;; -> range% +;; FIXME: Need to disable printing of structs with custom-write property + +;; pretty-print-syntax : syntax port partition number SuffixOption number +;; -> range% (define (pretty-print-syntax stx port primary-partition colors suffix-option columns) (define range-builder (new range-builder%)) (define-values (datum ht:flat=>stx ht:stx=>flat) - (syntax->datum/tables stx primary-partition - (length colors) - suffix-option)) + (syntax->datum/tables stx primary-partition colors suffix-option)) (define identifier-list (filter identifier? (hash-map ht:stx=>flat (lambda (k v) k)))) (define (flat=>stx obj) @@ -40,13 +36,6 @@ [end (current-position)]) (when (and start stx) (send range-builder add-range stx (cons start end))))) - (define (pp-extend-style-table identifier-list) - (let* ([syms (map (lambda (x) (stx=>flat x)) identifier-list)] - [like-syms (map syntax-e identifier-list)]) - (pretty-print-extend-style-table (pp-better-style-table) - syms - like-syms))) - (unless (syntax? stx) (raise-type-error 'pretty-print-syntax "syntax" stx)) @@ -55,7 +44,8 @@ [pretty-print-post-print-hook pp-post-hook] [pretty-print-size-hook pp-size-hook] [pretty-print-print-hook pp-print-hook] - [pretty-print-current-style-table (pp-extend-style-table identifier-list)] + [pretty-print-remap-stylable pp-remap-stylable] + [pretty-print-current-style-table (pp-better-style-table)] [pretty-print-columns columns]) (pretty-print/defaults datum port) (new range% @@ -79,9 +69,13 @@ (string-length (get-output-string ostring)))] [else #f])) +(define (pp-remap-stylable obj) + (and (id-syntax-dummy? obj) (id-syntax-dummy-remap obj))) + (define (pp-better-style-table) (basic-style-list) - #; ;; Messes up formatting too much :( + #| + ;; Messes up formatting too much :( (let* ([pref (pref:tabify)] [table (car pref)] [begin-rx (cadr pref)] @@ -91,7 +85,8 @@ (pretty-print-extend-style-table (basic-style-list) (map car style-list) - (map cdr style-list))))) + (map cdr style-list)))) + |#) (define (basic-style-list) (pretty-print-extend-style-table diff --git a/collects/mred/private/wxme/editor.ss b/collects/mred/private/wxme/editor.ss index 716743bc38..1c8ec16aaa 100644 --- a/collects/mred/private/wxme/editor.ss +++ b/collects/mred/private/wxme/editor.ss @@ -97,9 +97,9 @@ (set-box! w PAGE-WIDTH) (set-box! h PAGE-HEIGHT) (when (eq? (get-printer-orientation) 'landscape) - (let ([tmp h]) - (set! h w) - (set! w tmp)))) + (let ([tmp (unbox h)]) + (set-box! h (unbox w)) + (set-box! w tmp)))) ;; ---------------------------------------- diff --git a/collects/mred/private/wxme/pasteboard.ss b/collects/mred/private/wxme/pasteboard.ss index b2755831ee..00d84ef3e7 100644 --- a/collects/mred/private/wxme/pasteboard.ss +++ b/collects/mred/private/wxme/pasteboard.ss @@ -770,7 +770,7 @@ (snip-set-admin del-snip #f) (set-snip-flags! del-snip (remove-flag (snip->flags del-snip) CAN-DISOWN)) (unless del - (when (send del-snip get-admin) + (unless (send del-snip get-admin) (set-snip-flags! del-snip (remove-flag (snip->flags del-snip) OWNED)))) (unless s-modified? diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index cbabd25673..05e586528c 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "19nov2009") +#lang scheme/base (provide stamp) (define stamp "23nov2009") diff --git a/collects/scheme/contract/private/guts.ss b/collects/scheme/contract/private/guts.ss index e6e1980217..96e85aac05 100644 --- a/collects/scheme/contract/private/guts.ss +++ b/collects/scheme/contract/private/guts.ss @@ -361,10 +361,16 @@ (define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate)) (define (check-flat-named-contract predicate) (coerce-flat-contract 'flat-named-contract predicate)) (define (flat-named-contract name predicate) - (unless (and (procedure? predicate) - (procedure-arity-includes? predicate 1)) - (error 'flat-named-contract "expected a procedure of arity 1 as second argument, got ~e" predicate)) - (make-predicate-contract name predicate)) + (cond + [(and (procedure? predicate) + (procedure-arity-includes? predicate 1)) + (make-predicate-contract name predicate)] + [(flat-contract? predicate) + (make-predicate-contract name (flat-contract-predicate predicate))] + [else + (error 'flat-named-contract + "expected a flat contract or procedure of arity 1 as second argument, got ~e" + predicate)])) ;; build-compound-type-name : (union contract symbol) ... -> (-> sexp) (define (build-compound-type-name . fs) diff --git a/collects/scheme/future.ss b/collects/scheme/future.ss new file mode 100644 index 0000000000..4f8a051af2 --- /dev/null +++ b/collects/scheme/future.ss @@ -0,0 +1,7 @@ +#lang scheme/base +(require '#%futures) + +(provide future? + future + touch + processor-count) diff --git a/collects/scheme/private/sort.ss b/collects/scheme/private/sort.ss index b6b3060723..387560366c 100644 --- a/collects/scheme/private/sort.ss +++ b/collects/scheme/private/sort.ss @@ -4,23 +4,36 @@ (#%provide sort) -;; This is a destructive stable merge-sort, adapted from slib and improved by -;; Eli Barzilay. -;; The original source said: -;; It uses a version of merge-sort invented, to the best of my knowledge, by -;; David H. D. Warren, and first used in the DEC-10 Prolog system. -;; R. A. O'Keefe adapted it to work destructively in Scheme. -;; but it's a plain destructive merge sort, which I optimized further. +#| -;; The source uses macros to optimize some common cases (eg, no `getkey' -;; function, or precompiled versions with inlinable common comparison -;; predicates) -- they are local macros so they're not left in the compiled -;; code. +Based on "Fast mergesort implementation based on half-copying merge algorithm", +Cezary Juszczak, http://kicia.ift.uni.wroc.pl/algorytmy/mergesortpaper.pdf +Written in Scheme by Eli Barzilay. (Note: the reason for the seemingly +redundant pointer arithmetic in that paper is dealing with cases of uneven +number of elements.) -;; Note that there is no error checking on the arguments -- the `sort' function -;; that this module provide is then wrapped up by a keyworded version in -;; "scheme/private/list.ss", and that's what everybody sees. The wrapper is -;; doing these checks. +The source uses macros to optimize some common cases (eg, no `getkey' +function, or precompiled versions with inlinable common comparison +predicates) -- they are local macros so they're not left in the compiled +code. + +Note that there is no error checking on the arguments -- the `sort' function +that this module provide is then wrapped up by a keyworded version in +"scheme/private/list.ss", and that's what everybody sees. The wrapper is +doing these checks. + +|# + +;; This code works with unsafe operations, but don't use it for a while to +;; catch potential problems. +;; (#%require (rename '#%unsafe i+ unsafe-fx+) +;; (rename '#%unsafe i- unsafe-fx-) +;; (rename '#%unsafe i= unsafe-fx=) +;; (rename '#%unsafe i< unsafe-fx<) +;; (rename '#%unsafe i<= unsafe-fx<=) +;; (rename '#%unsafe i>> unsafe-fxrshift) +;; (rename '#%unsafe vref unsafe-vector-ref) +;; (rename '#%unsafe vset! unsafe-vector-set!)) (define sort (let () @@ -29,80 +42,78 @@ [(dr (foo . pattern) template) (define-syntax foo (syntax-rules () [(_ . pattern) template]))])) -(define-syntax-rule (sort-internal-body lst *less? n has-getkey? getkey) - (begin - (define-syntax-rule (less? x y) - (if has-getkey? (*less? (getkey x) (getkey y)) (*less? x y))) - (define (merge-sorted! a b) - ;; r-a? for optimization -- is r connected to a? - (define (loop r a b r-a?) - (if (less? (mcar b) (mcar a)) - (begin - (when r-a? (set-mcdr! r b)) - (if (null? (mcdr b)) (set-mcdr! b a) (loop b a (mcdr b) #f))) - ;; (car a) <= (car b) - (begin - (unless r-a? (set-mcdr! r a)) - (if (null? (mcdr a)) (set-mcdr! a b) (loop a (mcdr a) b #t))))) - (cond [(null? a) b] - [(null? b) a] - [(less? (mcar b) (mcar a)) - (if (null? (mcdr b)) (set-mcdr! b a) (loop b a (mcdr b) #f)) - b] - [else ; (car a) <= (car b) - (if (null? (mcdr a)) (set-mcdr! a b) (loop a (mcdr a) b #t)) - a])) - (let step ([n n]) - (cond [(> n 3) - (let* (; let* not really needed with mzscheme's l->r eval - [j (quotient n 2)] [a (step j)] [b (step (- n j))]) - (merge-sorted! a b))] - ;; the following two cases are just explicit treatment of sublists - ;; of length 2 and 3, could remove both (and use the above case for - ;; n>1) and it would still work, except a little slower - [(= n 3) (let ([p lst] [p1 (mcdr lst)] [p2 (mcdr (mcdr lst))]) - (let ([x (mcar p)] [y (mcar p1)] [z (mcar p2)]) - (set! lst (mcdr p2)) - (cond [(less? y x) ; y x - (cond [(less? z y) ; z y x - (set-mcar! p z) - (set-mcar! p1 y) - (set-mcar! p2 x)] - [(less? z x) ; y z x - (set-mcar! p y) - (set-mcar! p1 z) - (set-mcar! p2 x)] - [else ; y x z - (set-mcar! p y) - (set-mcar! p1 x)])] - [(less? z x) ; z x y - (set-mcar! p z) - (set-mcar! p1 x) - (set-mcar! p2 y)] - [(less? z y) ; x z y - (set-mcar! p1 z) - (set-mcar! p2 y)]) - (set-mcdr! p2 '()) - p))] - [(= n 2) (let ([x (mcar lst)] [y (mcar (mcdr lst))] [p lst]) - (set! lst (mcdr (mcdr lst))) - (when (less? y x) - (set-mcar! p y) - (set-mcar! (mcdr p) x)) - (set-mcdr! (mcdr p) '()) - p)] - [(= n 1) (let ([p lst]) - (set! lst (mcdr lst)) - (set-mcdr! p '()) - p)] - [else '()])))) +(define-syntax-rule (i+ x y) (+ x y)) +(define-syntax-rule (i- x y) (- x y)) +(define-syntax-rule (i= x y) (= x y)) +(define-syntax-rule (i< x y) (< x y)) +(define-syntax-rule (i<= x y) (<= x y)) +(define-syntax-rule (i>> x y) (arithmetic-shift x (- y))) +(define-syntax-rule (vref v i) (vector-ref v i)) +(define-syntax-rule (vset! v i x) (vector-set! v i x)) + +(define-syntax-rule (sort-internal-body v *> n 1)] [n/2+ (i- n n/2-)]) + (define-syntax-rule (> n 1)] [n/2+ (i- n n/2-)]) + (let ([Amid1 (i+ Alo n/2-)] + [Amid2 (i+ Alo n/2+)] + [Bmid1 (i+ Blo n/2-)]) + (copying-mergesort Amid1 Bmid1 n/2+) + (copying-mergesort Alo Amid2 n/2-) + (merge #t Amid2 (i+ Alo n) Bmid1 (i+ Blo n) Blo)))])) + + (let ([Alo 0] [Amid1 n/2-] [Amid2 n/2+] [Ahi n] [B1lo n]) + (copying-mergesort Amid1 B1lo n/2+) + (unless (zero? n/2-) (copying-mergesort Alo Amid2 n/2-)) + (merge #f B1lo (i+ B1lo n/2+) Amid2 Ahi Alo)))) (define sort-internals (make-hasheq)) (define _ (let () - (define-syntax-rule (precomp less? more ...) - (let ([proc (lambda (lst n) (sort-internal-body lst less? n #f #f))]) - (hash-set! sort-internals less? proc) + (define-syntax-rule (precomp >=) @@ -110,94 +121,99 @@ (precomp string-ci decorated-mlist - [mlst (let ([x (car lst)]) (mcons (cons (getkey x) x) null))]) - (let loop ([last mlst] [lst (cdr lst)]) + (let ([vec (make-vector (+ n (ceiling (/ n 2))))]) + ;; list -> decorated-vector + (let loop ([i 0] [lst lst]) (when (pair? lst) - (let ([new (let ([x (car lst)]) (mcons (cons (getkey x) x) null))]) - (set-mcdr! last new) - (loop new (cdr lst))))) - ;; decorated-mlist -> list - (let loop ([r (sort-internal *less? mlst n car)]) - (if (null? r) r (cons (cdr (mcar r)) (loop (mcdr r))))))] + (let ([x (car lst)]) + (vector-set! vec i (cons (getkey x) x)) + (loop (add1 i) (cdr lst))))) + ;; sort + (sort-internal * list + (let loop ([i n] [r '()]) + (let ([i (sub1 i)]) + (if (< i 0) r (loop i (cons (cdr (vector-ref vec i)) r))))))] ;; trivial cases [(< n 2) lst] ;; check if the list is already sorted (which can be common, eg, ;; directory lists) [(let loop ([last (car lst)] [next (cdr lst)]) (or (null? next) - (and (not (less? (car next) last)) + (and (not ( mlist - [mlst (mcons (car lst) null)]) - (let loop ([last mlst] [lst (cdr lst)]) + (if ( vector + (let loop ([i 0] [lst lst]) (when (pair? lst) - (let ([new (mcons (car lst) null)]) - (set-mcdr! last new) - (loop new (cdr lst))))) - ;; mlist -> list - (let loop ([r (if getkey - (sort-internal *less? mlst n getkey) - (sort-internal *less? mlst n))]) - (if (null? r) r (cons (mcar r) (loop (mcdr r))))))]))) + (vector-set! vec i (car lst)) + (loop (add1 i) (cdr lst)))) + ;; sort + (if getkey + (sort-internal * list + (let loop ([i n] [r '()]) + (let ([i (sub1 i)]) + (if (< i 0) r (loop i (cons (vector-ref vec i) r))))))]))) ;; Finally, this is the provided `sort' value (case-lambda - [(lst less?) (sort-body lst less? #f #f #f)] - [(lst less? getkey) + [(lst url (resolve-get t ri (car (part-tags t))))] [class ,(if (or (eq? t d) (and show-mine? (memq t toc-chain))) "tocviewselflink" - "tocviewlink")]) + "tocviewlink")] + [pltdoc "x"]) ,@(render-content (or (part-title-content t) '("???")) d ri))) (format-number (collected-info-number (part-collected-info t ri)) '(nbsp)))) @@ -528,7 +529,8 @@ ,(cond [(part? p) "tocsubseclink"] [any-parts? "tocsubnonseclink"] - [else "tocsublink"])]) + [else "tocsublink"])] + [pltdoc "x"]) ,@(render-content (if (part? p) (or (part-title-content p) @@ -607,8 +609,8 @@ (list style-file) style-extra-files)) ,(scribble-js-contents script-file (lookup-path script-file alt-paths))) - (body ((id ,(or (extract-part-body-id d ri) - "scribble-plt-scheme-org"))) + (body ([id ,(or (extract-part-body-id d ri) + "scribble-plt-scheme-org")]) ,@(render-toc-view d ri) (div ([class "maincolumn"]) (div ([class "main"]) @@ -616,7 +618,8 @@ (render-version d ri)) ,@(navigation d ri #t) ,@(render-part d ri) - ,@(navigation d ri #f))))))))))) + ,@(navigation d ri #f))) + (div ([id "langindicator"]) nbsp))))))))) (define/private (part-parent d ri) (collected-info-parent (part-collected-info d ri))) @@ -705,6 +708,7 @@ (make-target-url url) (make-attributes `([title . ,(if title* (string-append label " to " title*) label)] + [pltdoc . "x"] ,@more))))) (define top-link (titled-url @@ -987,7 +991,8 @@ [else ;; Normal link: (dest->url dest)])) - ,@(attribs)] + ,@(attribs) + [pltdoc "x"]] ,@(if (empty-content? (element-content e)) (render-content (strip-aux (dest-title dest)) part ri) (render-content (element-content e) part ri)))) diff --git a/collects/scribble/scribble-common.js b/collects/scribble/scribble-common.js index bfd8711f0a..13b1dfa07a 100644 --- a/collects/scribble/scribble-common.js +++ b/collects/scribble/scribble-common.js @@ -1,5 +1,7 @@ // Common functionality for PLT documentation pages +// Cookies -------------------------------------------------------------------- + function GetCookie(key, def) { if (document.cookie.length <= 0) return def; var i, cookiestrs = document.cookie.split(/; */); @@ -36,6 +38,40 @@ function GotoPLTRoot(ver, relative) { return false; } +// URL Parameters ------------------------------------------------------------- + +// In the following functions, the `name' argument is assumed to be simple in +// that it doesn't contain anything that isn't plain text in a regexp. (This +// is because JS doesn't have a `regexp-quote', easy to hack but not needed +// here). Also, the output value from the Get functions and the input value to +// the Set functions is decoded/encoded. Note that `SetArgInURL' mutates the +// string in the url object. + +function GetArgFromString(str, name) { + var rx = new RegExp("(?:^|[;&])"+name+"=([^&;]*)(?:[;&]|$)"); + return rx.test(str) && unescape(RegExp.$1); +} + +function SetArgInString(str, name, val) { + val = escape(val); + if (str.length == 0) return name + "=" + val; + var rx = new RegExp("^((?:|.*[;&])"+name+"=)(?:[^&;]*)([;&].*|)$"); + if (rx.test(str)) return RegExp.$1 + val + RegExp.$2; + else return name + "=" + val + "&" + str; +} + +function GetArgFromURL(url, name) { + if (!url.href.search(/\?([^#]*)(?:#|$)/)) return false; + return GetArgFromString(RegExp.$1, name); +} + +function SetArgInURL(url, name, val) { // note: mutates the string + url.href.search(/^([^?#]*)(?:\?([^#]*))?(#.*)?$/); + url.href = RegExp.$1 + "?" + SetArgInString(RegExp.$2,name,val) + RegExp.$3; +} + +// Utilities ------------------------------------------------------------------ + normalize_rxs = [/\/\/+/g, /\/\.(\/|$)/, /\/[^\/]*\/\.\.(\/|$)/]; function NormalizePath(path) { var tmp, i; @@ -44,6 +80,12 @@ function NormalizePath(path) { return path; } +// `noscript' is problematic in some browsers (always renders as a +// block), use this hack instead (does not always work!) +// document.write(""); + +// Interactions --------------------------------------------------------------- + function DoSearchKey(event, field, ver, top_path) { var val = field.value; if (event && event.keyCode == 13) { @@ -55,13 +97,41 @@ function DoSearchKey(event, field, ver, top_path) { return true; } -function TocviewToggle(glyph,id) { +function TocviewToggle(glyph, id) { var s = document.getElementById(id).style; var expand = s.display == "none"; s.display = expand ? "block" : "none"; glyph.innerHTML = expand ? "▼" : "►"; } -// `noscript' is problematic in some browsers (always renders as a -// block), use this hack instead (does not always work!) -// document.write(""); +// Page Init ------------------------------------------------------------------ + +// Note: could make a function that inspects and uses window.onload to chain to +// a previous one, but this file needs to be required first anyway, since it +// contains utilities for all other files. +var on_load_funcs = []; +function AddOnLoad(fun) { on_load_funcs.push(fun); } +window.onload = function() { + for (var i=0; i any)]) future?]{ + Starts running @scheme[thunk] in parallel. +} + +@defproc[(touch [f future?]) any]{ + Returns the value computed in the future @scheme[f], blocking + to let it complete if it hasn't yet completed. +} + +@defproc[(future? [x any/c]) boolean?]{ + Returns @scheme[#t] if @scheme[x] is a future. +} + +@defproc[(processor-count) exact-positive-integer?]{ + Returns the number of processors available on the current system. +} + diff --git a/collects/scribblings/futures/info.ss b/collects/scribblings/futures/info.ss new file mode 100644 index 0000000000..2d6205d396 --- /dev/null +++ b/collects/scribblings/futures/info.ss @@ -0,0 +1,3 @@ +#lang setup/infotab + +(define scribblings '(("futures.scrbl" ()))) diff --git a/collects/scribblings/inside/memory.scrbl b/collects/scribblings/inside/memory.scrbl index d5e174b8dc..ff53885768 100644 --- a/collects/scribblings/inside/memory.scrbl +++ b/collects/scribblings/inside/memory.scrbl @@ -550,6 +550,17 @@ The following macros can be used (with care!) to navigate MZ_PRECISE_GC} and @cpp{#endif}; a semi-colon by itself at the top level is not legal in C.} +@item{@cppdef{XFORM_SKIP_PROC}: annotate a function so that its body + is skipped in the same way as bracketing it with + @cpp{XFORM_START_SKIP} and @cpp{XFORM_END_SKIP}. + + Example: + + @verbatim[#:indent 2]{ + int foo(int c, ...) XFORM_END_SKIP { + } + }} + @item{@cppdef{XFORM_HIDE_EXPR}: a macro that takes wraps an expression to disable processing of the expression. diff --git a/collects/scribblings/main/private/make-search.ss b/collects/scribblings/main/private/make-search.ss index 483d41466e..7b986a6f15 100644 --- a/collects/scribblings/main/private/make-search.ss +++ b/collects/scribblings/main/private/make-search.ss @@ -111,7 +111,7 @@ [e (make-link-element "indexlink" e tag)] [e (send renderer render-content e sec ri)]) (match e ; should always render to a single `a' - [`((a ([href ,href] [class "indexlink"]) . ,body)) + [`((a ([href ,href] [class "indexlink"] [pltdoc ,_]) . ,body)) (cond [(and (part-index-desc? desc) (regexp-match #rx"(?:^|/)([^/]+)/index\\.html$" href)) => (lambda (man) (hash-set! manual-refs (cadr man) idx))]) @@ -121,10 +121,11 @@ (if (regexp-match? #rx"^Provided from: " label) body ;; if this happens, this code should be updated - (error "internal error: unexpected tooltip"))] + (error 'make-script + "internal error: unexpected tooltip"))] [else body])]) (values (compact-url href) (compact-body body)))] - [else (error "unexpected value rendered: ~e" e)]))) + [else (error 'make-script "unexpected value rendered: ~e" e)]))) (define (lib->name lib) (quote-string (let loop ([lib lib]) (match lib diff --git a/collects/scribblings/main/private/search.js b/collects/scribblings/main/private/search.js index cb01f2cf39..e0aeda00aa 100644 --- a/collects/scribblings/main/private/search.js +++ b/collects/scribblings/main/private/search.js @@ -226,17 +226,8 @@ function InitializeSearch() { result_links.push(n); AdjustResultsNum(); // get search string - if (location.search.length > 0) { - var paramstrs = location.search.substring(1).split(/[;&]/); - for (var i=0; i 0) return C_rexact; else return C_exact; } + /* a case for "Q" is not needed -- same as the default case below */ default: var words = term.split(/\b/); for (var i=0; i= C_max) return r; + } + return r; + }; +} + +function CompileTermsR(terms, nested) { + var term, result = new Array(); + while (terms.length > 0) { + term = terms.pop(); + switch (term) { + case "A:{": result.push(CompileTermsR(terms, CompileAndTerms)); break; + case "O:{": result.push(CompileTermsR(terms, CompileOrTerms)); break; + default: + // "}" has terminates a compound, otherwise it's an ordinary search term + if (nested && (term == "}")) return nested(result); + else result.push(CompileTerm(term)); + } + } + // all compound operators are implicitly terminated at the end + if (nested) return nested(result); + else return result; +} + +function CompileTerms(terms, nested) { + terms.reverse(); + return CompileTermsR(terms, nested) +} + function Id(x) { return x; } @@ -421,8 +465,7 @@ function Search(data, term, is_pre, K) { var t = false; var killer = function() { if (t) clearTimeout(t); }; // term comes with normalized spaces (trimmed, and no double spaces) - var preds = (term=="") ? [] : term.split(/ /); - for (var i=0; i= C_rexact && min >= C_exact) exacts.push(data[i]); else if (min > C_wordmatch) matches.push(data[i]); else if (min > C_fail) wordmatches.push(data[i]); fuel--; i++; } - if (i= search_results.length) first_search_result = 0; + var link_lang = (cur_plt_lang && ("?lang="+escape(cur_plt_lang))); for (var i=0; i'; + var href = UncompactUrl(res[1]); + if (link_lang) { + var hash = href.indexOf("#"); + if (hash >= 0) + href = href.substring(0,hash) + link_lang + href.substring(hash); + else + href = href + link_lang; + } result_links[i].innerHTML = - '' + '' + UncompactHtml(res[2]) + '' + (note || ""); result_links[i].style.backgroundColor = (n < exact_results_num) ? highlight_color : background_color; @@ -838,6 +890,6 @@ function SetHighlightColor(inp) { } set_highlight_color = SetHighlightColor; -window.onload = InitializeSearch; +AddOnLoad(InitializeSearch); })(); diff --git a/collects/scribblings/main/private/utils.ss b/collects/scribblings/main/private/utils.ss index bdc3b7b585..10010e52ea 100644 --- a/collects/scribblings/main/private/utils.ss +++ b/collects/scribblings/main/private/utils.ss @@ -103,13 +103,18 @@ [(#f) path] [else (error "internal error (main-page)")])) (define (onclick style) - (if (eq? root 'user) - (make-style style - (list (make-attributes - `([onclick - . ,(format "return GotoPLTRoot(\"~a\", \"~a\");" - (version) path)])))) - style)) + (make-style + style + (list (make-attributes + `(,@(if (eq? root 'user) + `([onclick + . ,(format "return GotoPLTRoot(\"~a\", \"~a\");" + (version) path)]) + `()) + ;; note: root=#f means an external link, but in this + ;; case this is the bugs link, so *keep* it and later + ;; use it on the bugs page + [pltdoc . "x"]))))) (define (elt style) (make-toc-element #f null (list (hyperlink dest #:style (onclick style) text)))) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 8d315d675e..2114c3b961 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -61,16 +61,19 @@ Constructs a @tech{flat contract} from @scheme[predicate]. A value satisfies the contract if the predicate returns a true value.} -@defproc[(flat-named-contract [type-name any/c][predicate (any/c . -> . any)]) +@defproc[(flat-named-contract [type-name any/c] [predicate (or/c flat-contract? (any/c . -> . any))]) flat-contract?]{ -Like @scheme[flat-contract], but the first argument must be the +On predicates like @scheme[flat-contract], but the first argument must be the (quoted) name of a contract used for error reporting. For example, @schemeblock[(flat-named-contract 'odd-integer (lambda (x) (and (integer? x) (odd? x))))] turns the predicate into a contract with the name @tt{odd-integer}. + +On flat contracts, the new flat contract is the same as the old except for +the name. } @defthing[any/c flat-contract?]{ @@ -862,6 +865,9 @@ source location information from compiled files. @section{Building New Contract Combinators} +@emph{@bold{Note:} + The interface in this section is unstable and subject to change.} + Contracts are represented internally as functions that accept information about the contract (who is to blame, source locations, etc) and produce projections (in the @@ -1123,6 +1129,9 @@ to build an actual error message.} @subsection{Contracts as structs} +@emph{@bold{Note:} + The interface in this section is unstable and subject to change.} + A contract is an arbitrary struct that has all of the struct properties (see @secref["structprops"] in the reference manual) diff --git a/collects/setup/setup-unit.ss b/collects/setup/setup-unit.ss index 40be5fab54..af82903506 100644 --- a/collects/setup/setup-unit.ss +++ b/collects/setup/setup-unit.ss @@ -76,9 +76,8 @@ (setup-printf "version" "~a [~a]" (version) (system-type 'gc)) (setup-printf "variants" "~a" - (apply string-append - (map (lambda (s) (format " ~a" s)) - (available-mzscheme-variants)))) + (string-join (map symbol->string (available-mzscheme-variants)) + ", ")) (setup-printf "main collects" "~a" (path->string main-collects-dir)) (setup-printf "collects paths" (if (null? (current-library-collection-paths)) " empty!" "")) @@ -136,16 +135,14 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define x-specific-collections - (apply append - (specific-collections) - (map (lambda (x) - (unpack x - (build-path main-collects-dir 'up) - (lambda (s) (setup-printf #f "~a" s)) - (current-target-directory-getter) - (force-unpacks) - (current-target-plt-directory-getter))) - (archives)))) + (append* (specific-collections) + (for/list ([x (in-list (archives))]) + (unpack x + (build-path main-collects-dir 'up) + (lambda (s) (setup-printf #f "~a" s)) + (current-target-directory-getter) + (force-unpacks) + (current-target-plt-directory-getter))))) ;; specific-planet-dir ::= ;; - (list path[directory] string[owner] string[package-name] (listof string[extra package path]) Nat[maj] Nat[min]), or @@ -854,49 +851,44 @@ kind mzlns))] [(and (or (not mzlls) (= (length mzlns) (length mzlls))) (or (not mzlfs) (= (length mzlns) (length mzlfs)))) - (for-each - (lambda (mzln mzll mzlf) - (let ([p (program-launcher-path mzln)] - [aux (list* `(exe-name . ,mzln) - '(framework-root . #f) - '(dll-dir . #f) - `(relative? . ,(not absolute-installation?)) - (build-aux-from-path - (build-path (cc-path cc) - (path-replace-suffix - (or mzll mzln) - #""))))]) - (unless (up-to-date? p aux) - (setup-printf - "launcher" - "~a~a" - (path->name p #:prefix (format "~a-bin" kind) - #:base (if (equal? kind 'console) - find-console-bin-dir - find-gui-bin-dir)) - (let ([v (current-launcher-variant)]) - (if (eq? v (system-type 'gc)) "" (format " [~a]" v)))) - (make-launcher - (or mzlf - (if (cc-collection cc) - (list "-l-" (string-append - (apply string-append - (map (lambda (s) - (string-append - (if (path? s) - (path->string s) - s) - "/")) - (cc-collection cc))) - mzll)) - (list "-t-" (path->string (build-path (cc-path cc) mzll))))) - p - aux)))) - mzlns - (or mzlls (map (lambda (_) #f) mzlns)) - (or mzlfs (map (lambda (_) #f) mzlns)))] + (for ([mzln (in-list mzlns)] + [mzll (in-list (or mzlls (map (lambda (_) #f) mzlns)))] + [mzlf (in-list (or mzlfs (map (lambda (_) #f) mzlns)))]) + (let ([p (program-launcher-path mzln)] + [aux (list* `(exe-name . ,mzln) + '(framework-root . #f) + '(dll-dir . #f) + `(relative? . ,(not absolute-installation?)) + (build-aux-from-path + (build-path (cc-path cc) + (path-replace-suffix + (or mzll mzln) + #""))))]) + (unless (up-to-date? p aux) + (setup-printf + "launcher" + "~a~a" + (path->name p #:prefix (format "~a-bin" kind) + #:base (if (equal? kind 'console) + find-console-bin-dir + find-gui-bin-dir)) + (let ([v (current-launcher-variant)]) + (if (eq? v (system-type 'gc)) "" (format " [~a]" v)))) + (make-launcher + (or mzlf + (if (cc-collection cc) + (list "-l-" (string-append + (string-append* + (map (lambda (s) (format "~a/" s)) + (cc-collection cc))) + mzll)) + (list "-t-" (path->string (build-path (cc-path cc) mzll))))) + p + aux))))] [else - (let ([fault (if (or (not mzlls) (= (length mzlns) (length mzlls))) 'f 'l)]) + (let ([fault (if (or (not mzlls) + (= (length mzlns) (length mzlls))) + 'f 'l)]) (setup-printf "WARNING" "~s launcher name list ~s doesn't match ~a list; ~s" diff --git a/collects/stepper/internal-docs.txt b/collects/stepper/internal-docs.txt index fefbd85372..d301d07e7f 100644 --- a/collects/stepper/internal-docs.txt +++ b/collects/stepper/internal-docs.txt @@ -212,6 +212,12 @@ stepper-skipto/discard : Abstraktion", where procedures are wrapped in a contract-checking context that has no impact on the reduction semantics.) +stepper-replace : + + This is like stepper-skipto/discard, except that it makes the + stepper replace the expression the property is attached to by the + value of the property. + stepper-else : [ #t ] : Initially applied to the 'true' that the cond macro replaces a beginner's 'else' with, it is later transferred diff --git a/collects/stepper/private/annotate.ss b/collects/stepper/private/annotate.ss index 0828266121..0ba963bdc5 100644 --- a/collects/stepper/private/annotate.ss +++ b/collects/stepper/private/annotate.ss @@ -1160,7 +1160,8 @@ (define (annotate/module-top-level exp) - (cond [(stepper-syntax-property exp 'stepper-skip-completely) exp] + (cond [(stepper-syntax-property exp 'stepper-replace)] + [(stepper-syntax-property exp 'stepper-skip-completely) exp] ;; for kathy's test engine: [(syntax-property exp 'test-call) exp] [(stepper-syntax-property exp 'stepper-define-struct-hint) diff --git a/collects/tests/framework/text.ss b/collects/tests/framework/text.ss index 00fe7cc228..f0047ebfa2 100644 --- a/collects/tests/framework/text.ss +++ b/collects/tests/framework/text.ss @@ -161,3 +161,40 @@ #:exists 'truncate) (send t load-file) (length (send t get-highlighted-ranges))))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; print-to-dc +;; + +(test + 'print-to-dc + (λ (x) (equal? x 'no-error)) + (λ () + (send-sexp-to-mred + '(let* ([t (new text:basic%)] + [bmp (make-object bitmap% 100 40)] + [dc (new bitmap-dc% (bitmap bmp))]) + (send t insert "Hello world") + (send dc clear) + (send t print-to-dc dc 1) + 'no-error)))) + + +(test + 'print-to-dc2 + (λ (x) (equal? x 'no-error)) + (λ () + (send-sexp-to-mred + `(let* ([f (new frame% [label ""])] + [t (new text:basic%)] + [ec (new editor-canvas% [parent f] [editor t])] + [bmp (make-object bitmap% 100 40)] + [dc (new bitmap-dc% (bitmap bmp))]) + (send t insert "Hello world") + (send t highlight-range 2 5 "orange") + (send f reflow-container) + (send dc clear) + (send t print-to-dc dc 1) + 'no-error)))) \ No newline at end of file diff --git a/collects/tests/mzscheme/benchmarks/common/nucleic2.sch b/collects/tests/mzscheme/benchmarks/common/nucleic2.sch index 048d6b00b9..24c0b04b7b 100644 --- a/collects/tests/mzscheme/benchmarks/common/nucleic2.sch +++ b/collects/tests/mzscheme/benchmarks/common/nucleic2.sch @@ -3756,4 +3756,4 @@ ; To run program, evaluate: (run) -(time (run)) +(time (let loop ([i 10]) (if (zero? i) 'done (begin (run) (loop (- i 1)))))) diff --git a/collects/tests/mzscheme/list.ss b/collects/tests/mzscheme/list.ss index 0aea0bd345..f6519acc96 100644 --- a/collects/tests/mzscheme/list.ss +++ b/collects/tests/mzscheme/list.ss @@ -113,7 +113,18 @@ (for-each (lambda (l) (test '((0 2) (0 3) (1 1)) sort* l)) '(((1 1) (0 2) (0 3)) ((0 2) (1 1) (0 3)) - ((0 2) (0 3) (1 1))))) + ((0 2) (0 3) (1 1)))) + ;; exhaustive tests for 2 and 3 item lists + (for-each (lambda (l) (test '((1 x) (2 y)) sort* l)) + '(((1 x) (2 y)) + ((2 y) (1 x)))) + (for-each (lambda (l) (test '((1 x) (2 y) (3 z)) sort* l)) + '(((1 x) (2 y) (3 z)) + ((2 y) (1 x) (3 z)) + ((2 y) (3 z) (1 x)) + ((3 z) (2 y) (1 x)) + ((3 z) (1 x) (2 y)) + ((1 x) (3 z) (2 y))))) ;; test #:key and #:cache-keys? (let () (define l '((0) (9) (1) (8) (2) (7) (3) (6) (4) (5))) diff --git a/collects/tests/mzscheme/vector.ss b/collects/tests/mzscheme/vector.ss index 223477a5e9..90a40244aa 100644 --- a/collects/tests/mzscheme/vector.ss +++ b/collects/tests/mzscheme/vector.ss @@ -119,6 +119,17 @@ (test 2 vector-count even? #(1 2 3 4)) (test 2 vector-count < #(1 2 3 4) #(4 3 2 1))) +;; ---------- vector-copy ---------- + +(let () + (test #() vector-copy #()) + (test #(1 2 3) vector-copy #(1 2 3)) + (test #f immutable? (vector-copy #(1 2 3))) + (let ([v (vector 1 2 3)]) + (test #f eq? v (vector-copy v)))) + + + ;; ---------- vector-arg{min,max} ---------- (let () diff --git a/collects/tests/run-automated-tests.ss b/collects/tests/run-automated-tests.ss index c0e6a22a7c..2f27debe89 100755 --- a/collects/tests/run-automated-tests.ss +++ b/collects/tests/run-automated-tests.ss @@ -31,16 +31,16 @@ ;; special flag that means that errors raised by the test suite are ;; ignored, and should only be used by the mzscheme tests.) (define tests - '(;[no-handler load "mzscheme/quiet.ss" (lib "scheme/init")] + '([no-handler load "mzscheme/quiet.ss" (lib "scheme/init")] ;; [require "planet/lang.ss"] [require "typed-scheme/nightly-run.ss"] -; [require "match/plt-match-tests.ss"] - ; ;; [require "stepper/automatic-tests.ss" (lib "scheme/base")] + [require "match/plt-match-tests.ss"] + ;; [require "stepper/automatic-tests.ss" (lib "scheme/base")] [require "lazy/main.ss"] - ; [require "scribble/main.ss"] - ;[require "net/main.ss"] -; [require "file/main.ss"] - ; [require "profile/main.ss"] + [require "scribble/main.ss"] + [require "net/main.ss"] + [require "file/main.ss"] + [require "profile/main.ss"] )) (require scheme/runtime-path) diff --git a/collects/web-server/scribblings/ctable.scrbl b/collects/web-server/scribblings/ctable.scrbl index 0366511a90..e61d9e9b61 100644 --- a/collects/web-server/scribblings/ctable.scrbl +++ b/collects/web-server/scribblings/ctable.scrbl @@ -67,8 +67,11 @@ where a @scheme[host-table-sexpr] is: (mime-types ,path-string?) (password-authentication ,path-string?)))] -In this syntax, the @scheme['messages] paths are relative to the @scheme['configuration-root] directory. -All the paths in @scheme['paths] are relative to @scheme['host-root] (other than @scheme['host-root] obviously.) +In this syntax, the @scheme['messages] paths are relative to the +@scheme['configuration-root] directory. All the paths in +@scheme['paths] except for @scheme['servlet-root] are relative to +@scheme['host-root] (other than @scheme['host-root] obviously.) +The @scheme['servlet-root] path is relative to @scheme['file-root]. Allowable @scheme['log-format]s are those accepted by @scheme[log-format->format]. diff --git a/doc/release-notes/drscheme/HISTORY.txt b/doc/release-notes/drscheme/HISTORY.txt index 69b9b68c9e..128c46a0fd 100644 --- a/doc/release-notes/drscheme/HISTORY.txt +++ b/doc/release-notes/drscheme/HISTORY.txt @@ -1,9 +1,15 @@ +------------------------------ + Version 4.2.3 +------------------------------ + + . minor bug fixes + ------------------------------ Version 4.2.2 ------------------------------ . DrScheme now (by default) automatically compiles your source - files, saving them in the compiled/drscheme/ subdirectory. + files, saving them in the compiled/drscheme/ subdirectory. . Syntax coloring now works for languages using the @-reader (ie, Scribble) diff --git a/doc/release-notes/mred/HISTORY.txt b/doc/release-notes/mred/HISTORY.txt index cd3c6ea544..4675ac45d7 100644 --- a/doc/release-notes/mred/HISTORY.txt +++ b/doc/release-notes/mred/HISTORY.txt @@ -1,3 +1,9 @@ +Version 4.2.3, November 2009 + +Minor bug fixes + +---------------------------------------------------------------------- + Version 4.2.2, September 2009 Minor bug fixes diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index 925bea770d..1c35a4436d 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -1,3 +1,8 @@ +Version 4.2.3, November 2009 +Changed _pointer (in scheme/foreign) to mean a pointer that does not + refer to GCable memory; added _gcpointer +Added scheme/vector + Version 4.2.2, September 2009 Added scheme/unsafe/ops Added print-syntax-width diff --git a/doc/release-notes/redex/HISTORY.txt b/doc/release-notes/redex/HISTORY.txt index 887b6f2499..db4fa58971 100644 --- a/doc/release-notes/redex/HISTORY.txt +++ b/doc/release-notes/redex/HISTORY.txt @@ -1,3 +1,5 @@ +v4.2.3 + * added support for collecting metafunction coverage, using the 'relation-coverage' parameter. This includes a backwards incompatible change: the parameter's value is now a list of diff --git a/doc/release-notes/stepper/HISTORY.txt b/doc/release-notes/stepper/HISTORY.txt index 618e8881a7..670fa93772 100644 --- a/doc/release-notes/stepper/HISTORY.txt +++ b/doc/release-notes/stepper/HISTORY.txt @@ -1,6 +1,10 @@ Stepper ------- +Changes for v4.2.3: + +Bug fixes, show first step as soon as it appears. + Changes for v4.2.2: Minor bug fixes. diff --git a/doc/release-notes/teachpack/HISTORY.txt b/doc/release-notes/teachpack/HISTORY.txt index 44eaab26f0..ae902a89c9 100644 --- a/doc/release-notes/teachpack/HISTORY.txt +++ b/doc/release-notes/teachpack/HISTORY.txt @@ -1,3 +1,9 @@ +------------------------------------------------------------------------ +Version 4.2.3 [Sun Nov 22 19:25:01 EST 2009] + +* bug fixes in universe +* 2htdp/image (first draft) + ------------------------------------------------------------------------ Version 4.2.2 [Sat Aug 29 15:44:41 EDT 2009] diff --git a/src/mred/gc2/Makefile.in b/src/mred/gc2/Makefile.in index 72fd98a870..271d352a1b 100644 --- a/src/mred/gc2/Makefile.in +++ b/src/mred/gc2/Makefile.in @@ -431,7 +431,7 @@ xsrc/wxs_win.cc: $(srcdir)/../wxs/wxs_win.cxx $(XFORMDEP) $(XFORMPRECOMPDEP) xsrc/wxJPEG.cc: $(srcdir)/../../wxcommon/wxJPEG.cxx $(XFORMDEP) $(XFORMPRECOMPDEP) $(XFORMWP) xsrc/wxJPEG.cc $(srcdir)/../../wxcommon/wxJPEG.cxx -GCPREINC = -DSCHEME_THREADLOCAL_H -include $(srcdir)/../../mzscheme/gc2/gc2.h +GCPREINC = -include $(srcdir)/../../mzscheme/gc2/gc2.h POSTFLAGS = $(OPTIONS) @COMPFLAGS@ @PROFFLAGS@ @CFLAGS@ XXPOSTFLAGS = $(OPTIONS) @COMPFLAGS@ @PROFFLAGS@ @CXXFLAGS@ diff --git a/src/mzscheme/cmdline.inc b/src/mzscheme/cmdline.inc index 2c4e4dfe1d..9194656ae0 100644 --- a/src/mzscheme/cmdline.inc +++ b/src/mzscheme/cmdline.inc @@ -5,7 +5,9 @@ #define SDESC "Set! works on undefined identifiers" -char *cmdline_exe_hack = "[Replace me for EXE hack ]"; +char *cmdline_exe_hack = + ("[Replace me for EXE hack " + " ]"); #ifdef MZ_PRECISE_GC # define GC_PRECISION_TYPE "3" diff --git a/src/mzscheme/gc2/gc2.h b/src/mzscheme/gc2/gc2.h index 8ff30d2c2a..8e7f14b69c 100644 --- a/src/mzscheme/gc2/gc2.h +++ b/src/mzscheme/gc2/gc2.h @@ -2,10 +2,12 @@ #ifndef __mzscheme_gc_2__ #define __mzscheme_gc_2__ -#ifdef INCLUDE_WITHOUT_PATHS -# include "schthread.h" -#else -# include "../include/schthread.h" +#ifndef GC2_JUST_MACROS +# ifdef INCLUDE_WITHOUT_PATHS +# include "schthread.h" +# else +# include "../include/schthread.h" +# endif #endif /***************************************************************************/ @@ -409,9 +411,12 @@ GC2_EXTERN void GC_switch_back_from_master(void *gc); Switches to back to gc from the master GC */ -GC2_EXTERN void *GC_make_jit_nursery_page(); +GC2_EXTERN unsigned long GC_make_jit_nursery_page(); /* - obtains a nursery page from the GC for thread local allocation + Obtains a nursery page from the GC for thread local allocation. + The result is an unsigned long because it's not a valid + pointer to a GCable object. The result becomes invalid (i.e. it's collected) + with the next GC. */ diff --git a/src/mzscheme/gc2/newgc.c b/src/mzscheme/gc2/newgc.c index 63c8163c91..bd6eda90c3 100644 --- a/src/mzscheme/gc2/newgc.c +++ b/src/mzscheme/gc2/newgc.c @@ -417,7 +417,7 @@ int GC_is_allocated(void *p) /* struct objhead is defined in gc2_obj.h */ /* Make sure alloction starts out double-word aligned. The header on each allocated object is one word, so to make - the content double-word aligned, we deeper. */ + the content double-word aligned, we may need a prefix. */ #ifdef GC_ALIGN_SIXTEEN # ifdef SIXTY_FOUR_BIT_INTEGERS # define PREFIX_WSIZE 1 @@ -722,10 +722,16 @@ inline static void gen0_free_nursery_mpage(NewGC *gc, mpage *page, size_t page_s /* Needs to be consistent with GC_alloc_alignment(): */ #define THREAD_LOCAL_PAGE_SIZE APAGE_SIZE -void *GC_make_jit_nursery_page() { +unsigned long GC_make_jit_nursery_page() { NewGC *gc = GC_get_GC(); mpage *new_mpage; + if((gc->gen0.current_size + THREAD_LOCAL_PAGE_SIZE) >= gc->gen0.max_size) { + if (!gc->dumping_avoid_collection) + garbage_collect(gc, 0); + } + gc->gen0.current_size += THREAD_LOCAL_PAGE_SIZE; + { new_mpage = gen0_create_new_nursery_mpage(gc, THREAD_LOCAL_PAGE_SIZE); @@ -736,7 +742,19 @@ void *GC_make_jit_nursery_page() { gc->thread_local_pages = new_mpage; } - return (void *)(NUM(new_mpage->addr) + new_mpage->size); + if (!new_mpage->size) { + /* To avoid roundoff problems, the JIT needs the + result to be not a multiple of THREAD_LOCAL_PAGE_SIZE, + so add a prefix if alignment didn't force one. */ +#if defined(GC_ALIGN_SIXTEEN) + new_mpage->size = 16; +#elif defined(GC_ALIGN_EIGHT) + new_mpage->size = 8; +#else + new_mpage->size = WORD_SIZE; +#endif + } + return (NUM(new_mpage->addr) + new_mpage->size); } inline static void gen0_free_jit_nursery_page(NewGC *gc, mpage *page) { @@ -1847,7 +1865,6 @@ void GC_construct_child_gc() { } static inline void save_globals_to_gc(NewGC *gc) { - gc->saved_mark_stack = mark_stack; gc->saved_GC_variable_stack = GC_variable_stack; gc->saved_GC_gen0_alloc_page_ptr = GC_gen0_alloc_page_ptr; gc->saved_GC_gen0_alloc_page_end = GC_gen0_alloc_page_end; @@ -1855,7 +1872,6 @@ static inline void save_globals_to_gc(NewGC *gc) { } static inline void restore_globals_from_gc(NewGC *gc) { - mark_stack = gc->saved_mark_stack; GC_variable_stack = gc->saved_GC_variable_stack; GC_gen0_alloc_page_ptr = gc->saved_GC_gen0_alloc_page_ptr; GC_gen0_alloc_page_end = gc->saved_GC_gen0_alloc_page_end; diff --git a/src/mzscheme/include/scheme.h b/src/mzscheme/include/scheme.h index 909b573f31..891b1c4caa 100644 --- a/src/mzscheme/include/scheme.h +++ b/src/mzscheme/include/scheme.h @@ -1658,6 +1658,7 @@ extern void *scheme_malloc_envunbox(size_t); # define XFORM_END_SKIP /**/ # define XFORM_START_SUSPEND /**/ # define XFORM_END_SUSPEND /**/ +# define XFORM_SKIP_PROC /**/ # define XFORM_START_TRUST_ARITH /**/ # define XFORM_END_TRUST_ARITH /**/ # define XFORM_CAN_IGNORE /**/ diff --git a/src/mzscheme/include/schthread.h b/src/mzscheme/include/schthread.h index 37fb3b7dba..daa47e1a72 100644 --- a/src/mzscheme/include/schthread.h +++ b/src/mzscheme/include/schthread.h @@ -25,6 +25,9 @@ # define THREAD_LOCAL __declspec(thread) # elif defined(OS_X) # define IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS +# if defined(__x86_64__) || defined(__i386__) +# define INLINE_GETSPECIFIC_ASSEMBLY_CODE +# endif # else # define THREAD_LOCAL __thread # endif @@ -92,6 +95,7 @@ typedef struct Thread_Local_Variables { unsigned long scheme_stack_boundary_; unsigned long volatile scheme_jit_stack_boundary_; volatile int scheme_future_need_gc_pause_; + int scheme_use_rtcall_; struct Scheme_Object *quick_stx_; int scheme_continuation_application_count_; int scheme_cont_capture_count_; @@ -109,7 +113,6 @@ typedef struct Thread_Local_Variables { struct Scheme_Overflow *offstack_overflow_; struct Scheme_Overflow_Jmp *scheme_overflow_jmp_; void *scheme_overflow_stack_start_; - struct future_t *current_ft_; void **codetab_tree_; int during_set_; Stack_Cache_Elem stack_cache_stack_[STACK_CACHE_SIZE]; @@ -180,7 +183,9 @@ typedef struct Thread_Local_Variables { int swap_no_setjmp_; int thread_swap_count_; int scheme_did_gc_count_; - int worker_gc_counter_; + struct Scheme_Future_State *scheme_future_state_; + struct Scheme_Future_Thread_State *scheme_future_thread_state_; + void *jit_future_storage_[2]; struct Scheme_Object **scheme_current_runstack_start_; struct Scheme_Object **scheme_current_runstack_; MZ_MARK_STACK_TYPE scheme_current_cont_mark_stack_; @@ -211,19 +216,36 @@ typedef struct Thread_Local_Variables { unsigned long current_total_allocation_; struct gmp_tmp_stack gmp_tmp_xxx_; struct gmp_tmp_stack *gmp_tmp_current_; -#if FUTURES_ENABLED - pthread_cond_t worker_can_continue_cv_; - void *jit_future_storage_[2]; -#endif + struct Scheme_Logger *scheme_main_logger_; } Thread_Local_Variables; #if defined(IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS) /* Using Pthread getspecific() */ # include MZ_EXTERN pthread_key_t scheme_thread_local_key; -# define scheme_get_thread_local_variables() ((Thread_Local_Variables *)pthread_getspecific(scheme_thread_local_key)) -#ifdef MZ_XFORM +# ifndef INLINE_GETSPECIFIC_ASSEMBLY_CODE +# define scheme_get_thread_local_variables() ((Thread_Local_Variables *)pthread_getspecific(scheme_thread_local_key)) +# ifdef MZ_XFORM XFORM_GC_VARIABLE_STACK_THROUGH_GETSPECIFIC; +# endif +# else +# ifdef MZ_XFORM +START_XFORM_SKIP; +# endif +static inline Thread_Local_Variables *scheme_get_thread_local_variables() __attribute__((used)); +static inline Thread_Local_Variables *scheme_get_thread_local_variables() { + Thread_Local_Variables *x; +# if defined(__x86_64__) + asm volatile("movq %%gs:0x8A0, %0" : "=r"(x)); +# else + asm volatile("movl %%gs:0x468, %0" : "=r"(x)); +# endif + return x; +} +# ifdef MZ_XFORM +END_XFORM_SKIP; +XFORM_GC_VARIABLE_STACK_THROUGH_FUNCTION; +# endif # endif #else /* Using `THREAD_LOCAL' variable: */ @@ -255,6 +277,7 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define scheme_stack_boundary XOA (scheme_get_thread_local_variables()->scheme_stack_boundary_) #define scheme_jit_stack_boundary XOA (scheme_get_thread_local_variables()->scheme_jit_stack_boundary_) #define scheme_future_need_gc_pause XOA (scheme_get_thread_local_variables()->scheme_future_need_gc_pause_) +#define scheme_use_rtcall XOA (scheme_get_thread_local_variables()->scheme_use_rtcall_) #define quick_stx XOA (scheme_get_thread_local_variables()->quick_stx_) #define scheme_continuation_application_count XOA (scheme_get_thread_local_variables()->scheme_continuation_application_count_) #define scheme_cont_capture_count XOA (scheme_get_thread_local_variables()->scheme_cont_capture_count_) @@ -272,7 +295,6 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define offstack_overflow XOA (scheme_get_thread_local_variables()->offstack_overflow_) #define scheme_overflow_jmp XOA (scheme_get_thread_local_variables()->scheme_overflow_jmp_) #define scheme_overflow_stack_start XOA (scheme_get_thread_local_variables()->scheme_overflow_stack_start_) -#define current_ft XOA (scheme_get_thread_local_variables()->current_ft_) #define codetab_tree XOA (scheme_get_thread_local_variables()->codetab_tree_) #define during_set XOA (scheme_get_thread_local_variables()->during_set_) #define thread_local_pointers XOA (scheme_get_thread_local_variables()->thread_local_pointers_) @@ -344,7 +366,9 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define swap_no_setjmp XOA (scheme_get_thread_local_variables()->swap_no_setjmp_) #define thread_swap_count XOA (scheme_get_thread_local_variables()->thread_swap_count_) #define scheme_did_gc_count XOA (scheme_get_thread_local_variables()->scheme_did_gc_count_) -#define worker_gc_counter XOA (scheme_get_thread_local_variables()->worker_gc_counter_) +#define scheme_future_state XOA (scheme_get_thread_local_variables()->scheme_future_state_) +#define scheme_future_thread_state XOA (scheme_get_thread_local_variables()->scheme_future_thread_state_) +#define jit_future_storage XOA (scheme_get_thread_local_variables()->jit_future_storage_) #define scheme_current_runstack_start XOA (scheme_get_thread_local_variables()->scheme_current_runstack_start_) #define scheme_current_runstack XOA (scheme_get_thread_local_variables()->scheme_current_runstack_) #define scheme_current_cont_mark_stack XOA (scheme_get_thread_local_variables()->scheme_current_cont_mark_stack_) @@ -375,8 +399,7 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define current_total_allocation XOA (scheme_get_thread_local_variables()->current_total_allocation_) #define gmp_tmp_xxx XOA (scheme_get_thread_local_variables()->gmp_tmp_xxx_) #define gmp_tmp_current XOA (scheme_get_thread_local_variables()->gmp_tmp_current_) -#define worker_can_continue_cv XOA (scheme_get_thread_local_variables()->worker_can_continue_cv_) -#define jit_future_storage XOA (scheme_get_thread_local_variables()->jit_future_storage_) +#define scheme_main_logger XOA (scheme_get_thread_local_variables()->scheme_main_logger_) /* **************************************** */ diff --git a/src/mzscheme/main.c b/src/mzscheme/main.c index 41c3260aac..7ee244e0cb 100644 --- a/src/mzscheme/main.c +++ b/src/mzscheme/main.c @@ -248,6 +248,10 @@ typedef struct { MAIN_char **argv; } Main_Args; +# ifdef MZ_PRECISE_GC +START_XFORM_SKIP; +# endif + static int main_after_dlls(int argc, MAIN_char **argv) { Main_Args ma; @@ -256,6 +260,10 @@ static int main_after_dlls(int argc, MAIN_char **argv) return scheme_main_stack_setup(1, main_after_stack, &ma); } +# ifdef MZ_PRECISE_GC +END_XFORM_SKIP; +# endif + /************************ main_after_stack *************************/ /* Setup, parse command-line, and go to cont_run */ diff --git a/src/mzscheme/src/Makefile.in b/src/mzscheme/src/Makefile.in index b95cadcb60..5b6dce72e8 100644 --- a/src/mzscheme/src/Makefile.in +++ b/src/mzscheme/src/Makefile.in @@ -272,7 +272,8 @@ fun.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c $(srcdir)/schmap.inc \ $(srcdir)/future.h future.@LTO@: $(srcdir)/schpriv.h $(srcdir)/future.h $(SCONFIG) $(srcdir)/../include/scheme.h \ - $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c + $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c \ + $(srcdir)/jit_ts_future_glue.c $(srcdir)/jit_ts_runtime_glue.c $(srcdir)/jit_ts_protos.h hash.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c jit.@LTO@: $(COMMON_HEADERS) \ @@ -285,7 +286,7 @@ jit.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/lightning/ppc/asm.h $(srcdir)/lightning/ppc/asm-common.h \ $(srcdir)/lightning/ppc/funcs.h $(srcdir)/lightning/ppc/funcs-common.h \ $(srcdir)/lightning/ppc/fp.h $(srcdir)/lightning/ppc/fp-common.h \ - $(srcdir)/future.h + $(srcdir)/future.h $(srcdir)/jit_ts.c $(srcdir)/jit_ts_protos.h list.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h module.@LTO@: $(COMMON_HEADERS) \ diff --git a/src/mzscheme/src/bignum.c b/src/mzscheme/src/bignum.c index be985853a6..d2fb94dbd3 100644 --- a/src/mzscheme/src/bignum.c +++ b/src/mzscheme/src/bignum.c @@ -174,14 +174,10 @@ void scheme_clear_bignum_cache(void) void scheme_clear_bignum_cache(void) { } #endif -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - - #define xor(a, b) (!(a) ^ !(b)) Scheme_Object *scheme_make_small_bignum(long v, Small_Bignum *o) + XFORM_SKIP_PROC { bigdig bv; @@ -208,10 +204,6 @@ Scheme_Object *scheme_make_small_bignum(long v, Small_Bignum *o) return (Scheme_Object *) mzALIAS o; } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - Scheme_Object *scheme_make_bignum(long v) { Small_Bignum *r; diff --git a/src/mzscheme/src/complex.c b/src/mzscheme/src/complex.c index 0a74a59410..5eb359e88b 100644 --- a/src/mzscheme/src/complex.c +++ b/src/mzscheme/src/complex.c @@ -56,11 +56,8 @@ Scheme_Object *scheme_real_to_complex(const Scheme_Object *n) return make_complex(n, zero, 0); } -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - Scheme_Object *scheme_make_small_complex(const Scheme_Object *n, Small_Complex *s) + XFORM_SKIP_PROC { s->so.type = scheme_complex_type; s->r = (Scheme_Object *)n; @@ -69,10 +66,6 @@ Scheme_Object *scheme_make_small_complex(const Scheme_Object *n, Small_Complex * return (Scheme_Object *)s; } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - int scheme_is_complex_exact(const Scheme_Object *o) { Scheme_Complex *c = (Scheme_Complex *)o; diff --git a/src/mzscheme/src/dynext.c b/src/mzscheme/src/dynext.c index e38417d32c..5cb994113b 100644 --- a/src/mzscheme/src/dynext.c +++ b/src/mzscheme/src/dynext.c @@ -463,19 +463,12 @@ static Scheme_Object *do_load_extension(const char *filename, #endif } -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - void scheme_register_extension_global(void *ptr, long size) + XFORM_SKIP_PROC { GC_add_roots((char *)ptr, (char *)(((char *)ptr) + size + 1)); } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - static Scheme_Object *load_extension(int argc, Scheme_Object **argv) { return scheme_load_with_clrd(argc, argv, "load-extension", MZCONFIG_LOAD_EXTENSION_HANDLER); diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index a4c4d2ac19..8336e4776e 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -144,7 +144,7 @@ int scheme_is_module_begin_env(Scheme_Comp_Env *env); Scheme_Env *scheme_engine_instance_init(); Scheme_Env *scheme_place_instance_init(); static void place_instance_init_pre_kernel(); -static Scheme_Env *place_instance_init_post_kernel(); +static Scheme_Env *place_instance_init_post_kernel(int initial_main_os_thread); #ifdef MZ_PRECISE_GC static void register_traversers(void); @@ -361,7 +361,7 @@ Scheme_Env *scheme_engine_instance_init() { place_instance_init_pre_kernel(stack_base); make_kernel_env(); scheme_init_parameterization_readonly_globals(); - env = place_instance_init_post_kernel(); + env = place_instance_init_post_kernel(1); return env; } @@ -428,7 +428,7 @@ Scheme_Env *scheme_get_unsafe_env() { return unsafe_env; } -static Scheme_Env *place_instance_init_post_kernel() { +static Scheme_Env *place_instance_init_post_kernel(int initial_main_os_thread) { Scheme_Env *env; /* error handling and buffers */ /* this check prevents initializing orig ports twice for the first initial @@ -439,9 +439,10 @@ static Scheme_Env *place_instance_init_post_kernel() { } scheme_init_error_escape_proc(NULL); scheme_init_print_buffers_places(); + scheme_init_logger(); scheme_init_eval_places(); scheme_init_regexp_places(); - scheme_init_stx_places(); + scheme_init_stx_places(initial_main_os_thread); scheme_init_sema_places(); scheme_init_gmp_places(); scheme_alloc_global_fdset(); @@ -453,6 +454,7 @@ static Scheme_Env *place_instance_init_post_kernel() { scheme_init_port_config(); scheme_init_port_fun_config(); scheme_init_error_config(); + scheme_init_logger_config(); #ifndef NO_SCHEME_EXNS scheme_init_exn_config(); #endif @@ -495,7 +497,7 @@ static Scheme_Env *place_instance_init_post_kernel() { Scheme_Env *scheme_place_instance_init(void *stack_base) { place_instance_init_pre_kernel(stack_base); - return place_instance_init_post_kernel(); + return place_instance_init_post_kernel(0); } void scheme_place_instance_destroy() { @@ -1361,6 +1363,37 @@ Scheme_Hash_Table *scheme_map_constants_to_globals(void) return result; } +const char *scheme_look_for_primitive(void *code) +{ + Scheme_Bucket_Table *ht; + Scheme_Bucket **bs; + Scheme_Env *kenv; + long i; + int j; + + for (j = 0; j < 2; j++) { + if (!j) + kenv = kernel_env; + else + kenv = unsafe_env; + + ht = kenv->toplevel; + bs = ht->buckets; + + for (i = ht->size; i--; ) { + Scheme_Bucket *b = bs[i]; + if (b && b->val) { + if (SCHEME_PRIMP(b->val)) { + if (SCHEME_PRIM(b->val) == code) + return ((Scheme_Primitive_Proc *)b->val)->name; + } + } + } + } + + return NULL; +} + /*========================================================================*/ /* compile-time env, constructors and simple queries */ /*========================================================================*/ diff --git a/src/mzscheme/src/error.c b/src/mzscheme/src/error.c index 1bb6fa88e2..5f72cf30ef 100644 --- a/src/mzscheme/src/error.c +++ b/src/mzscheme/src/error.c @@ -50,8 +50,7 @@ void (*scheme_console_output)(char *str, long len); static int init_syslog_level = INIT_SYSLOG_LEVEL; static int init_stderr_level = SCHEME_LOG_ERROR; -Scheme_Logger *scheme_main_logger; -static void init_logger_config(); +THREAD_LOCAL_DECL(static Scheme_Logger *scheme_main_logger); /* readonly globals */ const char *scheme_compile_stx_string = "compile"; @@ -177,6 +176,7 @@ Scheme_Config *scheme_init_error_escape_proc(Scheme_Config *config) %c = unicode char %d = int %ld = long int + %lx = long int %o = int, octal %f = double %% = percent @@ -333,9 +333,14 @@ static long sch_vsprintf(char *s, long maxlen, const char *msg, va_list args, ch case 'l': { long d; + int as_hex; + as_hex = (msg[j] == 'x'); j++; d = ints[ip++]; - sprintf(buf, "%ld", d); + if (as_hex) + sprintf(buf, "%lx", d); + else + sprintf(buf, "%ld", d); t = buf; tlen = strlen(t); } @@ -343,7 +348,6 @@ static long sch_vsprintf(char *s, long maxlen, const char *msg, va_list args, ch case 'f': { double f; - j++; f = dbls[dp++]; sprintf(buf, "%f", f); t = buf; @@ -584,7 +588,13 @@ void scheme_init_error(Scheme_Env *env) scheme_add_evt(scheme_log_reader_type, (Scheme_Ready_Fun)log_reader_get, NULL, NULL, 1); REGISTER_SO(scheme_def_exit_proc); + REGISTER_SO(default_display_handler); + REGISTER_SO(emergency_display_handler); + scheme_def_exit_proc = scheme_make_prim_w_arity(def_exit_handler_proc, "default-exit-handler", 1, 1); + default_display_handler = scheme_make_prim_w_arity(def_error_display_proc, "default-error-display-handler", 2, 2); + emergency_display_handler = scheme_make_prim_w_arity(emergency_error_display_proc, "emergency-error-display-handler", 2, 2); + REGISTER_SO(def_err_val_proc); def_err_val_proc = scheme_make_prim_w_arity(def_error_value_string_proc, "default-error-value->string-handler", 2, 2); @@ -600,14 +610,6 @@ void scheme_init_error(Scheme_Env *env) info_symbol = scheme_intern_symbol("info"); debug_symbol = scheme_intern_symbol("debug"); - { - REGISTER_SO(scheme_main_logger); - scheme_main_logger = make_a_logger(NULL, NULL); - scheme_main_logger->syslog_level = init_syslog_level; - scheme_main_logger->stderr_level = init_stderr_level; - } - init_logger_config(); - REGISTER_SO(arity_property); { Scheme_Object *guard; @@ -620,27 +622,29 @@ void scheme_init_error(Scheme_Env *env) scheme_init_error_config(); } -static void init_logger_config() +void scheme_init_logger() { - scheme_set_root_param(MZCONFIG_LOGGER, (Scheme_Object *)scheme_main_logger); + REGISTER_SO(scheme_main_logger); + scheme_main_logger = make_a_logger(NULL, NULL); + scheme_main_logger->syslog_level = init_syslog_level; + scheme_main_logger->stderr_level = init_stderr_level; +} + +Scheme_Logger *scheme_get_main_logger() { + return scheme_main_logger; } void scheme_init_error_config(void) { - init_logger_config(); - scheme_set_root_param(MZCONFIG_EXIT_HANDLER, scheme_def_exit_proc); - - REGISTER_SO(default_display_handler); - REGISTER_SO(emergency_display_handler); - - default_display_handler = scheme_make_prim_w_arity(def_error_display_proc, "default-error-display-handler", 2, 2); - emergency_display_handler = scheme_make_prim_w_arity(emergency_error_display_proc, "emergency-error-display-handler", 2, 2); - scheme_set_root_param(MZCONFIG_ERROR_DISPLAY_HANDLER, default_display_handler); scheme_set_root_param(MZCONFIG_ERROR_PRINT_VALUE_HANDLER, def_err_val_proc); } +void scheme_init_logger_config() { + scheme_set_root_param(MZCONFIG_LOGGER, (Scheme_Object *)scheme_main_logger); +} + static void scheme_inescapeable_error(const char *a, const char *b) { diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 7a3a8146cf..08725e0da4 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -145,9 +145,6 @@ #endif #ifdef FUTURES_ENABLED # include "future.h" -#else -# define LOG_PRIM_START(x) /* empty */ -# define LOG_PRIM_END(x) /* empty */ #endif #define EMBEDDED_DEFINES_START_ANYWHERE 0 @@ -7863,9 +7860,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, f = prim->prim_val; - LOG_PRIM_START(f); v = f(num_rands, rands, (Scheme_Object *)prim); - LOG_PRIM_END(f); DEBUG_CHECK_TYPE(v); } else if (type == scheme_closure_type) { diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index bf32589335..6354dbaeb0 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -7945,11 +7945,9 @@ void scheme_apply_dw_in_meta(Scheme_Dynamic_Wind *dw, int post_part, int meta_de #define CLOCKS_PER_SEC 1000000 #endif -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - long scheme_get_milliseconds(void) + XFORM_SKIP_PROC +/* this function can be called from any OS thread */ { #ifdef USE_MACTIME return scheme_get_process_milliseconds(); @@ -7972,6 +7970,8 @@ long scheme_get_milliseconds(void) } double scheme_get_inexact_milliseconds(void) + XFORM_SKIP_PROC +/* this function can be called from any OS thread */ { #ifdef USE_MACTIME { @@ -8000,6 +8000,7 @@ double scheme_get_inexact_milliseconds(void) } long scheme_get_process_milliseconds(void) + XFORM_SKIP_PROC { #ifdef USER_TIME_IS_CLOCK return scheme_get_milliseconds(); @@ -8043,6 +8044,7 @@ long scheme_get_process_milliseconds(void) } long scheme_get_thread_milliseconds(Scheme_Object *thrd) + XFORM_SKIP_PROC { Scheme_Thread *t = thrd ? (Scheme_Thread *)thrd : scheme_current_thread; @@ -8055,10 +8057,6 @@ long scheme_get_thread_milliseconds(Scheme_Object *thrd) } } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - long scheme_get_seconds(void) { #ifdef USE_MACTIME diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c index b7fa5e1c85..4cd5930ec5 100644 --- a/src/mzscheme/src/future.c +++ b/src/mzscheme/src/future.c @@ -1,28 +1,132 @@ +/* + MzScheme + Copyright (c) 2006-2009 PLT Scheme Inc. -#ifndef UNIT_TEST -# include "schpriv.h" -#endif + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. -#ifdef INSTRUMENT_PRIMITIVES -int g_print_prims = 0; + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301 USA. +*/ + +#include "schpriv.h" + +//This will be TRUE if primitive tracking has been enabled +//by the program + +static Scheme_Object *future_p(int argc, Scheme_Object *argv[]) +{ + if (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_future_type)) + return scheme_true; + else + return scheme_false; +} + +#ifdef MZ_PRECISE_GC +static void register_traversers(void); #endif #ifndef FUTURES_ENABLED -/* Futures not enabled, but make a stub module */ +/* Futures not enabled, but make a stub module and implementation */ + +typedef struct future_t { + Scheme_Object so; + Scheme_Object *running_sema; + Scheme_Object *orig_lambda; + Scheme_Object *retval; + int multiple_count; + Scheme_Object **multiple_array; + int no_retval; +} future_t; static Scheme_Object *future(int argc, Scheme_Object *argv[]) { - scheme_signal_error("future: not enabled"); - return NULL; + future_t *ft; + + scheme_check_proc_arity("future", 0, 0, argc, argv); + + ft = MALLOC_ONE_TAGGED(future_t); + ft->so.type = scheme_future_type; + + ft->orig_lambda = argv[0]; + + return (Scheme_Object *)ft; } static Scheme_Object *touch(int argc, Scheme_Object *argv[]) { - scheme_signal_error("touch: not enabled"); + future_t * volatile ft; + + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_future_type)) + scheme_wrong_type("touch", "future", 0, argc, argv); + + ft = (future_t *)argv[0]; + + while (1) { + if (ft->retval) { + if (SAME_OBJ(ft->retval, SCHEME_MULTIPLE_VALUES)) { + Scheme_Thread *p = scheme_current_thread; + p->ku.multiple.array = ft->multiple_array; + p->ku.multiple.count = ft->multiple_count; + } + return ft->retval; + } + if (ft->no_retval) + scheme_signal_error("touch: future previously aborted"); + + if (ft->running_sema) { + scheme_wait_sema(ft->running_sema, 0); + scheme_post_sema(ft->running_sema); + } else { + Scheme_Object *sema; + mz_jmp_buf newbuf, * volatile savebuf; + Scheme_Thread *p = scheme_current_thread; + + /* In case another Scheme thread touchs the future. */ + sema = scheme_make_sema(0); + ft->running_sema = sema; + + savebuf = p->error_buf; + p->error_buf = &newbuf; + if (scheme_setjmp(newbuf)) { + ft->no_retval = 1; + scheme_post_sema(ft->running_sema); + scheme_longjmp(*savebuf, 1); + } else { + GC_CAN_IGNORE Scheme_Object *retval, *proc; + proc = ft->orig_lambda; + ft->orig_lambda = NULL; /* don't hold on to proc */ + retval = scheme_apply_multi(proc, 0, NULL); + ft->retval = retval; + if (SAME_OBJ(retval, SCHEME_MULTIPLE_VALUES)) { + ft->multiple_array = p->ku.multiple.array; + ft->multiple_count = p->ku.multiple.count; + p->ku.multiple.array = NULL; + } + scheme_post_sema(ft->running_sema); + p->error_buf = savebuf; + } + } + } + return NULL; } +static Scheme_Object *processor_count(int argc, Scheme_Object *argv[]) +{ + return scheme_make_integer(1); +} + # define FUTURE_PRIM_W_ARITY(name, func, a1, a2, env) GLOBAL_PRIM_W_ARITY(name, func, a1, a2, env) void scheme_init_futures(Scheme_Env *env) @@ -32,11 +136,17 @@ void scheme_init_futures(Scheme_Env *env) newenv = scheme_primitive_module(scheme_intern_symbol("#%futures"), env); - FUTURE_PRIM_W_ARITY("future", future, 1, 1, newenv); - FUTURE_PRIM_W_ARITY("touch", touch, 1, 1, newenv); + FUTURE_PRIM_W_ARITY("future?", future_p, 1, 1, newenv); + FUTURE_PRIM_W_ARITY("future", future, 1, 1, newenv); + FUTURE_PRIM_W_ARITY("touch", touch, 1, 1, newenv); + FUTURE_PRIM_W_ARITY("processor-count", processor_count, 1, 1, newenv); scheme_finish_primitive_module(newenv); scheme_protect_primitive_provide(newenv, NULL); + +#ifdef MZ_PRECISE_GC + register_traversers(); +#endif } #else @@ -44,150 +154,77 @@ void scheme_init_futures(Scheme_Env *env) #include "future.h" #include #include -#ifdef UNIT_TEST -# include "./tests/unit_test.h" -#endif -extern void *on_demand_jit_code; +static Scheme_Object *future(int argc, Scheme_Object *argv[]); +static Scheme_Object *touch(int argc, Scheme_Object *argv[]); +static Scheme_Object *processor_count(int argc, Scheme_Object *argv[]); +static void futures_init(void); +static void init_future_thread(struct Scheme_Future_State *fs, int i); -#define THREAD_POOL_SIZE 7 +#define THREAD_POOL_SIZE 12 #define INITIAL_C_STACK_SIZE 500000 -static pthread_t g_pool_threads[THREAD_POOL_SIZE]; -static int *g_fuel_pointers[THREAD_POOL_SIZE]; -static unsigned long *g_stack_boundary_pointers[THREAD_POOL_SIZE]; -static int *g_need_gc_pointers[THREAD_POOL_SIZE]; -static int g_num_avail_threads = 0; -static unsigned long g_cur_cpu_mask = 1; -static void *g_signal_handle = NULL; -static struct NewGC *g_shared_GC; -future_t *g_future_queue = NULL; -future_t *g_future_waiting_atomic = NULL; -int g_next_futureid = 0; -pthread_t g_rt_threadid = 0; +typedef struct Scheme_Future_State { + struct Scheme_Future_Thread_State *pool_threads[THREAD_POOL_SIZE]; -static pthread_mutex_t g_future_queue_mutex = PTHREAD_MUTEX_INITIALIZER; -static pthread_cond_t g_future_pending_cv = PTHREAD_COND_INITIALIZER; + void *signal_handle; -THREAD_LOCAL_DECL(static pthread_cond_t worker_can_continue_cv); + int future_queue_count; + future_t *future_queue; + future_t *future_queue_end; + future_t *future_waiting_atomic; + int next_futureid; + + pthread_mutex_t future_mutex; + pthread_cond_t future_pending_cv; + pthread_cond_t gc_ok_c; + pthread_cond_t gc_done_c; + + int gc_not_ok, wait_for_gc; + + int *gc_counter_ptr; + + int future_threads_created; +} Scheme_Future_State; + +typedef struct Scheme_Future_Thread_State { + int id; + pthread_t threadid; + int worker_gc_counter; + pthread_cond_t worker_can_continue_cv; + future_t *current_ft; + long runstack_size; + + volatile int *fuel_pointer; + volatile unsigned long *stack_boundary_pointer; + volatile int *need_gc_pointer; +} Scheme_Future_Thread_State; + +THREAD_LOCAL_DECL(static Scheme_Future_State *scheme_future_state); +THREAD_LOCAL_DECL(void *jit_future_storage[2]); -static pthread_mutex_t gc_ok_m = PTHREAD_MUTEX_INITIALIZER; -static pthread_cond_t gc_ok_c = PTHREAD_COND_INITIALIZER; -static pthread_cond_t gc_done_c = PTHREAD_COND_INITIALIZER; -static int gc_not_ok, wait_for_gc; #ifdef MZ_PRECISE_GC THREAD_LOCAL_DECL(extern unsigned long GC_gen0_alloc_page_ptr); #endif -static future_t **g_current_ft; -static Scheme_Object ***g_scheme_current_runstack; -static Scheme_Object ***g_scheme_current_runstack_start; -static void **g_jit_future_storage; -static int *gc_counter_ptr; -THREAD_LOCAL_DECL(static int worker_gc_counter); +static void start_gc_not_ok(Scheme_Future_State *fs); +static void end_gc_not_ok(Scheme_Future_Thread_State *fts, + Scheme_Future_State *fs, + Scheme_Object **current_rs); -static void register_traversers(void); -extern void scheme_on_demand_generate_lambda(Scheme_Native_Closure *nc, int argc, Scheme_Object **argv); - -static void start_gc_not_ok(int with_lock); -static void end_gc_not_ok(future_t *ft, int with_lock); - -static int future_do_runtimecall(void *func, int is_atomic, void *retval); - -THREAD_LOCAL_DECL(static future_t *current_ft); - -//Stuff for scheme runstack -//Some of these may mimic defines in thread.c, but are redefined here -//to avoid making any changes to that file for now (moving anything out into common -//headers, etc.) -#ifndef DEFAULT_INIT_STACK_SIZE -#define DEFAULT_INIT_STACK_SIZE 1000 -#endif - -//Functions -#ifndef UNIT_TEST static void *worker_thread_future_loop(void *arg); -static void invoke_rtcall(future_t *future); -static future_t *enqueue_future(future_t *ft);; -static future_t *get_pending_future(void); -static future_t *get_my_future(void); -static future_t *get_last_future(void); +static void invoke_rtcall(Scheme_Future_State * volatile fs, future_t * volatile future); +static future_t *enqueue_future(Scheme_Future_State *fs, future_t *ft);; +static future_t *get_pending_future(Scheme_Future_State *fs); +static void receive_special_result(future_t *f, Scheme_Object *retval, int clear); +static void send_special_result(future_t *f, Scheme_Object *retval); + +#ifdef MZ_PRECISE_GC +# define scheme_future_setjmp(newbuf) scheme_jit_setjmp((newbuf).jb) +# define scheme_future_longjmp(newbuf, v) scheme_jit_longjmp((newbuf).jb, v) #else -//Garbage stubs for unit testing -#define START_XFORM_SKIP -#define END_XFORM_SKIP -void scheme_add_global(char *name, int arity, Scheme_Env *env) { } -int scheme_make_prim_w_arity(prim_t func, char *name, int arg1, int arg2) { return 1; } -Scheme_Object *future_touch(int futureid) -{ - Scheme_Object *args[1] = { &futureid }; - return touch(1, args); -} -#endif - -void *g_funcargs[5]; -void *func_retval = NULL; - - -/**********************************************************************/ -/* Helpers for debugging */ -/**********************************************************************/ -#ifdef DEBUG_FUTURES -int g_rtcall_count = 0; - -static Scheme_Object **get_thread_runstack(void) -{ - return MZ_RUNSTACK; -} - - -static Scheme_Object **get_thread_runstack_start(void) -{ - return MZ_RUNSTACK_START; -} - -void dump_state(void) -{ - future_t *f; - pthread_mutex_lock(&g_future_queue_mutex); - printf("\n"); - printf("FUTURES STATE:\n"); - printf("-------------------------------------------------------------\n"); - if (NULL == g_future_queue) - { - printf("No futures currently running. %d thread(s) available in the thread pool.\n\n", g_num_avail_threads); - pthread_mutex_unlock(&g_future_queue_mutex); - return; - } - - for (f = g_future_queue; f != NULL; f = f->next) - { - printf("Future %d [Thread: %p, Runstack start = %p, Runstack = %p]: ", f->id, f->threadid, f->runstack_start, f->runstack); - fflush(stdout); - switch (f->status) - { - case PENDING: - printf("Waiting to be assigned to thread\n"); - break; - case RUNNING: - printf("Executing JIT code\n"); - break; - case WAITING_FOR_PRIM: - printf("Waiting for runtime primitive invocation (prim=%p)\n", (void*)f->rt_prim); - break; - case FINISHED: - printf("Finished work, waiting for cleanup\n"); - break; - } - - fflush(stdout); - printf("%d thread(s) available in the thread pool.\n", g_num_avail_threads); - printf("\n"); - fflush(stdout); - } - - pthread_mutex_unlock(&g_future_queue_mutex); -} +# define scheme_future_setjmp(newbuf) scheme_setjmp(newbuf) +# define scheme_future_longjmp(newbuf, v) scheme_longjmp(newbuf, v) #endif /**********************************************************************/ @@ -200,9 +237,6 @@ typedef struct sema_t { pthread_cond_t c; } sema_t; -#define SEMA_INITIALIZER { 0, PTHREAD_MUTEX_INITIALIZER, \ - PTHREAD_COND_INITIALIZER } - static void sema_wait(sema_t *s) { pthread_mutex_lock(&s->m); @@ -221,7 +255,36 @@ static void sema_signal(sema_t *s) pthread_mutex_unlock(&s->m); } -static sema_t ready_sema = SEMA_INITIALIZER; +static void sema_init(sema_t *s) +{ + pthread_mutex_init(&s->m, NULL); + pthread_cond_init(&s->c, NULL); + s->ready = 0; +} + +static void sema_destroy(sema_t *s) +{ + pthread_mutex_destroy(&s->m); + pthread_cond_destroy(&s->c); +} + +/**********************************************************************/ +/* Arguments for a newly created future thread */ +/**********************************************************************/ + +typedef struct future_thread_params_t { + struct sema_t ready_sema; + struct NewGC *shared_GC; + Scheme_Future_State *fs; + Scheme_Future_Thread_State *fts; + Scheme_Thread *thread_skeleton; + Scheme_Object **runstack_start; + + Scheme_Object ***scheme_current_runstack_ptr; + Scheme_Object ***scheme_current_runstack_start_ptr; + Scheme_Thread **current_thread_ptr; + void *jit_future_storage_ptr; +} future_thread_params_t; /**********************************************************************/ /* Plumbing for MzScheme initialization */ @@ -239,6 +302,16 @@ void scheme_init_futures(Scheme_Env *env) v = scheme_intern_symbol("#%futures"); newenv = scheme_primitive_module(v, env); + scheme_add_global_constant( + "future?", + scheme_make_folding_prim( + future_p, + "future?", + 1, + 1, + 1), + newenv); + scheme_add_global_constant( "future", scheme_make_prim_w_arity( @@ -249,10 +322,10 @@ void scheme_init_futures(Scheme_Env *env) newenv); scheme_add_global_constant( - "num-processors", + "processor-count", scheme_make_prim_w_arity( - num_processors, - "num-processors", + processor_count, + "processor-count", 0, 0), newenv); @@ -266,217 +339,192 @@ void scheme_init_futures(Scheme_Env *env) 1), newenv); -#ifdef INSTRUMENT_PRIMITIVES - scheme_add_global_constant( - "start-primitive-tracking", - scheme_make_prim_w_arity( - start_primitive_tracking, - "start-primitive-tracking", - 0, - 0), - newenv); - - scheme_add_global_constant( - "end-primitive-tracking", - scheme_make_prim_w_arity( - end_primitive_tracking, - "end-primitive-tracking", - 0, - 0), - newenv); -#endif - scheme_finish_primitive_module(newenv); scheme_protect_primitive_provide(newenv, NULL); - - REGISTER_SO(g_future_queue); } - -//Setup code here that should be invoked on -//the runtime thread. void futures_init(void) { - int i; - pthread_t threadid; - GC_CAN_IGNORE pthread_attr_t attr; - g_rt_threadid = pthread_self(); - g_signal_handle = scheme_get_signal_handle(); + Scheme_Future_State *fs; + void *hand; + + fs = (Scheme_Future_State *)malloc(sizeof(Scheme_Future_State)); + memset(fs, 0, sizeof(Scheme_Future_State)); + scheme_future_state = fs; + + REGISTER_SO(fs->future_queue); + REGISTER_SO(fs->future_queue_end); + REGISTER_SO(fs->future_waiting_atomic); + + pthread_mutex_init(&fs->future_mutex, NULL); + pthread_cond_init(&fs->future_pending_cv, NULL); + pthread_cond_init(&fs->gc_ok_c, NULL); + pthread_cond_init(&fs->gc_done_c, NULL); + + fs->gc_counter_ptr = &scheme_did_gc_count; + + hand = scheme_get_signal_handle(); + fs->signal_handle = hand; #ifdef MZ_PRECISE_GC register_traversers(); #endif +} + +static void init_future_thread(Scheme_Future_State *fs, int i) +{ + Scheme_Future_Thread_State *fts; + GC_CAN_IGNORE future_thread_params_t params; + pthread_t threadid; + GC_CAN_IGNORE pthread_attr_t attr; //Create the worker thread pool. These threads will //'queue up' and wait for futures to become available pthread_attr_init(&attr); - pthread_attr_setstacksize(&attr, INITIAL_C_STACK_SIZE); - for (i = 0; i < THREAD_POOL_SIZE; i++) - { - /* FIXME: insteda of using global variables, we need to - commuincate though some record. Global variables - won't work with places, since the relevant values - are all place-specific. */ - gc_counter_ptr = &scheme_did_gc_count; - g_shared_GC = GC; - pthread_create(&threadid, &attr, worker_thread_future_loop, &i); - sema_wait(&ready_sema); - - scheme_register_static(g_current_ft, sizeof(void*)); - scheme_register_static(g_scheme_current_runstack, sizeof(void*)); - scheme_register_static(g_scheme_current_runstack_start, sizeof(void*)); - scheme_register_static(g_jit_future_storage, 2 * sizeof(void*)); + pthread_attr_setstacksize(&attr, INITIAL_C_STACK_SIZE); - g_pool_threads[i] = threadid; - } + fts = (Scheme_Future_Thread_State *)malloc(sizeof(Scheme_Future_Thread_State)); + memset(fts, 0, sizeof(Scheme_Future_Thread_State)); + fts->id = i; - g_num_avail_threads = THREAD_POOL_SIZE; -} + params.shared_GC = GC; + params.fts = fts; + params.fs = fs; -static void start_gc_not_ok(int with_lock) -{ - if (with_lock) - pthread_mutex_lock(&gc_ok_m); + /* Make enough of a thread record to deal with multiple values. */ + params.thread_skeleton = MALLOC_ONE_TAGGED(Scheme_Thread); + params.thread_skeleton->so.type = scheme_thread_type; - while (wait_for_gc) { - pthread_cond_wait(&gc_done_c, &gc_ok_m); + { + Scheme_Object **rs_start, **rs; + long init_runstack_size = 1000; + rs_start = scheme_alloc_runstack(init_runstack_size); + rs = rs_start XFORM_OK_PLUS init_runstack_size; + params.runstack_start = rs_start; + fts->runstack_size = init_runstack_size; } - gc_not_ok++; - if (with_lock) - pthread_mutex_unlock(&gc_ok_m); + sema_init(¶ms.ready_sema); + pthread_create(&threadid, &attr, worker_thread_future_loop, ¶ms); + sema_wait(¶ms.ready_sema); + sema_destroy(¶ms.ready_sema); + + fts->threadid = threadid; + + scheme_register_static(&fts->current_ft, sizeof(void*)); + scheme_register_static(params.scheme_current_runstack_ptr, sizeof(void*)); + scheme_register_static(params.scheme_current_runstack_start_ptr, sizeof(void*)); + scheme_register_static(params.jit_future_storage_ptr, 2 * sizeof(void*)); + scheme_register_static(params.current_thread_ptr, sizeof(void*)); + + fs->pool_threads[i] = fts; +} + +static void start_gc_not_ok(Scheme_Future_State *fs) +{ + while (fs->wait_for_gc) { + pthread_cond_wait(&fs->gc_done_c, &fs->future_mutex); + } + + fs->gc_not_ok++; + #ifdef MZ_PRECISE_GC - if (worker_gc_counter != *gc_counter_ptr) { - GC_gen0_alloc_page_ptr = 0; /* forces future to ask for memory */ - worker_gc_counter = *gc_counter_ptr; + { + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + if (fts->worker_gc_counter != *fs->gc_counter_ptr) { + GC_gen0_alloc_page_ptr = 0; /* forces future to ask for memory */ + fts->worker_gc_counter = *fs->gc_counter_ptr; + } } #endif } -static void end_gc_not_ok(future_t *ft, int with_lock) +static void end_gc_not_ok(Scheme_Future_Thread_State *fts, + Scheme_Future_State *fs, + Scheme_Object **current_rs) { - if (ft) { - scheme_set_runstack_limits(ft->runstack_start, - ft->runstack_size, - ft->runstack - ft->runstack_start, - ft->runstack_size); - } - if (with_lock) - pthread_mutex_lock(&gc_ok_m); - --gc_not_ok; - pthread_cond_signal(&gc_ok_c); - if (with_lock) - pthread_mutex_unlock(&gc_ok_m); + scheme_set_runstack_limits(MZ_RUNSTACK_START, + fts->runstack_size, + (current_rs + ? current_rs XFORM_OK_MINUS MZ_RUNSTACK_START + : fts->runstack_size), + fts->runstack_size); + + /* FIXME: clear scheme_current_thread->ku.multiple.array ? */ + + --fs->gc_not_ok; + pthread_cond_signal(&fs->gc_ok_c); } void scheme_future_block_until_gc() { + Scheme_Future_State *fs = scheme_future_state; int i; - pthread_mutex_lock(&gc_ok_m); - wait_for_gc = 1; - pthread_mutex_unlock(&gc_ok_m); + if (!fs) return; + + pthread_mutex_lock(&fs->future_mutex); + fs->wait_for_gc = 1; + pthread_mutex_unlock(&fs->future_mutex); for (i = 0; i < THREAD_POOL_SIZE; i++) { - if (g_fuel_pointers[i] != NULL) - { - *(g_need_gc_pointers[i]) = 1; - *(g_fuel_pointers[i]) = 0; - *(g_stack_boundary_pointers[i]) += INITIAL_C_STACK_SIZE; - } + if (fs->pool_threads[i]) { + *(fs->pool_threads[i]->need_gc_pointer) = 1; + *(fs->pool_threads[i]->fuel_pointer) = 0; + *(fs->pool_threads[i]->stack_boundary_pointer) += INITIAL_C_STACK_SIZE; + } } asm("mfence"); - pthread_mutex_lock(&gc_ok_m); - while (gc_not_ok) { - pthread_cond_wait(&gc_ok_c, &gc_ok_m); + pthread_mutex_lock(&fs->future_mutex); + while (fs->gc_not_ok) { + pthread_cond_wait(&fs->gc_ok_c, &fs->future_mutex); } - pthread_mutex_unlock(&gc_ok_m); + pthread_mutex_unlock(&fs->future_mutex); } void scheme_future_continue_after_gc() { + Scheme_Future_State *fs = scheme_future_state; int i; + if (!fs) return; + for (i = 0; i < THREAD_POOL_SIZE; i++) { - if (g_fuel_pointers[i] != NULL) - { - *(g_need_gc_pointers[i]) = 0; - *(g_fuel_pointers[i]) = 1; - *(g_stack_boundary_pointers[i]) -= INITIAL_C_STACK_SIZE; - } - + if (fs->pool_threads[i]) { + *(fs->pool_threads[i]->need_gc_pointer) = 0; + *(fs->pool_threads[i]->fuel_pointer) = 1; + *(fs->pool_threads[i]->stack_boundary_pointer) -= INITIAL_C_STACK_SIZE; + } } - pthread_mutex_lock(&gc_ok_m); - wait_for_gc = 0; - pthread_cond_broadcast(&gc_done_c); - pthread_mutex_unlock(&gc_ok_m); + pthread_mutex_lock(&fs->future_mutex); + fs->wait_for_gc = 0; + pthread_cond_broadcast(&fs->gc_done_c); + pthread_mutex_unlock(&fs->future_mutex); } void scheme_future_gc_pause() /* Called in future thread */ { - pthread_mutex_lock(&gc_ok_m); - end_gc_not_ok(current_ft, 0); - start_gc_not_ok(0); /* waits until wait_for_gc is 0 */ - pthread_mutex_unlock(&gc_ok_m); + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + Scheme_Future_State *fs = scheme_future_state; + + pthread_mutex_lock(&fs->future_mutex); + end_gc_not_ok(fts, fs, MZ_RUNSTACK); + start_gc_not_ok(fs); /* waits until wait_for_gc is 0 */ + pthread_mutex_unlock(&fs->future_mutex); } /**********************************************************************/ /* Primitive implementations */ /**********************************************************************/ -#ifdef INSTRUMENT_PRIMITIVES -long start_ms = 0; - -Scheme_Object *start_primitive_tracking(int argc, Scheme_Object *argv[]) -{ - //Get the start time - struct timeval now; - long ms; - gettimeofday(&now, NULL); - - start_ms = now.tv_usec / 1000.0; - - g_print_prims = 1; - printf("Primitive tracking started at "); - print_ms_and_us(); - printf("\n"); - return scheme_void; -} - -Scheme_Object *end_primitive_tracking(int argc, Scheme_Object *argv[]) -{ - g_print_prims = 0; - printf("Primitive tracking ended at "); - print_ms_and_us(); - printf("\n"); - return scheme_void; -} - -void print_ms_and_us() -{ - struct timeval now; - long ms, us; - gettimeofday(&now, NULL); - - //ms = (now.tv_sec * 1000.0) - start_ms; - ms = (now.tv_usec / 1000) - start_ms; - us = now.tv_usec - (ms * 1000) - (start_ms * 1000); - printf("%ld.%ld", ms, us); -} -#endif - Scheme_Object *future(int argc, Scheme_Object *argv[]) /* Called in runtime thread */ { -#ifdef DEBUG_FUTURES - LOG_THISCALL; -#endif - - int init_runstack_size; - int futureid; + Scheme_Future_State *fs = scheme_future_state; + int futureid, count; future_t *ft; Scheme_Native_Closure *nc; Scheme_Native_Closure_Data *ncd; @@ -485,6 +533,16 @@ Scheme_Object *future(int argc, Scheme_Object *argv[]) //Input validation scheme_check_proc_arity("future", 0, 0, argc, argv); + if (fs->future_threads_created < THREAD_POOL_SIZE) { + pthread_mutex_lock(&fs->future_mutex); + count = fs->future_queue_count; + pthread_mutex_unlock(&fs->future_mutex); + if (count >= fs->future_threads_created) { + init_future_thread(fs, fs->future_threads_created); + fs->future_threads_created++; + } + } + nc = (Scheme_Native_Closure*)lambda; ncd = nc->code; @@ -492,100 +550,78 @@ Scheme_Object *future(int argc, Scheme_Object *argv[]) ft = MALLOC_ONE_TAGGED(future_t); ft->so.type = scheme_future_type; - futureid = ++g_next_futureid; + futureid = ++fs->next_futureid; ft->id = futureid; ft->orig_lambda = lambda; ft->status = PENDING; - //Allocate a new scheme stack for the future - //init_runstack_size = MZ_RUNSTACK - MZ_RUNSTACK_START; - init_runstack_size = 1000; - -#ifdef DEBUG_FUTURES - printf("Allocating Scheme stack of %d bytes for future %d.\n", init_runstack_size, futureid); -#endif - - { - Scheme_Object **rs_start, **rs; - rs_start = scheme_alloc_runstack(init_runstack_size); - rs = rs_start XFORM_OK_PLUS init_runstack_size; - ft->runstack_start = rs_start; - ft->runstack = rs; - ft->runstack_size = init_runstack_size; - } - //JIT compile the code if not already jitted //Temporarily repoint MZ_RUNSTACK //to the worker thread's runstack - //in case the JIT compiler uses the stack address //when generating code - if (ncd->code == on_demand_jit_code) + if (ncd->code == scheme_on_demand_jit_code) { scheme_on_demand_generate_lambda(nc, 0, NULL); } ft->code = (void*)ncd->code; - pthread_mutex_lock(&g_future_queue_mutex); - enqueue_future(ft); + pthread_mutex_lock(&fs->future_mutex); + enqueue_future(fs, ft); //Signal that a future is pending - pthread_cond_signal(&g_future_pending_cv); - pthread_mutex_unlock(&g_future_queue_mutex); + pthread_cond_signal(&fs->future_pending_cv); + pthread_mutex_unlock(&fs->future_mutex); return (Scheme_Object*)ft; } -Scheme_Object *num_processors(int argc, Scheme_Object *argv[]) -/* Called in runtime thread */ -{ - return scheme_make_integer(THREAD_POOL_SIZE); -} - - int future_ready(Scheme_Object *obj) /* Called in runtime thread by Scheme scheduler */ { + Scheme_Future_State *fs = scheme_future_state; int ret = 0; future_t *ft = (future_t*)obj; - pthread_mutex_lock(&g_future_queue_mutex); - if (ft->work_completed || ft->rt_prim != NULL) - { - ret = 1; - } - pthread_mutex_unlock(&g_future_queue_mutex); + pthread_mutex_lock(&fs->future_mutex); + if (ft->work_completed || ft->rt_prim) { + ret = 1; + } + pthread_mutex_unlock(&fs->future_mutex); + return ret; } -static void dequeue_future(future_t *ft) +static void dequeue_future(Scheme_Future_State *fs, future_t *ft) + XFORM_SKIP_PROC +/* called from both future and runtime threads */ { if (ft->prev == NULL) - { - //Set next to be the head of the queue - g_future_queue = ft->next; - if (g_future_queue != NULL) - g_future_queue->prev = NULL; - } + fs->future_queue = ft->next; else - { - ft->prev->next = ft->next; - if (NULL != ft->next) - ft->next->prev = ft->prev; - } -} + ft->prev->next = ft->next; + + if (ft->next == NULL) + fs->future_queue_end = ft->prev; + else + ft->next->prev = ft->prev; + ft->next = NULL; + ft->prev = NULL; + + --fs->future_queue_count; +} Scheme_Object *touch(int argc, Scheme_Object *argv[]) /* Called in runtime thread */ { + Scheme_Future_State *fs = scheme_future_state; Scheme_Object *retval = NULL; future_t *ft; if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_future_type)) - { - scheme_wrong_type("touch", "future", 0, argc, argv); - } + scheme_wrong_type("touch", "future", 0, argc, argv); ft = (future_t*)argv[0]; @@ -594,29 +630,32 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[]) dump_state(); #endif - pthread_mutex_lock(&g_future_queue_mutex); + pthread_mutex_lock(&fs->future_mutex); if (ft->status == PENDING) { ft->status = RUNNING; - pthread_mutex_unlock(&g_future_queue_mutex); + pthread_mutex_unlock(&fs->future_mutex); - retval = _scheme_apply(ft->orig_lambda, 0, NULL); + retval = scheme_apply_multi(ft->orig_lambda, 0, NULL); + send_special_result(ft, retval); - pthread_mutex_lock(&g_future_queue_mutex); + pthread_mutex_lock(&fs->future_mutex); ft->work_completed = 1; ft->retval = retval; ft->status = FINISHED; - dequeue_future(ft); - pthread_mutex_unlock(&g_future_queue_mutex); + dequeue_future(fs, ft); + pthread_mutex_unlock(&fs->future_mutex); + + receive_special_result(ft, retval, 0); return retval; } - pthread_mutex_unlock(&g_future_queue_mutex); + pthread_mutex_unlock(&fs->future_mutex); //Spin waiting for primitive calls or a return value from //the worker thread wait_for_rtcall_or_completion: scheme_block_until(future_ready, NULL, (Scheme_Object*)ft, 0); - pthread_mutex_lock(&g_future_queue_mutex); + pthread_mutex_lock(&fs->future_mutex); if (ft->work_completed) { retval = ft->retval; @@ -624,52 +663,97 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[]) LOG("Successfully touched future %d\n", ft->id); // fflush(stdout); - dequeue_future(ft); - - //Increment the number of available pool threads - g_num_avail_threads++; - pthread_mutex_unlock(&g_future_queue_mutex); + pthread_mutex_unlock(&fs->future_mutex); } - else if (ft->rt_prim != NULL) + else if (ft->rt_prim) { //Invoke the primitive and stash the result //Release the lock so other threads can manipulate the queue //while the runtime call executes - pthread_mutex_unlock(&g_future_queue_mutex); + pthread_mutex_unlock(&fs->future_mutex); LOG("Invoking primitive %p on behalf of future %d...", ft->rt_prim, ft->id); - invoke_rtcall(ft); + invoke_rtcall(fs, ft); LOG("done.\n"); goto wait_for_rtcall_or_completion; } else { - pthread_mutex_unlock(&g_future_queue_mutex); + pthread_mutex_unlock(&fs->future_mutex); goto wait_for_rtcall_or_completion; } + if (!retval) { + scheme_signal_error("touch: future previously aborted"); + } + + receive_special_result(ft, retval, 0); + return retval; } +#ifdef linux +#include +#elif OS_X +#include +#include +#elif WINDOWS +#include +#endif + +Scheme_Object *processor_count(int argc, Scheme_Object *argv[]) +/* Called in runtime thread */ +{ + int cpucount = 0; + +#ifdef linux + cpucount = sysconf(_SC_NPROCESSORS_ONLN); +#elif OS_X + size_t size = sizeof(cpucount) ; + + if (sysctlbyname("hw.ncpu", &cpucount, &size, NULL, 0)) + { + cpucount = 1; + } +#elif WINDOWS + SYSTEM_INFO sysinfo; + GetSystemInfo(&sysinfo); + cpucount = sysinfo.dwNumberOfProcessors; +#else + cpucount = THREAD_POOL_SIZE; +#endif + + return scheme_make_integer(cpucount); +} + //Entry point for a worker thread allocated for //executing futures. This function will never terminate //(until the process dies). void *worker_thread_future_loop(void *arg) + XFORM_SKIP_PROC /* Called in future thread; runtime thread is blocked until ready_sema is signaled. */ { - START_XFORM_SKIP; + /* valid only until signaling */ + future_thread_params_t *params = (future_thread_params_t *)arg; + Scheme_Future_Thread_State *fts = params->fts; + Scheme_Future_State *fs = params->fs; Scheme_Object *v; Scheme_Object* (*jitcode)(Scheme_Object*, int, Scheme_Object**); future_t *ft; - int id = *(int *)arg; + mz_jmp_buf newbuf; scheme_init_os_thread(); - GC = g_shared_GC; + scheme_future_state = fs; + scheme_future_thread_state = fts; + + GC = params->shared_GC; + scheme_current_thread = params->thread_skeleton; //Set processor affinity - /*pthread_mutex_lock(&g_future_queue_mutex); + /*pthread_mutex_lock(&fs->future_mutex); + static unsigned long cur_cpu_mask = 1; if (pthread_setaffinity_np(pthread_self(), sizeof(g_cur_cpu_mask), &g_cur_cpu_mask)) { printf( @@ -678,56 +762,54 @@ void *worker_thread_future_loop(void *arg) pthread_self()); } - pthread_mutex_unlock(&g_future_queue_mutex); + pthread_mutex_unlock(&fs->future_mutex); */ - pthread_cond_init(&worker_can_continue_cv, NULL); + pthread_cond_init(&fts->worker_can_continue_cv, NULL); + + scheme_use_rtcall = 1; scheme_fuel_counter = 1; scheme_jit_stack_boundary = ((unsigned long)&v) - INITIAL_C_STACK_SIZE; - g_need_gc_pointers[id] = &scheme_future_need_gc_pause; - g_fuel_pointers[id] = &scheme_fuel_counter; - g_stack_boundary_pointers[id] = &scheme_jit_stack_boundary; + fts->need_gc_pointer = &scheme_future_need_gc_pause; + fts->fuel_pointer = &scheme_fuel_counter; + fts->stack_boundary_pointer = &scheme_jit_stack_boundary; - g_current_ft = ¤t_ft; - g_scheme_current_runstack = &scheme_current_runstack; - g_scheme_current_runstack_start = &scheme_current_runstack_start; - g_jit_future_storage = &jit_future_storage[0]; - sema_signal(&ready_sema); + MZ_RUNSTACK_START = params->runstack_start; + MZ_RUNSTACK = MZ_RUNSTACK_START + fts->runstack_size; + + params->scheme_current_runstack_ptr = &scheme_current_runstack; + params->scheme_current_runstack_start_ptr = &scheme_current_runstack_start; + params->current_thread_ptr = &scheme_current_thread; + params->jit_future_storage_ptr = &jit_future_storage[0]; + + sema_signal(¶ms->ready_sema); wait_for_work: - start_gc_not_ok(1); - pthread_mutex_lock(&g_future_queue_mutex); - while (!(ft = get_pending_future())) - { - end_gc_not_ok(NULL, 1); - pthread_cond_wait(&g_future_pending_cv, &g_future_queue_mutex); - start_gc_not_ok(1); - } + pthread_mutex_lock(&fs->future_mutex); + start_gc_not_ok(fs); + while (!(ft = get_pending_future(fs))) { + end_gc_not_ok(fts, fs, NULL); + pthread_cond_wait(&fs->future_pending_cv, &fs->future_mutex); + start_gc_not_ok(fs); + } LOG("Got a signal that a future is pending..."); //Work is available for this thread ft->status = RUNNING; - pthread_mutex_unlock(&g_future_queue_mutex); + pthread_mutex_unlock(&fs->future_mutex); - ft->threadid = pthread_self(); - - //Decrement the number of available pool threads - g_num_avail_threads--; - - //Initialize the runstack for this thread - //MZ_RUNSTACK AND MZ_RUNSTACK_START should be thread-local - MZ_RUNSTACK = ft->runstack; - MZ_RUNSTACK_START = ft->runstack_start; + ft->threadid = fts->threadid; + ft->thread_short_id = fts->id; //Set up the JIT compiler for this thread scheme_jit_fill_threadlocal_table(); jitcode = (Scheme_Object* (*)(Scheme_Object*, int, Scheme_Object**))(ft->code); - current_ft = ft; + fts->current_ft = ft; //Run the code //Passing no arguments for now. @@ -739,31 +821,44 @@ void *worker_thread_future_loop(void *arg) //If jitcode asks the runrtime thread to do work, then //a GC can occur. LOG("Running JIT code at %p...\n", ft->code); - v = jitcode(ft->orig_lambda, 0, NULL); + + scheme_current_thread->error_buf = &newbuf; + if (scheme_future_setjmp(newbuf)) { + /* failed */ + v = NULL; + } else { + v = jitcode(ft->orig_lambda, 0, NULL); + if (SAME_OBJ(v, SCHEME_TAIL_CALL_WAITING)) { + v = scheme_ts_scheme_force_value_same_mark(v); + } + } + LOG("Finished running JIT code at %p.\n", ft->code); // Get future again, since a GC may have occurred - ft = current_ft; - + ft = fts->current_ft; + //Set the return val in the descriptor - pthread_mutex_lock(&g_future_queue_mutex); + pthread_mutex_lock(&fs->future_mutex); ft->work_completed = 1; ft->retval = v; - ft->runstack = NULL; - ft->runstack_start = NULL; + /* In case of multiple values: */ + send_special_result(ft, v); //Update the status ft->status = FINISHED; - scheme_signal_received_at(g_signal_handle); - pthread_mutex_unlock(&g_future_queue_mutex); + dequeue_future(fs, ft); - end_gc_not_ok(NULL, 1); + scheme_signal_received_at(fs->signal_handle); + + end_gc_not_ok(fts, fs, NULL); + + pthread_mutex_unlock(&fs->future_mutex); goto wait_for_work; return NULL; - END_XFORM_SKIP; } void scheme_check_future_work() @@ -773,337 +868,192 @@ void scheme_check_future_work() and that can be done in any Scheme thread (e.g., get a new page for allocation). */ future_t *ft; + Scheme_Future_State *fs = scheme_future_state; + + if (!fs) return; while (1) { /* Try to get a future waiting on a atomic operation */ - pthread_mutex_lock(&g_future_queue_mutex); - ft = g_future_waiting_atomic; + pthread_mutex_lock(&fs->future_mutex); + ft = fs->future_waiting_atomic; if (ft) { - g_future_waiting_atomic = ft->next_waiting_atomic; + fs->future_waiting_atomic = ft->next_waiting_atomic; + ft->next_waiting_atomic = NULL; + ft->waiting_atomic = 0; } - pthread_mutex_unlock(&g_future_queue_mutex); + pthread_mutex_unlock(&fs->future_mutex); if (ft) { - invoke_rtcall(ft); + if (ft->rt_prim && ft->rt_prim_is_atomic) { + invoke_rtcall(fs, ft); + } } else break; } - } //Returns 0 if the call isn't actually executed by this function, //i.e. if we are already running on the runtime thread. Otherwise returns //1, and 'retval' is set to point to the return value of the runtime //call invocation. -int future_do_runtimecall( - void *func, - int is_atomic, - //int sigtype, - //void *args, - void *retval) +static void future_do_runtimecall(Scheme_Future_Thread_State *fts, + void *func, + int is_atomic) + XFORM_SKIP_PROC /* Called in future thread */ { - START_XFORM_SKIP; future_t *future; - - //If already running on the main thread - //or no future is involved, do nothing - //and return FALSE - if (pthread_self() == g_rt_threadid) - { - //Should never get here! This check should be done - //by the caller using the macros defined in scheme-futures.h! - return 0; - } + Scheme_Future_State *fs = scheme_future_state; //Fetch the future descriptor for this thread - future = current_ft; + future = fts->current_ft; //set up the arguments for the runtime call //to be picked up by the main rt thread - //pthread_mutex_lock(&future->mutex); - pthread_mutex_lock(&g_future_queue_mutex); + pthread_mutex_lock(&fs->future_mutex); - //Update the stack pointer for this future - //to be in sync with MZ_RUNSTACK - the runtime thread - //will use this value to temporarily swap its stack - //for the worker thread's - future->runstack = MZ_RUNSTACK; + future->prim_func = func; future->rt_prim = 1; future->rt_prim_is_atomic = is_atomic; if (is_atomic) { - future->next_waiting_atomic = g_future_waiting_atomic; - g_future_waiting_atomic = future; + if (!future->waiting_atomic) { + future->next_waiting_atomic = fs->future_waiting_atomic; + fs->future_waiting_atomic = future; + future->waiting_atomic = 1; + } } //Update the future's status to waiting future->status = WAITING_FOR_PRIM; - scheme_signal_received_at(g_signal_handle); + scheme_signal_received_at(fs->signal_handle); //Wait for the signal that the RT call is finished - future->can_continue_cv = &worker_can_continue_cv; - end_gc_not_ok(future, 1); - pthread_cond_wait(&worker_can_continue_cv, &g_future_queue_mutex); - start_gc_not_ok(1); + future->can_continue_cv = &fts->worker_can_continue_cv; + while (future->can_continue_cv) { + end_gc_not_ok(fts, fs, MZ_RUNSTACK); + pthread_cond_wait(&fts->worker_can_continue_cv, &fs->future_mutex); + start_gc_not_ok(fs); + //Fetch the future instance again, in case the GC has moved the pointer + future = fts->current_ft; + } - //Fetch the future instance again, in case the GC has moved the pointer - future = current_ft; + pthread_mutex_unlock(&fs->future_mutex); - pthread_mutex_unlock(&g_future_queue_mutex); - - return 1; - END_XFORM_SKIP; + if (future->no_retval) { + future->no_retval = 0; + scheme_future_longjmp(*scheme_current_thread->error_buf, 1); + } } /**********************************************************************/ /* Functions for primitive invocation */ /**********************************************************************/ -int rtcall_void_void_3args(void (*f)()) +void scheme_rtcall_void_void_3args(const char *who, int src_type, prim_void_void_3args_t f) + XFORM_SKIP_PROC /* Called in future thread */ { - START_XFORM_SKIP; - future_t *future; - prim_data_t data; + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + future_t *future = fts->current_ft; - if (!IS_WORKER_THREAD) - { - return 0; - } + future->prim_protocol = SIG_VOID_VOID_3ARGS; - memset(&data, 0, sizeof(prim_data_t)); - data.void_void_3args = f; - data.sigtype = SIG_VOID_VOID_3ARGS; + future->arg_S0 = MZ_RUNSTACK; - future = current_ft; - future->prim_data = data; + future->time_of_request = scheme_get_inexact_milliseconds(); + future->source_of_request = who; + future->source_type = src_type; - future_do_runtimecall((void*)f, 1, NULL); - future = current_ft; + future_do_runtimecall(fts, (void*)f, 1); - return 1; - END_XFORM_SKIP; + future->arg_S0 = NULL; } - -int rtcall_alloc_void_pvoid(void (*f)(), void **retval) +unsigned long scheme_rtcall_alloc_void_pvoid(const char *who, int src_type, prim_alloc_void_pvoid_t f) + XFORM_SKIP_PROC /* Called in future thread */ { - START_XFORM_SKIP; future_t *future; - prim_data_t data; - - if (!IS_WORKER_THREAD) - { - return 0; - } + unsigned long retval; + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + Scheme_Future_State *fs = scheme_future_state; while (1) { - memset(&data, 0, sizeof(prim_data_t)); + future = fts->current_ft; + future->time_of_request = 0; /* takes too long?: scheme_get_inexact_milliseconds(); */ + future->source_of_request = who; + future->source_type = src_type; + + future->prim_protocol = SIG_ALLOC_VOID_PVOID; - data.alloc_void_pvoid = f; - data.sigtype = SIG_ALLOC_VOID_PVOID; + future_do_runtimecall(fts, (void*)f, 1); - future = current_ft; - future->prim_data = data; + future = fts->current_ft; + retval = future->alloc_retval; + future->alloc_retval = 0; - future_do_runtimecall((void*)f, 1, NULL); - future = current_ft; - - *retval = future->alloc_retval; - future->alloc_retval = NULL; - - if (*gc_counter_ptr == future->alloc_retval_counter) + if (*fs->gc_counter_ptr == future->alloc_retval_counter) break; } - return 1; - END_XFORM_SKIP; + return retval; } - -int rtcall_obj_int_pobj_obj( - prim_obj_int_pobj_obj_t f, - Scheme_Object *rator, - int argc, - Scheme_Object **argv, - Scheme_Object **retval) -/* Called in future thread */ +static void receive_special_result(future_t *f, Scheme_Object *retval, int clear) + XFORM_SKIP_PROC +/* Called in future or runtime thread */ { - START_XFORM_SKIP; - future_t *future; - prim_data_t data; - if (!IS_WORKER_THREAD) - { - return 0; + if (SAME_OBJ(retval, SCHEME_MULTIPLE_VALUES)) { + Scheme_Thread *p = scheme_current_thread; + + p->ku.multiple.array = f->multiple_array; + p->ku.multiple.count = f->multiple_count; + if (clear) + f->multiple_array = NULL; + } else if (SAME_OBJ(retval, SCHEME_TAIL_CALL_WAITING)) { + Scheme_Thread *p = scheme_current_thread; + + p->ku.apply.tail_rator = f->tail_rator; + p->ku.apply.tail_rands = f->tail_rands; + p->ku.apply.tail_num_rands = f->num_tail_rands; + if (clear) { + f->tail_rator = NULL; + f->tail_rands = NULL; } - - memset(&data, 0, sizeof(prim_data_t)); - -#ifdef DEBUG_FUTURES - printf("scheme_fuel_counter = %d\n", scheme_fuel_counter); - printf("scheme_jit_stack_boundary = %p\n", (void*)scheme_jit_stack_boundary); - printf("scheme_current_runstack = %p\n", scheme_current_runstack); - printf("scheme_current_runstack_start = %p\n", scheme_current_runstack_start); - printf("stack address = %p\n", &future); -#endif - - data.obj_int_pobj_obj = f; - data.p = rator; - data.argc = argc; - data.argv = argv; - data.sigtype = SIG_OBJ_INT_POBJ_OBJ; - - future = current_ft; - future->prim_data = data; - - future_do_runtimecall((void*)f, 0, NULL); - future = current_ft; - *retval = future->prim_data.retval; - future->prim_data.retval = NULL; - - return 1; - END_XFORM_SKIP; + } } +#include "jit_ts_future_glue.c" -int rtcall_int_pobj_obj( - prim_int_pobj_obj_t f, - int argc, - Scheme_Object **argv, - Scheme_Object **retval) -/* Called in future thread */ +static void send_special_result(future_t *f, Scheme_Object *retval) + XFORM_SKIP_PROC +/* Called in future or runtime thread */ { - START_XFORM_SKIP; - future_t *future; - prim_data_t data; - if (!IS_WORKER_THREAD) - { - return 0; - } + if (SAME_OBJ(retval, SCHEME_MULTIPLE_VALUES)) { + Scheme_Thread *p = scheme_current_thread; - memset(&data, 0, sizeof(prim_data_t)); + f->multiple_array = p->ku.multiple.array; + f->multiple_count = p->ku.multiple.count; + if (SAME_OBJ(p->ku.multiple.array, p->values_buffer)) + p->values_buffer = NULL; + p->ku.multiple.array = NULL; + } else if (SAME_OBJ(retval, SCHEME_TAIL_CALL_WAITING)) { + Scheme_Thread *p = scheme_current_thread; -#ifdef DEBUG_FUTURES - printf("scheme_fuel_counter = %d\n", scheme_fuel_counter); - printf("scheme_jit_stack_boundary = %p\n", (void*)scheme_jit_stack_boundary); - printf("scheme_current_runstack = %p\n", scheme_current_runstack); - printf("scheme_current_runstack_start = %p\n", scheme_current_runstack_start); - printf("stack address = %p\n", &future); -#endif - - data.int_pobj_obj = f; - data.argc = argc; - data.argv = argv; - data.sigtype = SIG_INT_OBJARR_OBJ; - - future = current_ft; - future->prim_data = data; - - future_do_runtimecall((void*)f, 0, NULL); - future = current_ft; - *retval = future->prim_data.retval; - future->prim_data.retval = NULL; - - return 1; - END_XFORM_SKIP; -} - - -int rtcall_pvoid_pvoid_pvoid( - prim_pvoid_pvoid_pvoid_t f, - void *a, - void *b, - void **retval) -/* Called in future thread */ -{ - START_XFORM_SKIP; - future_t *future; - prim_data_t data; - - if (!IS_WORKER_THREAD) - { - return 0; - } - - memset(&data, 0, sizeof(prim_data_t)); - -#ifdef DEBUG_FUTURES - printf("scheme_fuel_counter = %d\n", scheme_fuel_counter); - printf("scheme_jit_stack_boundary = %p\n", (void*)scheme_jit_stack_boundary); - printf("scheme_current_runstack = %p\n", scheme_current_runstack); - printf("scheme_current_runstack_start = %p\n", scheme_current_runstack_start); - printf("stack address = %p\n", &future); -#endif - - data.pvoid_pvoid_pvoid = f; - data.a = a; - data.b = b; - data.sigtype = SIG_PVOID_PVOID_PVOID; - - future = current_ft; - future->prim_data = data; - - future_do_runtimecall((void*)f, 0, NULL); - future = current_ft; - *retval = future->prim_data.c; - - return 1; - END_XFORM_SKIP; -} - - -int rtcall_int_pobj_obj_obj( - prim_int_pobj_obj_obj_t f, - int argc, - Scheme_Object **argv, - Scheme_Object *p, - Scheme_Object **retval) -/* Called in future thread */ -{ - START_XFORM_SKIP; - future_t *future; - prim_data_t data; - - if (!IS_WORKER_THREAD) - { - return 0; - } - - memset(&data, 0, sizeof(prim_data_t)); - -#ifdef DEBUG_FUTURES - printf("scheme_fuel_counter = %d\n", scheme_fuel_counter); - printf("scheme_jit_stack_boundary = %p\n", (void*)scheme_jit_stack_boundary); - printf("scheme_current_runstack = %p\n", scheme_current_runstack); - printf("scheme_current_runstack_start = %p\n", scheme_current_runstack_start); - printf("stack address = %p\n", &future); -#endif - - data.int_pobj_obj_obj = f; - data.argc = argc; - data.argv = argv; - data.p = p; - data.sigtype = SIG_INT_POBJ_OBJ_OBJ; - - future = current_ft; - future->prim_data = data; - - future_do_runtimecall((void*)f, 0, NULL); - future = current_ft; - *retval = future->prim_data.retval; - future->prim_data.retval = NULL; - - return 1; - END_XFORM_SKIP; + f->tail_rator = p->ku.apply.tail_rator; + f->tail_rands = p->ku.apply.tail_rands; + f->num_tail_rands = p->ku.apply.tail_num_rands; + p->ku.apply.tail_rator = NULL; + p->ku.apply.tail_rands = NULL; + } } //Does the work of actually invoking a primitive on behalf of a //future. This function is always invoked on the main (runtime) //thread. -void invoke_rtcall(future_t *future) +static void do_invoke_rtcall(Scheme_Future_State *fs, future_t *future) /* Called in runtime thread */ { #ifdef DEBUG_FUTURES @@ -1112,97 +1062,108 @@ void invoke_rtcall(future_t *future) future->rt_prim = 0; - switch (future->prim_data.sigtype) + if (scheme_log_level_p(scheme_main_logger, SCHEME_LOG_DEBUG)) { + const char *src; + + src = future->source_of_request; + if (future->source_type == FSRC_RATOR) { + int len; + if (SCHEME_PROCP(future->arg_s0)) { + const char *src2; + src2 = scheme_get_proc_name(future->arg_s0, &len, 1); + if (src2) src = src2; + } + } else if (future->source_type == FSRC_PRIM) { + const char *src2; + src2 = scheme_look_for_primitive(future->prim_func); + if (src2) src = src2; + } + + scheme_log(scheme_main_logger, SCHEME_LOG_DEBUG, 0, + "future: %d waiting for runtime at %f: %s", + (long)future->thread_short_id, + future->time_of_request, + src); + } + + switch (future->prim_protocol) { case SIG_VOID_VOID_3ARGS: { - prim_void_void_3args_t func = future->prim_data.void_void_3args; + prim_void_void_3args_t func = (prim_void_void_3args_t)future->prim_func; - func(future->runstack); + func(future->arg_S0); break; } case SIG_ALLOC_VOID_PVOID: { - void *ret; - prim_alloc_void_pvoid_t func = future->prim_data.alloc_void_pvoid; + unsigned long ret; + prim_alloc_void_pvoid_t func = (prim_alloc_void_pvoid_t)future->prim_func; ret = func(); future->alloc_retval = ret; - ret = NULL; future->alloc_retval_counter = scheme_did_gc_count; break; } - case SIG_OBJ_INT_POBJ_OBJ: - { - Scheme_Object *ret; - prim_obj_int_pobj_obj_t func = future->prim_data.obj_int_pobj_obj; - ret = func( - future->prim_data.p, - future->prim_data.argc, - future->prim_data.argv); - - future->prim_data.retval = ret; - - /*future->prim_data.retval = future->prim_data.prim_obj_int_pobj_obj( - future->prim_data.p, - future->prim_data.argc, - future->prim_data.argv); */ - - break; - } - case SIG_INT_OBJARR_OBJ: - { - Scheme_Object *ret; - prim_int_pobj_obj_t func = future->prim_data.int_pobj_obj; - ret = func( - future->prim_data.argc, - future->prim_data.argv); - - future->prim_data.retval = ret; - - /*future->prim_data.retval = future->prim_data.prim_int_pobj_obj( - future->prim_data.argc, - future->prim_data.argv); - */ - break; - } - case SIG_INT_POBJ_OBJ_OBJ: - { - Scheme_Object *ret; - prim_int_pobj_obj_obj_t func = future->prim_data.int_pobj_obj_obj; - ret = func( - future->prim_data.argc, - future->prim_data.argv, - future->prim_data.p); - - future->prim_data.retval = ret; - /*future->prim_data.retval = future->prim_data.prim_int_pobj_obj_obj( - future->prim_data.argc, - future->prim_data.argv, - future->prim_data.p); - */ - break; - } - case SIG_PVOID_PVOID_PVOID: - { - void *pret = NULL; - prim_pvoid_pvoid_pvoid_t func = future->prim_data.pvoid_pvoid_pvoid; - pret = func(future->prim_data.a, future->prim_data.b); - - future->prim_data.c = pret; - /*future->prim_data.c = future->prim_data.prim_pvoid_pvoid_pvoid( - future->prim_data.a, - future->prim_data.b); - */ - break; - } +# include "jit_ts_runtime_glue.c" + default: + scheme_signal_error("unknown protocol %d", future->prim_protocol); + break; } - pthread_mutex_lock(&g_future_queue_mutex); + pthread_mutex_lock(&fs->future_mutex); //Signal the waiting worker thread that it //can continue running machine code - pthread_cond_signal(future->can_continue_cv); - pthread_mutex_unlock(&g_future_queue_mutex); + if (future->can_continue_cv) { + pthread_cond_signal(future->can_continue_cv); + future->can_continue_cv= NULL; + } + pthread_mutex_unlock(&fs->future_mutex); +} + +static void *do_invoke_rtcall_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Future_State *fs = (Scheme_Future_State *)p->ku.k.p1; + future_t *future = (future_t *)p->ku.k.p2; + + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; + + do_invoke_rtcall(fs, future); + + return scheme_void; +} + +static void invoke_rtcall(Scheme_Future_State * volatile fs, future_t * volatile future) +{ + Scheme_Thread *p = scheme_current_thread; + mz_jmp_buf newbuf, * volatile savebuf; + + savebuf = p->error_buf; + p->error_buf = &newbuf; + if (scheme_setjmp(newbuf)) { + pthread_mutex_lock(&fs->future_mutex); + future->no_retval = 1; + future->work_completed = 1; + //Signal the waiting worker thread that it + //can continue running machine code + pthread_cond_signal(future->can_continue_cv); + future->can_continue_cv = NULL; + pthread_mutex_unlock(&fs->future_mutex); + scheme_longjmp(*savebuf, 1); + } else { + if (future->rt_prim_is_atomic) { + do_invoke_rtcall(fs, future); + } else { + /* call with continuation barrier. */ + p->ku.k.p1 = fs; + p->ku.k.p2 = future; + + (void)scheme_top_level_do(do_invoke_rtcall_k, 1); + } + } + p->error_buf = savebuf; } @@ -1210,88 +1171,36 @@ void invoke_rtcall(future_t *future) /* Helpers for manipulating the futures queue */ /**********************************************************************/ -future_t *enqueue_future(future_t *ft) +future_t *enqueue_future(Scheme_Future_State *fs, future_t *ft) /* Called in runtime thread */ { - future_t *last; - last = get_last_future(); - if (NULL == last) - { - g_future_queue = ft; - return ft; - } - - ft->prev = last; - last->next = ft; - ft->next = NULL; + if (fs->future_queue_end) { + fs->future_queue_end->next = ft; + ft->prev = fs->future_queue_end; + } + fs->future_queue_end = ft; + if (!fs->future_queue) + fs->future_queue = ft; + fs->future_queue_count++; return ft; } - -future_t *get_pending_future(void) +future_t *get_pending_future(Scheme_Future_State *fs) + XFORM_SKIP_PROC /* Called in future thread */ { - START_XFORM_SKIP; future_t *f; - for (f = g_future_queue; f != NULL; f = f->next) - { - if (f->status == PENDING) - return f; - } + + for (f = fs->future_queue; f != NULL; f = f->next) { + if (f->status == PENDING) + return f; + } return NULL; - END_XFORM_SKIP; } -future_t *get_last_future(void) -/* Called in runtime thread */ -{ - future_t *ft = g_future_queue; - if (NULL == ft) - { - return ft; - } - - while (ft->next != NULL) - { - ft = ft->next; - } - - return ft; -} - - -void clear_futures(void) -{ - int i; - future_t *f, *tmp; - pthread_mutex_lock(&g_future_queue_mutex); - for (i = 0; i < THREAD_POOL_SIZE; i++) - { - pthread_cancel(g_pool_threads[i]); - } - - pthread_mutex_unlock(&g_future_queue_mutex); - f = get_last_future(); - if (NULL == f) - return; - - while (1) - { - tmp = f->prev; - free(f); - if (tmp == NULL) - { - break; - } - - tmp->next = NULL; - f = tmp; - } - - g_future_queue = NULL; -} +#endif /**********************************************************************/ /* Precise GC */ @@ -1306,11 +1215,13 @@ START_XFORM_SKIP; static void register_traversers(void) { +#ifdef FUTURES_ENABLED GC_REG_TRAV(scheme_future_type, future); +#else + GC_REG_TRAV(scheme_future_type, sequential_future); +#endif } END_XFORM_SKIP; #endif - -#endif diff --git a/src/mzscheme/src/future.h b/src/mzscheme/src/future.h index 69d03ae6b5..a2c8eee44e 100644 --- a/src/mzscheme/src/future.h +++ b/src/mzscheme/src/future.h @@ -23,143 +23,92 @@ int scheme_make_prim_w_arity(prim_t func, char *name, int arg1, int arg2); #include "pthread.h" #include -extern pthread_t g_rt_threadid; -extern Scheme_Object *start_primitive_tracking(int argc, Scheme_Object *argv[]); -extern Scheme_Object *end_primitive_tracking(int argc, Scheme_Object *argv[]); -extern Scheme_Object *future(int argc, Scheme_Object *argv[]); -extern Scheme_Object *touch(int argc, Scheme_Object *argv[]); -extern Scheme_Object *num_processors(int argc, Scheme_Object *argv[]); -extern void futures_init(void); - typedef void (*prim_void_void_3args_t)(Scheme_Object **); -typedef void *(*prim_alloc_void_pvoid_t)(void); +typedef unsigned long (*prim_alloc_void_pvoid_t)(); typedef Scheme_Object* (*prim_obj_int_pobj_obj_t)(Scheme_Object*, int, Scheme_Object**); typedef Scheme_Object* (*prim_int_pobj_obj_t)(int, Scheme_Object**); typedef Scheme_Object* (*prim_int_pobj_obj_obj_t)(int, Scheme_Object**, Scheme_Object*); typedef void* (*prim_pvoid_pvoid_pvoid_t)(void*, void*); -typedef struct { - unsigned int sigtype; - - prim_void_void_3args_t void_void_3args; - prim_alloc_void_pvoid_t alloc_void_pvoid; - prim_obj_int_pobj_obj_t obj_int_pobj_obj; - prim_int_pobj_obj_t int_pobj_obj; - prim_int_pobj_obj_obj_t int_pobj_obj_obj; - prim_pvoid_pvoid_pvoid_t pvoid_pvoid_pvoid; - - //Scheme_Object* (*prim_obj_int_pobj_obj)(Scheme_Object* rator, int argc, Scheme_Object** argv); - //Scheme_Object* (*prim_int_pobj_obj)(int argc, Scheme_Object** argv); - //Scheme_Object* (*prim_int_pobj_obj_obj)(int argc, Scheme_Object** argv, Scheme_Object* p); - //void (*prim_void_void)(void); - //void* (*prim_pvoid_pvoid_pvoid)(void *a, void *b); - - Scheme_Object *p; - int argc; - Scheme_Object **argv; - Scheme_Object *retval; - - void *a; - void *b; - void *c; - -} prim_data_t; - #define PENDING 0 #define RUNNING 1 #define WAITING_FOR_PRIM 2 #define FINISHED 3 -typedef struct future { +#define FSRC_OTHER 0 +#define FSRC_RATOR 1 +#define FSRC_PRIM 2 + +typedef struct future_t { Scheme_Object so; int id; pthread_t threadid; + int thread_short_id; int status; int work_completed; pthread_cond_t *can_continue_cv; - long runstack_size; - Scheme_Object **runstack; - Scheme_Object **runstack_start; Scheme_Object *orig_lambda; void *code; //Runtime call stuff int rt_prim; /* flag to indicate waiting for a prim call */ int rt_prim_is_atomic; + double time_of_request; + const char *source_of_request; + int source_type; - prim_data_t prim_data; - void *alloc_retval; + unsigned long alloc_retval; int alloc_retval_counter; + void *prim_func; + int prim_protocol; + Scheme_Object *arg_s0; + Scheme_Object **arg_S0; + Scheme_Bucket *arg_b0; + int arg_i0; + long arg_l0; + size_t arg_z0; + Scheme_Native_Closure_Data *arg_n0; + Scheme_Object *arg_s1; + Scheme_Object **arg_S1; + int arg_i1; + long arg_l1; + Scheme_Object *arg_s2; + Scheme_Object **arg_S2; + int arg_i2; + + Scheme_Object *retval_s; + void *retval_p; /* use only with conservative GC */ + MZ_MARK_STACK_TYPE retval_m; + int no_retval; + + Scheme_Object **multiple_array; + int multiple_count; + + Scheme_Object *tail_rator; + Scheme_Object **tail_rands; + int num_tail_rands; + Scheme_Object *retval; - struct future *prev; - struct future *next; - struct future *next_waiting_atomic; + struct future_t *prev; + struct future_t *next; + + int waiting_atomic; + struct future_t *next_waiting_atomic; } future_t; -#ifdef UNIT_TEST -//If unit testing, expose internal functions and vars to -//the test suite -extern future_t *g_future_queue; -extern int g_next_futureid; -extern pthread_t g_rt_threadid; - -extern void *worker_thread_future_loop(void *arg); -extern void *invoke_rtcall(future_t *future); -extern future_t *enqueue_future(void); -extern future_t *get_pending_future(void); -extern future_t *get_my_future(void); -extern future_t *get_future_by_threadid(pthread_t threadid); -extern future_t *get_future(int futureid); -extern future_t *get_last_future(void); -extern void clear_futures(void); -#endif - //Primitive instrumentation stuff -#ifdef INSTRUMENT_PRIMITIVES -extern int g_print_prims; -extern void print_ms_and_us(void); -#define LOG_PRIM_START(p) \ - if (g_print_prims) \ - { \ - printf("%p ", p); \ - print_ms_and_us(); \ - printf("\n"); \ - } - -#define LOG_PRIM_END(p) -/* -#define LOG_PRIM_END(p) \ - if (g_print_prims) \ - { \ - print_ms_and_us(); \ - printf("\n"); \ - } -*/ - -#define LOG_PRIM_W_NAME(name) \ - if (g_print_prims) \ - { \ - printf("%s ", name); \ - print_ms_and_us(); \ - printf("\n"); \ - } -#else -#define LOG_PRIM_START(p) -#define LOG_PRIM_END(p) -#define LOG_PRIM_W_NAME(name) -#endif //Signature flags for primitive invocations //Here the convention is SIG_[arg1type]_[arg2type]..._[return type] #define SIG_VOID_VOID_3ARGS 1 //void -> void, copy 3 args from runstack #define SIG_ALLOC_VOID_PVOID 2 //void -> void* -#define SIG_OBJ_INT_POBJ_OBJ 3 //Scheme_Object* -> int -> Scheme_Object** -> Scheme_Object* -#define SIG_INT_OBJARR_OBJ 4 //int -> Scheme_Object*[] -> Scheme_Object -#define SIG_INT_POBJ_OBJ_OBJ 17 //int -> Scheme_Object** -> Scheme_Object* -> Scheme_Object* -#define SIG_PVOID_PVOID_PVOID 18 //void* -> void* -> void* + +# include "jit_ts_protos.h" + +extern Scheme_Object *scheme_ts_scheme_force_value_same_mark(Scheme_Object *v); //Helper macros for argument marshaling #ifdef FUTURES_ENABLED @@ -171,20 +120,8 @@ extern void print_ms_and_us(void); /*GDB_BREAK;*/ \ } -extern int rtcall_void_void_3args(void (*f)()); -extern int rtcall_alloc_void_pvoid(void (*f)(), void **retval); -extern int rtcall_obj_int_pobj_obj( - Scheme_Object* (*f)(Scheme_Object*, int, Scheme_Object**), - Scheme_Object *a, - int b, - Scheme_Object **c, - Scheme_Object **retval); - -extern int rtcall_int_pobj_obj( - Scheme_Object* (*f)(int, Scheme_Object**), - int argc, - Scheme_Object **argv, - Scheme_Object **retval); +extern void scheme_rtcall_void_void_3args(const char *who, int src_type, prim_void_void_3args_t f); +extern unsigned long scheme_rtcall_alloc_void_pvoid(const char *who, int src_type, prim_alloc_void_pvoid_t f); #else @@ -241,6 +178,9 @@ extern int rtcall_int_pobj_obj( #define LOG_RTCALL_ENV_ENV_VOID(a,b) #endif +extern void *scheme_on_demand_jit_code; +extern void scheme_on_demand_generate_lambda(Scheme_Native_Closure *nc, int argc, Scheme_Object **argv); + void scheme_future_block_until_gc(); void scheme_future_continue_after_gc(); void scheme_check_future_work(); diff --git a/src/mzscheme/src/gen-jit-ts.ss b/src/mzscheme/src/gen-jit-ts.ss new file mode 100644 index 0000000000..63d896d2fe --- /dev/null +++ b/src/mzscheme/src/gen-jit-ts.ss @@ -0,0 +1,178 @@ +#lang at-exp scheme/base +(require scheme/string) + +(define (char->type c) + (case c + [(#\s) "Scheme_Object*"] + [(#\S) "Scheme_Object**"] + [(#\b) "Scheme_Bucket*"] + [(#\n) "Scheme_Native_Closure_Data*"] + [(#\m) "MZ_MARK_STACK_TYPE"] + [(#\p) "void*"] + [(#\i) "int"] + [(#\l) "long"] + [(#\z) "size_t"] + [(#\v) "void"] + [else (error 'char->type "unknown: ~e" c)])) + +(define (type->arg-string t) + (let* ([t (symbol->string t)]) + (substring t 0 (- (string-length t) 2)))) + +(define (parse-type t) + (let* ([s (symbol->string t)]) + (values + (for/list ([c (in-string (type->arg-string t))]) + (char->type c)) + (char->type (string-ref s (sub1 (string-length s))))))) + +(define (make-arg-list arg-types arg-names) + (string-join (map (lambda (t a) + (string-append t " " a)) + arg-types arg-names) + ", ")) + +(define (gen-definer t) + (define-values (arg-types result-type) (parse-type t)) + (define arg-names (map symbol->string (map (lambda (v) (gensym)) arg-types))) + (define return (if (equal? result-type "void") "" "return")) + (define args (make-arg-list arg-types arg-names)) + (define ts (symbol->string t)) + (for-each display + @list{#define define_ts_@|ts|(id, src_type) \ + static @|result-type| ts_ ## id(@|args|) \ + XFORM_SKIP_PROC \ + { \ + if (scheme_use_rtcall) \ + @|return| scheme_rtcall_@|t|("[" #id "]", src_type, id, @(string-join arg-names ", ")); \ + else \ + @|return| id(@(string-join arg-names ", ")); \ + }}) + (newline)) + +(define (gen-future-side t) + (define-values (arg-types result-type) (parse-type t)) + (define arg-names (map symbol->string (map (lambda (v) (gensym)) arg-types))) + (define return (if (equal? result-type "void") "" "return")) + (define args (make-arg-list arg-types arg-names)) + (define ts (symbol->string t)) + (define fretval @string-append{future->retval_@|(substring ts (sub1 (string-length ts)))|}) + (for-each + display + @list{ + @|result-type| scheme_rtcall_@|ts|(const char *who, int src_type, prim_@|ts| f@|(if (null? arg-types) "" ",")| @|args|) + XFORM_SKIP_PROC + { + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + future_t *future; + double tm; + @(if (string=? result-type "void") "" @string-append{@|result-type| retval;}) + + future = fts->current_ft; + future->prim_protocol = SIG_@|ts|; + future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; + @(string-join + (for/list ([t (in-string (type->arg-string t))] + [a arg-names] + [i (in-naturals)]) + @string-append{ future->arg_@|(string t)|@|(number->string i)| = @|a|;}) + "\n") + @(if (equal? arg-types '("Scheme_Object*")) @string-append{send_special_result(future, @(car arg-names));} "") + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; + @(if (string=? result-type "void") "" @string-append{retval = @|fretval|;}) + @(if (string=? result-type "void") "" @string-append{@|fretval| = 0;}) + @(if (string=? result-type "Scheme_Object*") @string-append{receive_special_result(future, retval, 1);} "") + @(if (string=? result-type "void") "" "return retval;") + } + }) + (newline)) + +(define (gen-runtime-side t) + (define-values (arg-types result-type) (parse-type t)) + (define arg-names (map symbol->string (map (lambda (v) (gensym)) arg-types))) + (define return (if (equal? result-type "void") "" "return")) + (define args (make-arg-list arg-types arg-names)) + (define ts (symbol->string t)) + (for-each + display + @list{ + case SIG_@|ts|: + { + prim_@|ts| f = (prim_@|ts|)future->prim_func; + @(if (string=? result-type "void") "" @string-append{@|result-type| retval;}) + @(if (equal? arg-types '("Scheme_Object*")) @string-append{receive_special_result(future, future->arg_s0, 1);} "") + @(if (string=? result-type "void") "" "retval = ") + f(@(string-join + (for/list ([t (in-string (type->arg-string t))] + [i (in-naturals)]) + @string-append{future->arg_@|(string t)|@|(number->string i)|}) + ", ")); + @(if (string=? result-type "void") "" @string-append{future->retval_@(substring ts (sub1 (string-length ts))) = retval;}) + @(if (string=? result-type "Scheme_Object*") @string-append{send_special_result(future, retval);} "") + break; + } + }) + (newline)) + +(define proto-counter 5) + +(define (gen-protos t) + (define-values (arg-types result-type) (parse-type t)) + (define arg-names (map symbol->string (map (lambda (v) (gensym)) arg-types))) + (define return (if (equal? result-type "void") "" "return")) + (define args (make-arg-list arg-types arg-names)) + (define ts (symbol->string t)) + (printf "#define SIG_~a ~a\n" t proto-counter) + (set! proto-counter (add1 proto-counter)) + (display + @string-append{typedef @|result-type| (*prim_@|ts|)(@(string-join arg-types ", "));}) + (newline) + (display @string-append{@|result-type| scheme_rtcall_@|ts|(const char *who, int src_type, prim_@|ts| f@(if (null? arg-types) "" ",") @|args|);}) + (newline)) + +(define types + '(siS_s + iSs_s + s_s + n_s + _s + ss_s + ss_m + Sl_s + l_s + bsi_v + iiS_v + ss_v + b_v + sl_s + iS_s + S_s + s_v + iSi_s + siS_v + z_p)) + +(with-output-to-file "jit_ts_def.c" + #:exists 'replace + (lambda () + (for-each gen-definer types))) + +(with-output-to-file "jit_ts_future_glue.c" + #:exists 'replace + (lambda () + (for-each gen-future-side types))) + +(with-output-to-file "jit_ts_runtime_glue.c" + #:exists 'replace + (lambda () + (for-each gen-runtime-side types))) + +(with-output-to-file "jit_ts_protos.h" + #:exists 'replace + (lambda () + (for-each gen-protos types))) diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 03afa3dea5..95859ffeb2 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -39,6 +39,7 @@ argument, etc. */ + #include "schpriv.h" #include "schmach.h" #ifdef FUTURES_ENABLED @@ -143,7 +144,7 @@ static void *vector_ref_code, *vector_ref_check_index_code, *vector_set_code, *v static void *string_ref_code, *string_ref_check_index_code, *string_set_code, *string_set_check_index_code; static void *bytes_ref_code, *bytes_ref_check_index_code, *bytes_set_code, *bytes_set_check_index_code; static void *syntax_e_code; -void *on_demand_jit_code; +void *scheme_on_demand_jit_code; static void *on_demand_jit_arity_code; static void *get_stack_pointer_code; static void *stack_cache_pop_code; @@ -295,14 +296,9 @@ void scheme_jit_fill_threadlocal_table(); # define tl_scheme_jit_stack_boundary tl_delta(scheme_jit_stack_boundary) # define tl_jit_future_storage tl_delta(jit_future_storage) # define tl_scheme_future_need_gc_pause tl_delta(scheme_future_need_gc_pause) +# define tl_scheme_use_rtcall tl_delta(scheme_use_rtcall) -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif -static void *get_threadlocal_table() { return &BOTTOM_VARIABLE; } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif +static void *get_threadlocal_table() XFORM_SKIP_PROC { return &BOTTOM_VARIABLE; } # ifdef JIT_X86_64 # define JIT_R10 JIT_R(10) @@ -311,17 +307,34 @@ END_XFORM_SKIP; # define mz_tl_addr_tmp(tmp_reg, addr) (mz_tl_addr(JIT_R10, addr)) # define mz_tl_addr_untmp(tmp_reg) (void)0 # define mz_tl_tmp_reg(tmp_reg) JIT_R10 +# define _mz_tl_str_p(addr, tmp_reg, reg) jit_str_p(tmp_reg, reg) +# define _mz_tl_str_l(addr, tmp_reg, reg) jit_str_l(tmp_reg, reg) +# define _mz_tl_str_i(addr, tmp_reg, reg) jit_str_i(tmp_reg, reg) # else -# define mz_tl_addr(reg, addr) (mz_get_local_p(reg, JIT_LOCAL4), jit_addi_p(reg, reg, addr)) -# define mz_tl_addr_tmp(tmp_reg, addr) (PUSHQr(tmp_reg), mz_tl_addr(tmp_reg, addr)) -# define mz_tl_addr_untmp(tmp_reg) POPQr(tmp_reg) -# define mz_tl_tmp_reg(tmp_reg) tmp_reg +# define THREAD_LOCAL_USES_JIT_V2 +# ifdef THREAD_LOCAL_USES_JIT_V2 +# define mz_tl_addr(reg, addr) (jit_addi_p(reg, JIT_V2, addr)) +# define mz_tl_addr_tmp(tmp_reg, addr) (void)0 +# define mz_tl_addr_untmp(tmp_reg) 0 +# define mz_tl_tmp_reg(tmp_reg) (void)0 +# define _mz_tl_str_p(addr, tmp_reg, reg) jit_stxi_p(addr, JIT_V2, reg) +# define _mz_tl_str_l(addr, tmp_reg, reg) jit_stxi_l(addr, JIT_V2, reg) +# define _mz_tl_str_i(addr, tmp_reg, reg) jit_stxi_i(addr, JIT_V2, reg) +# else +# define mz_tl_addr(reg, addr) (mz_get_local_p(reg, JIT_LOCAL4), jit_addi_p(reg, reg, addr)) +# define mz_tl_addr_tmp(tmp_reg, addr) (PUSHQr(tmp_reg), mz_tl_addr(tmp_reg, addr)) +# define mz_tl_addr_untmp(tmp_reg) POPQr(tmp_reg) +# define mz_tl_tmp_reg(tmp_reg) tmp_reg +# define _mz_tl_str_p(addr, tmp_reg, reg) jit_str_p(tmp_reg, reg) +# define _mz_tl_str_l(addr, tmp_reg, reg) jit_str_l(tmp_reg, reg) +# define _mz_tl_str_i(addr, tmp_reg, reg) jit_str_i(tmp_reg, reg) +# endif # endif /* A given tmp_reg doesn't have to be unused; it just has to be distinct from other arguments. */ -# define mz_tl_sti_p(addr, reg, tmp_reg) (mz_tl_addr_tmp(tmp_reg, addr), jit_str_p(mz_tl_tmp_reg(tmp_reg), reg), mz_tl_addr_untmp(tmp_reg)) -# define mz_tl_sti_l(addr, reg, tmp_reg) (mz_tl_addr_tmp(tmp_reg, addr), jit_str_l(mz_tl_tmp_reg(tmp_reg), reg), mz_tl_addr_untmp(tmp_reg)) -# define mz_tl_sti_i(addr, reg, tmp_reg) (mz_tl_addr_tmp(tmp_reg, addr), jit_str_i(mz_tl_tmp_reg(tmp_reg), reg), mz_tl_addr_untmp(tmp_reg)) +# define mz_tl_sti_p(addr, reg, tmp_reg) (mz_tl_addr_tmp(tmp_reg, addr), _mz_tl_str_p(addr, mz_tl_tmp_reg(tmp_reg), reg), mz_tl_addr_untmp(tmp_reg)) +# define mz_tl_sti_l(addr, reg, tmp_reg) (mz_tl_addr_tmp(tmp_reg, addr), _mz_tl_str_l(addr, mz_tl_tmp_reg(tmp_reg), reg), mz_tl_addr_untmp(tmp_reg)) +# define mz_tl_sti_i(addr, reg, tmp_reg) (mz_tl_addr_tmp(tmp_reg, addr), _mz_tl_str_i(addr, mz_tl_tmp_reg(tmp_reg), reg), mz_tl_addr_untmp(tmp_reg)) # define mz_tl_ldi_p(reg, addr) (mz_tl_addr(reg, addr), jit_ldr_p(reg, reg)) # define mz_tl_ldi_l(reg, addr) (mz_tl_addr(reg, addr), jit_ldr_l(reg, reg)) # define mz_tl_ldi_i(reg, addr) (mz_tl_addr(reg, addr), jit_ldr_i(reg, reg)) @@ -379,22 +392,6 @@ static void *decrement_cache_stack_pos(void *p) THREAD_LOCAL_DECL(static Scheme_Object **fixup_runstack_base); THREAD_LOCAL_DECL(static int fixup_already_in_place); -static Scheme_Object *_scheme_tail_apply_from_native_fixup_args(Scheme_Object *rator, - int argc, - Scheme_Object **argv) -{ - int already = fixup_already_in_place, i; - Scheme_Object **base; - - base = fixup_runstack_base XFORM_OK_MINUS argc XFORM_OK_MINUS already; - - /* Need to shift argc to end of base: */ - for (i = 0; i < argc; i++) { - base[already + i] = argv[i]; - } - - return _scheme_tail_apply_from_native(rator, argc + already, base); -} static Scheme_Object *make_global_ref(Scheme_Object *var) { GC_CAN_IGNORE Scheme_Object *o; @@ -773,11 +770,18 @@ static Scheme_Object *apply_checked_fail(Scheme_Object **args) /*========================================================================*/ #define JIT_RUNSTACK JIT_V0 -#define JIT_RUNSTACK_BASE JIT_V2 -#define JIT_RUNSTACK_BASE_OR_ALT(alt) JIT_RUNSTACK_BASE -#define mz_ld_runstack_base_alt(JIT_R2) /* empty */ -#define mz_st_runstack_base_alt(JIT_R2) /* empty */ +#ifndef THREAD_LOCAL_USES_JIT_V2 +# define JIT_RUNSTACK_BASE JIT_V2 +# define JIT_RUNSTACK_BASE_OR_ALT(alt) JIT_RUNSTACK_BASE +# define mz_ld_runstack_base_alt(reg) /* empty */ +# define mz_st_runstack_base_alt(reg) /* empty */ +#else +# define JIT_RUNSTACK_BASE_OR_ALT(alt) alt +# define JIT_RUNSTACK_BASE_LOCAL JIT_LOCAL4 +# define mz_ld_runstack_base_alt(reg) mz_get_local_p(reg, JIT_RUNSTACK_BASE_LOCAL) +# define mz_st_runstack_base_alt(reg) mz_set_local_p(reg, JIT_RUNSTACK_BASE_LOCAL) +#endif #ifdef MZ_USE_JIT_PPC # define JIT_STACK 1 @@ -1226,7 +1230,7 @@ static void _jit_prolog_again(mz_jit_state *jitter, int n, int ret_addr_reg) since the call (which also pushed), so if the stack was 16-bytes aligned before the call, it is current stack pointer is 1 word (either 4 or 8 bytes) below alignment (need to push 3 or 1 words to - re-align). Also, for a call without a prolog, th stack pointer is + re-align). Also, for a call without a prolog, the stack pointer is 1 word (for the return address) below alignment. */ # define JIT_LOCAL1 -(JIT_WORD_SIZE * 4) # define JIT_LOCAL2 -(JIT_WORD_SIZE * 5) @@ -1295,13 +1299,19 @@ static void _jit_prolog_again(mz_jit_state *jitter, int n, int ret_addr_reg) # define mz_repush_threadlocal() mz_set_local_p(JIT_R14, JIT_LOCAL4) # else # define mz_pop_threadlocal() /* empty */ +# ifdef THREAD_LOCAL_USES_JIT_V2 +# define _mz_install_threadlocal(reg) jit_movr_p(JIT_V2, reg) +# define mz_repush_threadlocal() /* empty */ +# else +# define _mz_install_threadlocal(reg) mz_set_local_p(reg, JIT_LOCAL4) +# define mz_repush_threadlocal() (PUSHQr(JIT_R0), jit_ldr_p(JIT_R0, _EBP), \ + jit_ldxi_p(JIT_R0, JIT_R0, JIT_LOCAL4), \ + jit_stxi_p(JIT_LOCAL4, _EBP, JIT_R0), \ + POPQr(JIT_R0)) +# endif # define mz_push_threadlocal() (PUSHQr(JIT_R0), PUSHQr(JIT_R1), PUSHQr(JIT_R2), PUSHQr(JIT_R2), \ - mz_get_threadlocal(), jit_retval(JIT_R0), mz_set_local_p(JIT_R0, JIT_LOCAL4), \ + mz_get_threadlocal(), jit_retval(JIT_R0), _mz_install_threadlocal(JIT_R0), \ POPQr(JIT_R2), POPQr(JIT_R2), POPQr(JIT_R1), POPQr(JIT_R0)) -# define mz_repush_threadlocal() (PUSHQr(JIT_R0), jit_ldr_p(JIT_R0, _EBP), \ - jit_ldxi_p(JIT_R0, JIT_R0, JIT_LOCAL4), \ - jit_stxi_p(JIT_LOCAL4, _EBP, JIT_R0), \ - POPQr(JIT_R0)) # endif #else # define mz_pop_threadlocal() /* empty */ @@ -2150,124 +2160,78 @@ static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands, extern int g_print_prims; #endif +#include "jit_ts.c" + /* Support for intercepting direct calls to primitives: */ #ifdef FUTURES_ENABLED # define mz_prepare_direct_prim(n) mz_prepare(n) # define mz_finishr_direct_prim(reg, proc) (jit_pusharg_p(reg), (void)mz_finish(proc)) # define mz_direct_only(p) /* skip this arg, so that total count <= 3 args */ -static Scheme_Object *noncm_prim_indirect(Scheme_Prim proc, int argc) +/* Inlines check of scheme_use_rtcall: */ +# define mz_generate_direct_prim(direct_only, first_arg, reg, prim_indirect) \ + { \ + GC_CAN_IGNORE jit_insn *refdirect, *refcont; \ + int argstate; \ + jit_save_argstate(argstate); \ + mz_tl_ldi_i(JIT_R0, tl_scheme_use_rtcall); \ + __START_TINY_JUMPS__(1); \ + refdirect = jit_beqi_i(jit_forward(), JIT_R0, 0); \ + first_arg; \ + mz_finishr_direct_prim(reg, prim_indirect); \ + refcont = jit_jmpi(jit_forward()); \ + CHECK_LIMIT(); \ + mz_patch_branch(refdirect); \ + jit_restore_argstate(argstate); \ + direct_only; \ + first_arg; \ + mz_finishr(reg); \ + mz_patch_ucbranch(refcont); \ + __END_TINY_JUMPS__(1); \ + } + +static Scheme_Object *noncm_prim_indirect(Scheme_Prim proc, int argc) + XFORM_SKIP_PROC { - Scheme_Object *ret; - LOG_PRIM_START(proc); - - if (rtcall_int_pobj_obj(proc, - argc, - MZ_RUNSTACK, - &ret)) - { - LOG_PRIM_END(proc); - return ret; - } - - ret = proc(argc, MZ_RUNSTACK); - LOG_PRIM_END(proc); - - return ret; + if (scheme_use_rtcall) + return scheme_rtcall_iS_s("[prim_indirect]", + FSRC_PRIM, + proc, + argc, + MZ_RUNSTACK); + else + return proc(argc, MZ_RUNSTACK); } -static Scheme_Object *prim_indirect(Scheme_Primitive_Closure_Proc proc, int argc, Scheme_Object *self) + +static Scheme_Object *prim_indirect(Scheme_Primitive_Closure_Proc proc, int argc, Scheme_Object *self) + XFORM_SKIP_PROC { - Scheme_Object *ret; - LOG_PRIM_START(proc); - - if (rtcall_int_pobj_obj_obj(proc, - argc, - MZ_RUNSTACK, - self, - &ret)) - { - LOG_PRIM_END(proc); - return ret; - } - - ret = proc(argc, MZ_RUNSTACK, self); - LOG_PRIM_END(proc); - - return ret; + if (scheme_use_rtcall) + return scheme_rtcall_iSs_s("[prim_indirect]", FSRC_PRIM, proc, argc, MZ_RUNSTACK, self); + else + return proc(argc, MZ_RUNSTACK, self); } /* Various specific 'futurized' versions of primitives that may be invoked directly from JIT code and are not considered thread-safe (are not invoked via apply_multi_from_native, etc.) */ -static Scheme_Object *ts_scheme_apply_multi_from_native(Scheme_Object *rator, int argc, Scheme_Object **argv) +static void ts_on_demand(void) XFORM_SKIP_PROC { - START_XFORM_SKIP; - Scheme_Object *retptr; - if (rtcall_obj_int_pobj_obj(_scheme_apply_multi_from_native, - rator, - argc, - argv, - &retptr)) { - return retptr; - } - - return _scheme_apply_multi_from_native(rator, argc, argv); - END_XFORM_SKIP; -} - -static Scheme_Object *ts_scheme_apply_from_native(Scheme_Object *rator, int argc, Scheme_Object **argv) -{ - START_XFORM_SKIP; - Scheme_Object *retptr; - if (rtcall_obj_int_pobj_obj(_scheme_apply_from_native, - rator, - argc, - argv, - &retptr)) { - return retptr; - } - - return _scheme_apply_from_native(rator, argc, argv); - END_XFORM_SKIP; -} - -static Scheme_Object *ts_scheme_tail_apply_from_native(Scheme_Object *rator, int argc, Scheme_Object **argv) -{ - START_XFORM_SKIP; - Scheme_Object *retptr; - if (rtcall_obj_int_pobj_obj(_scheme_tail_apply_from_native, - rator, - argc, - argv, - &retptr)) { - return retptr; - } - - return _scheme_tail_apply_from_native(rator, argc, argv); - END_XFORM_SKIP; -} - -static void ts_on_demand(void) -{ - START_XFORM_SKIP; - if (rtcall_void_void_3args(on_demand_with_args)) { - return; - } - - on_demand(); - END_XFORM_SKIP; + if (scheme_use_rtcall) { + scheme_rtcall_void_void_3args("[jit_on_demand]", FSRC_OTHER, on_demand_with_args); + } else + on_demand(); } #ifdef MZ_PRECISE_GC -static void *ts_prepare_retry_alloc(void *p, void *p2) +static void *ts_prepare_retry_alloc(void *p, void *p2) XFORM_SKIP_PROC { - START_XFORM_SKIP; - void *ret; - LOG_PRIM_START(&prepare_retry_alloc); - jit_future_storage[0] = p; - jit_future_storage[1] = p2; - if (rtcall_alloc_void_pvoid(GC_make_jit_nursery_page, - &ret)) { + unsigned long ret; + + if (scheme_use_rtcall) { + jit_future_storage[0] = p; + jit_future_storage[1] = p2; + ret = scheme_rtcall_alloc_void_pvoid("[acquire_gc_page]", FSRC_OTHER, GC_make_jit_nursery_page); GC_gen0_alloc_page_ptr = ret; retry_alloc_r1 = jit_future_storage[1]; p = jit_future_storage[0]; @@ -2276,27 +2240,44 @@ static void *ts_prepare_retry_alloc(void *p, void *p2) return p; } - jit_future_storage[0] = NULL; - jit_future_storage[1] = NULL; - ret = prepare_retry_alloc(p, p2); - LOG_PRIM_END(&prepare_retry_alloc); return ret; - END_XFORM_SKIP; } #endif + +Scheme_Object *scheme_ts_scheme_force_value_same_mark(Scheme_Object *v) +{ + return ts_scheme_force_value_same_mark(v); +} + #else /* futures not enabled */ # define mz_prepare_direct_prim(n) mz_prepare(n) # define mz_finishr_direct_prim(reg, proc) mz_finishr(reg) # define mz_direct_only(p) p -# define ts_scheme_apply_multi_from_native _scheme_apply_multi_from_native -# define ts_scheme_apply_from_native _scheme_apply_from_native -# define ts_scheme_tail_apply_from_native _scheme_tail_apply_from_native # define ts_on_demand on_demand # define ts_prepare_retry_alloc prepare_retry_alloc +# define mz_generate_direct_prim(direct_only, first_arg, reg, prim_indirect) \ + (mz_direct_only(direct_only), first_arg, mz_finishr_direct_prim(reg, prim_indirect)) #endif +static Scheme_Object *_scheme_tail_apply_from_native_fixup_args(Scheme_Object *rator, + int argc, + Scheme_Object **argv) +{ + int already = fixup_already_in_place, i; + Scheme_Object **base; + + base = fixup_runstack_base XFORM_OK_MINUS argc XFORM_OK_MINUS already; + + /* Need to shift argc to end of base: */ + for (i = 0; i < argc; i++) { + base[already + i] = argv[i]; + } + + return ts__scheme_tail_apply_from_native(rator, argc + already, base); +} + static int generate_pause_for_gc_and_retry(mz_jit_state *jitter, int in_short_jumps, int gc_reg, /* must not be JIT_R1 */ @@ -2306,6 +2287,8 @@ static int generate_pause_for_gc_and_retry(mz_jit_state *jitter, GC_CAN_IGNORE jit_insn *refslow = 0, *refpause; int i; + mz_rs_sync(); + /* expose gc_reg to GC */ mz_tl_sti_p(tl_jit_future_storage, gc_reg, JIT_R1); @@ -2325,6 +2308,7 @@ static int generate_pause_for_gc_and_retry(mz_jit_state *jitter, register back. */ if (i == 1) { mz_patch_branch(refpause); + JIT_UPDATE_THREAD_RSPTR_FOR_BRANCH_IF_NEEDED(); jit_prepare(0); mz_finish(scheme_future_gc_pause); } @@ -2366,9 +2350,12 @@ static int generate_direct_prim_tail_call(mz_jit_state *jitter, int num_rands) jit_movi_i(JIT_R1, num_rands); mz_prepare_direct_prim(2); /* a prim takes 3 args, but a NONCM prim ignores the 3rd */ CHECK_LIMIT(); - mz_direct_only(jit_pusharg_p(JIT_RUNSTACK)); - jit_pusharg_i(JIT_R1); - mz_finishr_direct_prim(JIT_V1, noncm_prim_indirect); + { + /* May use JIT_R0 and create local branch: */ + mz_generate_direct_prim(jit_pusharg_p(JIT_RUNSTACK), + jit_pusharg_i(JIT_R1), + JIT_V1, noncm_prim_indirect); + } CHECK_LIMIT(); /* Return: */ mz_pop_threadlocal(); @@ -2508,7 +2495,7 @@ static int generate_tail_call(mz_jit_state *jitter, int num_rands, int direct_na /* Need to shuffle argument lists. Since we can pass only three arguments, use static variables for the others. */ mz_ld_runstack_base_alt(JIT_R1); - mz_tl_sti_p(tl_fixup_runstack_base, JIT_RUNSTACK_BASE_OR_ALT(JIT_R0), JIT_R1); + mz_tl_sti_p(tl_fixup_runstack_base, JIT_RUNSTACK_BASE_OR_ALT(JIT_R1), JIT_R0); mz_get_local_p(JIT_R1, JIT_LOCAL2); mz_tl_sti_l(tl_fixup_already_in_place, JIT_R1, JIT_R0); } @@ -2542,7 +2529,7 @@ static int generate_finish_tail_call(mz_jit_state *jitter, int direct_native) if (direct_native > 1) { /* => some_args_already_in_place */ (void)mz_finish(_scheme_tail_apply_from_native_fixup_args); } else { - (void)mz_finish(ts_scheme_tail_apply_from_native); + (void)mz_finish(ts__scheme_tail_apply_from_native); } CHECK_LIMIT(); /* Return: */ @@ -2571,9 +2558,12 @@ static int generate_direct_prim_non_tail_call(mz_jit_state *jitter, int num_rand jit_movi_i(JIT_R1, num_rands); mz_prepare_direct_prim(2); /* a prim takes 3 args, but a NONCM prim ignores the 3rd */ CHECK_LIMIT(); - mz_direct_only(jit_pusharg_p(JIT_RUNSTACK)); - jit_pusharg_i(JIT_R1); - mz_finishr_direct_prim(JIT_V1, noncm_prim_indirect); + { + /* May use JIT_R0 and create local branch: */ + mz_generate_direct_prim(jit_pusharg_p(JIT_RUNSTACK), + jit_pusharg_i(JIT_R1), + JIT_V1, noncm_prim_indirect); + } CHECK_LIMIT(); jit_retval(JIT_R0); VALIDATE_RESULT(JIT_R0); @@ -2840,9 +2830,9 @@ static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc mz_prepare(1); jit_pusharg_p(JIT_R0); if (multi_ok) { - (void)mz_finish(scheme_force_value_same_mark); + (void)mz_finish(ts_scheme_force_value_same_mark); } else { - (void)mz_finish(scheme_force_one_value_same_mark); + (void)mz_finish(ts_scheme_force_one_value_same_mark); } ref5 = jit_jmpi(jit_forward()); CHECK_LIMIT(); @@ -2866,9 +2856,14 @@ static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc mz_prepare_direct_prim(3); jit_pusharg_p(JIT_V1); if (num_rands < 0) { jit_movr_p(JIT_V1, JIT_R0); } /* save argc to manually pop runstack */ - mz_direct_only(jit_pusharg_p(JIT_RUNSTACK)); - jit_pusharg_i(JIT_R2); - mz_finishr_direct_prim(JIT_R1, prim_indirect); + { + __END_SHORT_JUMPS__(1); + /* May use JIT_R0 and create local branch: */ + mz_generate_direct_prim(jit_pusharg_p(JIT_RUNSTACK), + jit_pusharg_i(JIT_R2), + JIT_R1, prim_indirect); + __START_SHORT_JUMPS__(1); + } CHECK_LIMIT(); jit_retval(JIT_R0); VALIDATE_RESULT(JIT_R0); @@ -2894,9 +2889,9 @@ static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc mz_prepare(1); jit_pusharg_p(JIT_R0); if (multi_ok) { - (void)mz_finish(scheme_force_value_same_mark); + (void)mz_finish(ts_scheme_force_value_same_mark); } else { - (void)mz_finish(scheme_force_one_value_same_mark); + (void)mz_finish(ts_scheme_force_one_value_same_mark); } CHECK_LIMIT(); ref8 = jit_jmpi(jit_forward()); @@ -2940,9 +2935,9 @@ static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc jit_pusharg_p(JIT_V1); if (num_rands < 0) { jit_movr_p(JIT_V1, JIT_R0); } /* save argc to manually pop runstack */ if (multi_ok) { - (void)mz_finish(ts_scheme_apply_multi_from_native); + (void)mz_finish(ts__scheme_apply_multi_from_native); } else { - (void)mz_finish(ts_scheme_apply_from_native); + (void)mz_finish(ts__scheme_apply_from_native); } CHECK_LIMIT(); mz_patch_ucbranch(ref5); @@ -3340,7 +3335,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ && !(SCHEME_LOCAL_FLAGS(v) & SCHEME_LOCAL_OTHER_CLEARS)) { int pos; pos = mz_remap(SCHEME_LOCAL_POS(v)); - if (pos == (jitter->depth + args_already_in_place)) + if (pos == (jitter->depth + jitter->extra_pushed + args_already_in_place)) args_already_in_place++; else break; @@ -3793,7 +3788,7 @@ static int generate_alloc_double(mz_jit_state *jitter) (void)mz_tl_sti_d_fppop(tl_double_result, JIT_FPR0, JIT_R0); JIT_UPDATE_THREAD_RSPTR_IF_NEEDED(); mz_prepare(0); - (void)mz_finish(malloc_double); + (void)mz_finish(ts_malloc_double); jit_retval(JIT_R0); # endif #endif @@ -4591,7 +4586,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj /* watch out for most negative fixnum! */ if (!unsafe_fx) (void)jit_beqi_p(refslow, JIT_R0, (void *)(((long)1 << ((8 * JIT_WORD_SIZE) - 1)) | 0x1)); - jit_movi_p(JIT_R1, scheme_make_integer(0)); + (void)jit_movi_p(JIT_R1, scheme_make_integer(0)); jit_subr_l(JIT_R0, JIT_R1, JIT_R0); jit_ori_l(JIT_R0, JIT_R0, 0x1); __START_INNER_TINY__(branch_short); @@ -5375,7 +5370,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in JIT_UPDATE_THREAD_RSPTR_IF_NEEDED(); mz_prepare(1); jit_pusharg_p(JIT_R0); - (void)mz_finish(scheme_box); + (void)mz_finish(ts_scheme_box); jit_retval(JIT_R0); #endif @@ -6061,7 +6056,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i mz_prepare(2); jit_pusharg_p(JIT_R1); jit_pusharg_p(JIT_R0); - (void)mz_finish(scheme_make_mutable_pair); + (void)mz_finish(ts_scheme_make_mutable_pair); jit_retval(JIT_R0); #endif @@ -6311,9 +6306,9 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int jit_pusharg_l(JIT_R0); jit_pusharg_l(JIT_RUNSTACK); if (star) - (void)mz_finish(make_list_star); + (void)mz_finish(ts_make_list_star); else - (void)mz_finish(make_list); + (void)mz_finish(ts_make_list); jit_retval(JIT_R0); #endif @@ -6376,7 +6371,7 @@ static int generate_cons_alloc(mz_jit_state *jitter, int rev, int inline_retry) jit_pusharg_p(JIT_R1); jit_pusharg_p(JIT_R0); } - (void)mz_finish(scheme_make_pair); + (void)mz_finish(ts_scheme_make_pair); jit_retval(JIT_R0); #endif @@ -6433,25 +6428,25 @@ static int generate_vector_alloc(mz_jit_state *jitter, Scheme_Object *rator, mz_prepare(1); jit_pusharg_p(JIT_R0); if (imm) - (void)mz_finish(make_one_element_ivector); + (void)mz_finish(ts_make_one_element_ivector); else - (void)mz_finish(make_one_element_vector); + (void)mz_finish(ts_make_one_element_vector); } else if (c == 2) { mz_prepare(2); jit_pusharg_p(JIT_R1); jit_pusharg_p(JIT_R0); if (imm) - (void)mz_finish(make_two_element_ivector); + (void)mz_finish(ts_make_two_element_ivector); else - (void)mz_finish(make_two_element_vector); + (void)mz_finish(ts_make_two_element_vector); } else { jit_movi_l(JIT_R1, c); mz_prepare(1); jit_pusharg_l(JIT_R1); if (imm) - (void)mz_finish(make_ivector); + (void)mz_finish(ts_make_ivector); else - (void)mz_finish(make_vector); + (void)mz_finish(ts_make_vector); } jit_retval(JIT_R0); #endif @@ -6539,9 +6534,9 @@ static int generate_closure(Scheme_Closure_Data *data, mz_prepare(1); jit_pusharg_l(JIT_R0); if (immediately_filled) { - (void)mz_finish(GC_malloc_one_small_dirty_tagged); + (void)mz_finish(ts_GC_malloc_one_small_dirty_tagged); } else { - (void)mz_finish(GC_malloc_one_small_tagged); + (void)mz_finish(ts_GC_malloc_one_small_tagged); } jit_retval(JIT_R0); memcpy(&init_word, &example_so, sizeof(long)); @@ -6566,7 +6561,7 @@ static int generate_closure(Scheme_Closure_Data *data, (void)jit_patchable_movi_p(JIT_R0, code); /* !! */ #endif jit_pusharg_p(JIT_R0); - (void)mz_finish(scheme_make_native_closure); + (void)mz_finish(ts_scheme_make_native_closure); jit_retval(JIT_R0); return 1; @@ -6665,7 +6660,7 @@ static int generate_case_closure(Scheme_Object *obj, mz_jit_state *jitter, int t (void)jit_patchable_movi_p(JIT_R0, ndata); /* !! */ #endif jit_pusharg_p(JIT_R0); - (void)mz_finish(scheme_make_native_case_closure); + (void)mz_finish(ts_scheme_make_native_case_closure); jit_retval(JIT_R1); CHECK_LIMIT(); @@ -7061,7 +7056,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m jit_pusharg_p(JIT_R0); jit_pusharg_p(JIT_R2); CHECK_LIMIT(); - (void)mz_finish(call_set_global_bucket); + (void)mz_finish(ts_call_set_global_bucket); CHECK_LIMIT(); (void)jit_movi_p(target, scheme_void); END_JIT_DATA(7); @@ -7227,7 +7222,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m jit_ldxi_p(JIT_R2, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); mz_prepare(1); jit_pusharg_p(JIT_R2); - (void)mz_finish(scheme_make_envunbox); + (void)mz_finish(ts_scheme_make_envunbox); jit_retval(JIT_R0); jit_stxi_p(WORDS_TO_BYTES(pos), JIT_RUNSTACK, JIT_R0); CHECK_LIMIT(); @@ -7254,7 +7249,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m JIT_UPDATE_THREAD_RSPTR_IF_NEEDED(); mz_prepare(1); jit_pusharg_p(JIT_R2); - (void)mz_finish(make_global_ref); + (void)mz_finish(ts_make_global_ref); CHECK_LIMIT(); jit_retval(target); VALIDATE_RESULT(target); @@ -7594,7 +7589,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m CHECK_LIMIT(); jit_movi_i(JIT_V1, lv->count); jit_pusharg_i(JIT_V1); - (void)mz_finish(lexical_binding_wrong_return_arity); + (void)mz_finish(ts_lexical_binding_wrong_return_arity); CHECK_LIMIT(); /* Continue with expected values; R2 has value array: */ @@ -7642,7 +7637,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m (void)jit_movi_p(JIT_R0, scheme_undefined); mz_prepare(1); jit_pusharg_p(JIT_R0); - (void)mz_finish(scheme_make_envunbox); + (void)mz_finish(ts_scheme_make_envunbox); jit_retval(JIT_R0); jit_stxi_p(WORDS_TO_BYTES(i), JIT_RUNSTACK, JIT_R0); } @@ -7768,7 +7763,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m mz_prepare(2); jit_pusharg_p(JIT_R0); jit_pusharg_p(JIT_V1); - (void)mz_finish(scheme_set_cont_mark); + (void)mz_finish(ts_scheme_set_cont_mark); CHECK_LIMIT(); END_JIT_DATA(18); @@ -7898,7 +7893,7 @@ static int generate_function_getarg(mz_jit_state *jitter, int has_rest, int num_ rest args, because we'll have to copy anyway. */ if (!has_rest && num_params) { jit_lshi_l(JIT_RUNSTACK_BASE_OR_ALT(JIT_V1), JIT_R1, JIT_LOG_WORD_SIZE); - jit_addr_p(JIT_RUNSTACK_BASE_OR_ALT(JIT_V1), JIT_R2, JIT_RUNSTACK_BASE); + jit_addr_p(JIT_RUNSTACK_BASE_OR_ALT(JIT_V1), JIT_R2, JIT_RUNSTACK_BASE_OR_ALT(JIT_V1)); #ifndef JIT_RUNSTACK_BASE mz_set_local_p(JIT_V1, JIT_RUNSTACK_BASE_LOCAL); #endif @@ -8021,7 +8016,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) CHECK_LIMIT(); jit_movi_i(JIT_V1, 1); jit_pusharg_i(JIT_V1); - (void)mz_finish(call_wrong_return_arity); + (void)mz_finish(ts_call_wrong_return_arity); CHECK_LIMIT(); /* *** unbound_global_code *** */ @@ -8029,7 +8024,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) JIT_UPDATE_THREAD_RSPTR(); mz_prepare(1); jit_pusharg_p(JIT_R2); - (void)mz_finish(scheme_unbound_global); + (void)mz_finish(ts_scheme_unbound_global); CHECK_LIMIT(); /* *** quote_syntax_code *** */ @@ -8067,7 +8062,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) mz_prepare(2); jit_pusharg_l(JIT_R1); jit_pusharg_p(JIT_R0); - (void)mz_finish(scheme_delayed_rename); + (void)mz_finish(ts_scheme_delayed_rename); CHECK_LIMIT(); jit_retval(JIT_R0); /* Restore global array into JIT_R1, and put computed element at i+p+1: */ @@ -8130,28 +8125,28 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) jit_pusharg_i(JIT_R1); switch (i) { case 0: - (void)mz_finish(scheme_checked_car); + (void)mz_finish(ts_scheme_checked_car); break; case 1: - (void)mz_finish(scheme_checked_cdr); + (void)mz_finish(ts_scheme_checked_cdr); break; case 2: - (void)mz_finish(scheme_checked_caar); + (void)mz_finish(ts_scheme_checked_caar); break; case 3: - (void)mz_finish(scheme_checked_cadr); + (void)mz_finish(ts_scheme_checked_cadr); break; case 4: - (void)mz_finish(scheme_checked_cdar); + (void)mz_finish(ts_scheme_checked_cdar); break; case 5: - (void)mz_finish(scheme_checked_cddr); + (void)mz_finish(ts_scheme_checked_cddr); break; case 6: - (void)mz_finish(scheme_checked_mcar); + (void)mz_finish(ts_scheme_checked_mcar); break; case 7: - (void)mz_finish(scheme_checked_mcdr); + (void)mz_finish(ts_scheme_checked_mcdr); break; } CHECK_LIMIT(); @@ -8185,10 +8180,10 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) jit_pusharg_i(JIT_R1); switch (i) { case 0: - (void)mz_finish(scheme_checked_set_mcar); + (void)mz_finish(ts_scheme_checked_set_mcar); break; case 1: - (void)mz_finish(scheme_checked_set_mcdr); + (void)mz_finish(ts_scheme_checked_set_mcdr); break; } CHECK_LIMIT(); @@ -8200,8 +8195,8 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) bad_unbox_code = jit_get_ip().ptr; mz_prolog(JIT_R1); jit_prepare(1); - jit_pusharg_i(JIT_R0); - (void)mz_finish(scheme_unbox); + jit_pusharg_p(JIT_R0); + (void)mz_finish(ts_scheme_unbox); CHECK_LIMIT(); register_sub_func(jitter, bad_unbox_code, scheme_false); @@ -8211,7 +8206,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) mz_prolog(JIT_R1); jit_prepare(1); jit_pusharg_i(JIT_R0); - (void)mz_finish(scheme_vector_length); + (void)mz_finish(ts_scheme_vector_length); CHECK_LIMIT(); register_sub_func(jitter, bad_vector_length_code, scheme_false); @@ -8259,9 +8254,12 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) } JIT_UPDATE_THREAD_RSPTR(); mz_prepare_direct_prim(2); - mz_direct_only(jit_pusharg_p(JIT_RUNSTACK)); - jit_pusharg_p(JIT_R1); - mz_finishr_direct_prim(JIT_R2, noncm_prim_indirect); + { + /* May use JIT_R0 and create local branch: */ + mz_generate_direct_prim(jit_pusharg_p(JIT_RUNSTACK), + jit_pusharg_p(JIT_R1), + JIT_R2, noncm_prim_indirect); + } CHECK_LIMIT(); jit_retval(JIT_R0); VALIDATE_RESULT(JIT_R0); @@ -8289,7 +8287,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) /* Used as the code stub for a closure whose code is not yet compiled. See generate_function_prolog for the state of registers on entry */ - on_demand_jit_code = jit_get_ip().ptr; + scheme_on_demand_jit_code = jit_get_ip().ptr; jit_prolog(NATIVE_ARG_COUNT); in = jit_arg_p(); jit_getarg_p(JIT_R0, in); /* closure */ @@ -8337,7 +8335,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) /* Set runstack base to end of arguments on runstack: */ jit_movr_p(JIT_RUNSTACK_BASE_OR_ALT(JIT_V1), JIT_R1); jit_lshi_ul(JIT_RUNSTACK_BASE_OR_ALT(JIT_V1), JIT_RUNSTACK_BASE_OR_ALT(JIT_V1), JIT_LOG_WORD_SIZE); - jit_addr_p(JIT_RUNSTACK_BASE_OR_ALT(JIT_V1), JIT_RUNSTACK_BASE, JIT_RUNSTACK); + jit_addr_p(JIT_RUNSTACK_BASE_OR_ALT(JIT_V1), JIT_RUNSTACK_BASE_OR_ALT(JIT_V1), JIT_RUNSTACK); mz_st_runstack_base_alt(JIT_V1); /* Extract function and jump: */ jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Native_Closure *)0x0)->code); @@ -8353,13 +8351,13 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) jit_pusharg_p(JIT_R2); jit_pusharg_p(JIT_R1); jit_pusharg_p(JIT_R0); - (void)mz_finish(ts_scheme_apply_multi_from_native); + (void)mz_finish(ts__scheme_apply_multi_from_native); CHECK_LIMIT(); mz_pop_threadlocal(); mz_pop_locals(); jit_ret(); CHECK_LIMIT(); - register_helper_func(jitter, on_demand_jit_code); + register_helper_func(jitter, scheme_on_demand_jit_code); /* *** app_values_tail_slow_code *** */ /* RELIES ON jit_prolog(NATIVE_ARG_COUNT) FROM ABOVE */ @@ -8368,7 +8366,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) JIT_UPDATE_THREAD_RSPTR(); mz_prepare(1); jit_pusharg_p(JIT_V1); - (void)mz_finish(tail_call_with_values_from_multiple_result); + (void)mz_finish(ts_tail_call_with_values_from_multiple_result); jit_retval(JIT_R0); VALIDATE_RESULT(JIT_R0); /* Return: */ @@ -8410,6 +8408,10 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) is such a register for PPC. */ stack_cache_pop_code = jit_get_ip().ptr; jit_movr_p(JIT_R0, JIT_RET); +#ifdef MZ_USE_JIT_PPC + jit_subi_p(JIT_SP, JIT_SP, 48); /* includes space maybe used by callee */ + jit_stxi_p(44, JIT_SP, JIT_AUX); +#endif /* Decrement stack_cache_stack_pos (using a function, in case of thread-local vars) and get record pointer. Use jit_normal_finish(), because jit_finish() shuffles @@ -8419,18 +8421,16 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) jit_pusharg_p(JIT_R0); (void)jit_normal_finish(decrement_cache_stack_pos); jit_retval(JIT_R1); /* = pointer to a stack_cache_stack element */ -#ifdef MZ_USE_JIT_PPC - jit_movr_p(JIT_R(3), JIT_AUX); -#endif CHECK_LIMIT(); /* Extract old return address and jump to it */ jit_ldxi_l(JIT_R0, JIT_R1, (int)&((Stack_Cache_Elem *)0x0)->orig_result); - jit_movi_p(JIT_R2, NULL); + (void)jit_movi_p(JIT_R2, NULL); jit_stxi_l((int)&((Stack_Cache_Elem *)0x0)->orig_result, JIT_R1, JIT_R2); jit_ldxi_l(JIT_R2, JIT_R1, (int)&((Stack_Cache_Elem *)0x0)->orig_return_address); jit_movr_p(JIT_RET, JIT_R0); #ifdef MZ_USE_JIT_PPC - jit_movr_p(JIT_AUX, JIT_R(3)); + jit_ldxi_p(JIT_AUX, JIT_SP, 44); + jit_addi_p(JIT_SP, JIT_SP, 48); #endif jit_jmpr(JIT_R2); CHECK_LIMIT(); @@ -8441,7 +8441,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) JIT_UPDATE_THREAD_RSPTR(); mz_prepare(1); jit_pusharg_p(JIT_R0); - (void)mz_finish(raise_bad_call_with_values); + (void)mz_finish(ts_raise_bad_call_with_values); /* Doesn't return */ CHECK_LIMIT(); @@ -8457,9 +8457,9 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) mz_prepare(1); jit_pusharg_p(JIT_V1); if (i) { - (void)mz_finish(call_with_values_from_multiple_result_multi); + (void)mz_finish(ts_call_with_values_from_multiple_result_multi); } else { - (void)mz_finish(call_with_values_from_multiple_result); + (void)mz_finish(ts_call_with_values_from_multiple_result); } jit_retval(JIT_R0); VALIDATE_RESULT(JIT_R0); @@ -8570,28 +8570,28 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) switch (ii) { case 0: if (!iii) { - (void)mz_finish(scheme_checked_vector_ref); + (void)mz_finish(ts_scheme_checked_vector_ref); } else { - (void)mz_finish(scheme_checked_vector_set); + (void)mz_finish(ts_scheme_checked_vector_set); } break; case 1: if (!iii) { - (void)mz_finish(scheme_checked_string_ref); + (void)mz_finish(ts_scheme_checked_string_ref); /* might return, if char was outside Latin-1 */ jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2)); JIT_UPDATE_THREAD_RSPTR(); jit_retval(JIT_R0); mz_epilog(JIT_R2); } else { - (void)mz_finish(scheme_checked_string_set); + (void)mz_finish(ts_scheme_checked_string_set); } break; case 2: if (!iii) { - (void)mz_finish(scheme_checked_byte_string_ref); + (void)mz_finish(ts_scheme_checked_byte_string_ref); } else { - (void)mz_finish(scheme_checked_byte_string_set); + (void)mz_finish(ts_scheme_checked_byte_string_set); } break; } @@ -8704,7 +8704,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) jit_prepare(2); jit_pusharg_p(JIT_RUNSTACK); jit_pusharg_i(JIT_R1); - (void)mz_finish(scheme_checked_syntax_e); + (void)mz_finish(ts_scheme_checked_syntax_e); jit_retval(JIT_R0); jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); mz_epilog(JIT_R2); @@ -8802,9 +8802,9 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) jit_pusharg_p(JIT_V1); jit_pusharg_p(JIT_R0); if (ii == 1) { - (void)mz_finish(ts_scheme_apply_multi_from_native); + (void)mz_finish(ts__scheme_apply_multi_from_native); } else { - (void)mz_finish(ts_scheme_apply_from_native); + (void)mz_finish(ts__scheme_apply_from_native); } jit_retval(JIT_R0); VALIDATE_RESULT(JIT_R0); @@ -9044,8 +9044,8 @@ static int do_generate_more_common(mz_jit_state *jitter, void *_data) jit_movi_i(JIT_V1, 5); jit_prepare(2); jit_pusharg_p(JIT_RUNSTACK); - jit_pusharg_p(JIT_V1); - (void)mz_finish(scheme_extract_checked_procedure); + jit_pusharg_i(JIT_V1); + (void)mz_finish(ts_scheme_extract_checked_procedure); jit_retval(JIT_R0); VALIDATE_RESULT(JIT_R0); mz_epilog(JIT_V1); @@ -9112,7 +9112,7 @@ static int do_generate_more_common(mz_jit_state *jitter, void *_data) JIT_UPDATE_THREAD_RSPTR(); jit_prepare(1); jit_pusharg_p(JIT_RUNSTACK); - (void)mz_finish(apply_checked_fail); + (void)mz_finish(ts_apply_checked_fail); CHECK_LIMIT(); jit_retval(JIT_R0); VALIDATE_RESULT(JIT_R0); @@ -9160,7 +9160,6 @@ static int do_generate_more_common(mz_jit_state *jitter, void *_data) jit_pusharg_p(JIT_R0); (void)mz_finish(scheme_module_run_finish); CHECK_LIMIT(); - jit_retval(JIT_R0); mz_pop_locals(); jit_ret(); CHECK_LIMIT(); @@ -9193,7 +9192,6 @@ static int do_generate_more_common(mz_jit_state *jitter, void *_data) jit_pusharg_p(JIT_R0); (void)mz_finish(scheme_module_start_finish); CHECK_LIMIT(); - jit_retval(JIT_R0); mz_pop_locals(); jit_ret(); CHECK_LIMIT(); @@ -9353,7 +9351,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) jit_pusharg_p(JIT_R2); jit_pusharg_i(JIT_R1); CHECK_LIMIT(); - (void)mz_finish(scheme_build_list_offset); + (void)mz_finish(ts_scheme_build_list_offset); jit_retval(JIT_V1); #ifndef JIT_PRECISE_GC if (data->closure_size) @@ -9583,7 +9581,7 @@ static void on_demand_with_args(Scheme_Object **in_argv) argc = in_argv[1]; argv = (Scheme_Object **)in_argv[2]; - if (((Scheme_Native_Closure *)c)->code->code == on_demand_jit_code) + if (((Scheme_Native_Closure *)c)->code->code == scheme_on_demand_jit_code) scheme_on_demand_generate_lambda((Scheme_Native_Closure *)c, SCHEME_INT_VAL(argc), argv); } @@ -9618,7 +9616,7 @@ Scheme_Native_Closure_Data *scheme_generate_lambda(Scheme_Closure_Data *data, in ndata->iso.so.type = scheme_rt_native_code_plus_case; #endif } - ndata->code = on_demand_jit_code; + ndata->code = scheme_on_demand_jit_code; ndata->u.tail_code = on_demand_jit_arity_code; ndata->arity_code = on_demand_jit_arity_code; ndata->u2.orig_code = data; @@ -9667,10 +9665,10 @@ static int generate_simple_arity_check(mz_jit_state *jitter, int num_params, int /* Not negative, so report run-time arity mismatch */ mz_prepare(3); jit_pusharg_p(JIT_R2); - jit_pusharg_p(JIT_R1); + jit_pusharg_i(JIT_R1); jit_pusharg_p(JIT_R0); CHECK_LIMIT(); - (void)mz_nonrs_finish(wrong_argument_count); + (void)mz_nonrs_finish(ts_wrong_argument_count); CHECK_LIMIT(); /* Arity check or reporting. If argv is NULL, it's a reporting request */ @@ -9705,7 +9703,7 @@ static int generate_simple_arity_check(mz_jit_state *jitter, int num_params, int if (is_method) { mz_prepare(1); jit_pusharg_p(JIT_R0); - (void)mz_nonrs_finish(scheme_box); + (void)mz_nonrs_finish(ts_scheme_box); mz_pop_threadlocal(); mz_pop_locals(); jit_ret(); @@ -9805,10 +9803,10 @@ static int generate_case_lambda_dispatch(mz_jit_state *jitter, Scheme_Case_Lambd JIT_UPDATE_THREAD_RSPTR(); mz_prepare(3); jit_pusharg_p(JIT_R2); - jit_pusharg_p(JIT_R1); + jit_pusharg_i(JIT_R1); jit_pusharg_p(JIT_R0); CHECK_LIMIT(); - (void)mz_finish(wrong_argument_count); + (void)mz_finish(ts_wrong_argument_count); CHECK_LIMIT(); } @@ -9888,7 +9886,7 @@ static void generate_case_lambda(Scheme_Case_Lambda *c, Scheme_Native_Closure_Da static int lambda_has_been_jitted(Scheme_Native_Closure_Data *ndata) { - return (ndata->code != on_demand_jit_code); + return (ndata->code != scheme_on_demand_jit_code); } int scheme_native_arity_check(Scheme_Object *closure, int argc) @@ -10189,7 +10187,7 @@ Scheme_Object *scheme_native_stack_trace(void) on frames where the previous frame had a return address with a name, because an arbitrary frame's return address on the stack might not be used (depending on how the C compiler optimized the - cdode); any frame whose procedure has a name is JITted code, so + code); any frame whose procedure has a name is JITted code, so it will use the return address from the stack. */ if (STK_COMP((unsigned long)halfway, (unsigned long)p) && prev_had_name) { @@ -10305,11 +10303,8 @@ void scheme_dump_stack_trace(void) } #endif -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - void scheme_flush_stack_cache() + XFORM_SKIP_PROC { void **p; @@ -10321,6 +10316,7 @@ void scheme_flush_stack_cache() } void scheme_jit_longjmp(mz_jit_jmp_buf b, int v) + XFORM_SKIP_PROC { unsigned long limit; void **p; @@ -10339,16 +10335,13 @@ void scheme_jit_longjmp(mz_jit_jmp_buf b, int v) } void scheme_jit_setjmp_prepare(mz_jit_jmp_buf b) + XFORM_SKIP_PROC { void *p; p = &p; b->stack_frame = (unsigned long)p; } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - void scheme_clean_native_symtab(void) { #ifndef MZ_PRECISE_GC diff --git a/src/mzscheme/src/jit_ts.c b/src/mzscheme/src/jit_ts.c new file mode 100644 index 0000000000..a43e0e5827 --- /dev/null +++ b/src/mzscheme/src/jit_ts.c @@ -0,0 +1,138 @@ +#ifdef FUTURES_ENABLED + +# include "jit_ts_def.c" + +/* s = Scheme_Object* + i = int + l = long + S = Scheme_Object** + v = void + b = Scheme_Bucket* + n = Scheme_Native_Closure_Data* + p = void*, CGC only + z = size_t + m = MZ_MARK_STACK_TYPE */ + +define_ts_siS_s(_scheme_apply_multi_from_native, FSRC_RATOR) +define_ts_siS_s(_scheme_apply_from_native, FSRC_RATOR) +define_ts_siS_s(_scheme_tail_apply_from_native, FSRC_RATOR) +define_ts_s_s(scheme_force_value_same_mark, FSRC_OTHER) +define_ts_s_s(scheme_force_one_value_same_mark, FSRC_OTHER) +#if defined(INLINE_FP_OPS) && !defined(CAN_INLINE_ALLOC) +define_ts__s(malloc_double, FSRC_OTHER) +#endif +define_ts_s_s(scheme_box, FSRC_OTHER) +#ifndef CAN_INLINE_ALLOC +define_ts_ss_s(scheme_make_mutable_pair, FSRC_OTHER) +define_ts_Sl_s(make_list_star, FSRC_OTHER) +define_ts_Sl_s(make_list, FSRC_OTHER) +define_ts_ss_s(scheme_make_pair, FSRC_OTHER) +define_ts_s_s(make_one_element_ivector, FSRC_OTHER) +define_ts_s_s(make_one_element_vector, FSRC_OTHER) +define_ts_ss_s(make_two_element_ivector, FSRC_OTHER) +define_ts_ss_s(make_two_element_vector, FSRC_OTHER) +define_ts_l_s(make_ivector, FSRC_OTHER) +define_ts_l_s(make_vector, FSRC_OTHER) +#endif +#ifdef JIT_PRECISE_GC +define_ts_z_p(GC_malloc_one_small_dirty_tagged, FSRC_OTHER) +define_ts_z_p(GC_malloc_one_small_tagged, FSRC_OTHER) +#endif +define_ts_n_s(scheme_make_native_closure, FSRC_OTHER) +define_ts_n_s(scheme_make_native_case_closure, FSRC_OTHER) +define_ts_bsi_v(call_set_global_bucket, FSRC_OTHER) +define_ts_s_s(scheme_make_envunbox, FSRC_OTHER) +define_ts_s_s(make_global_ref, FSRC_OTHER) +define_ts_iiS_v(lexical_binding_wrong_return_arity, FSRC_OTHER) +define_ts_ss_m(scheme_set_cont_mark, FSRC_OTHER) +define_ts_iiS_v(call_wrong_return_arity, FSRC_OTHER) +define_ts_b_v(scheme_unbound_global, FSRC_OTHER) +define_ts_Sl_s(scheme_delayed_rename, FSRC_OTHER) +define_ts_iS_s(scheme_checked_car, FSRC_OTHER) +define_ts_iS_s(scheme_checked_cdr, FSRC_OTHER) +define_ts_iS_s(scheme_checked_caar, FSRC_OTHER) +define_ts_iS_s(scheme_checked_cadr, FSRC_OTHER) +define_ts_iS_s(scheme_checked_cdar, FSRC_OTHER) +define_ts_iS_s(scheme_checked_cddr, FSRC_OTHER) +define_ts_iS_s(scheme_checked_mcar, FSRC_OTHER) +define_ts_iS_s(scheme_checked_mcdr, FSRC_OTHER) +define_ts_iS_s(scheme_checked_set_mcar, FSRC_OTHER) +define_ts_iS_s(scheme_checked_set_mcdr, FSRC_OTHER) +define_ts_s_s(scheme_unbox, FSRC_OTHER) +define_ts_s_s(scheme_vector_length, FSRC_OTHER) +define_ts_s_s(tail_call_with_values_from_multiple_result, FSRC_OTHER) +define_ts_s_v(raise_bad_call_with_values, FSRC_OTHER) +define_ts_s_s(call_with_values_from_multiple_result_multi, FSRC_OTHER) +define_ts_s_s(call_with_values_from_multiple_result, FSRC_OTHER) +define_ts_iS_s(scheme_checked_vector_ref, FSRC_OTHER) +define_ts_iS_s(scheme_checked_vector_set, FSRC_OTHER) +define_ts_iS_s(scheme_checked_string_ref, FSRC_OTHER) +define_ts_iS_s(scheme_checked_string_set, FSRC_OTHER) +define_ts_iS_s(scheme_checked_byte_string_ref, FSRC_OTHER) +define_ts_iS_s(scheme_checked_byte_string_set, FSRC_OTHER) +define_ts_iS_s(scheme_checked_syntax_e, FSRC_OTHER) +define_ts_iS_s(scheme_extract_checked_procedure, FSRC_OTHER) +define_ts_S_s(apply_checked_fail, FSRC_OTHER) +define_ts_iSi_s(scheme_build_list_offset, FSRC_OTHER) +define_ts_siS_v(wrong_argument_count, FSRC_OTHER) +#else +# define ts__scheme_apply_multi_from_native _scheme_apply_multi_from_native +# define ts__scheme_apply_from_native _scheme_apply_from_native +# define ts__scheme_tail_apply_from_native _scheme_tail_apply_from_native +# define ts__scheme_tail_apply_from_native_fixup_args _scheme_tail_apply_from_native_fixup_args +# define ts_scheme_force_value_same_mark scheme_force_value_same_mark +# define ts_scheme_force_one_value_same_mark scheme_force_one_value_same_mark +# define ts_scheme_force_value_same_mark scheme_force_value_same_mark +# define ts_scheme_force_one_value_same_mark scheme_force_one_value_same_mark +# define ts_malloc_double malloc_double +# define ts_scheme_box scheme_box +# define ts_scheme_make_mutable_pair scheme_make_mutable_pair +# define ts_make_list_star make_list_star +# define ts_make_list make_list +# define ts_scheme_make_pair scheme_make_pair +# define ts_make_one_element_ivector make_one_element_ivector +# define ts_make_one_element_vector make_one_element_vector +# define ts_make_two_element_ivector make_two_element_ivector +# define ts_make_two_element_vector make_two_element_vector +# define ts_make_ivector make_ivector +# define ts_make_vector make_vector +# define ts_GC_malloc_one_small_dirty_tagged GC_malloc_one_small_dirty_tagged +# define ts_GC_malloc_one_small_tagged GC_malloc_one_small_tagged +# define ts_scheme_make_native_closure scheme_make_native_closure +# define ts_scheme_make_native_case_closure scheme_make_native_case_closure +# define ts_call_set_global_bucket call_set_global_bucket +# define ts_scheme_make_envunbox scheme_make_envunbox +# define ts_make_global_ref make_global_ref +# define ts_lexical_binding_wrong_return_arity lexical_binding_wrong_return_arity +# define ts_scheme_set_cont_mark scheme_set_cont_mark +# define ts_call_wrong_return_arity call_wrong_return_arity +# define ts_scheme_unbound_global scheme_unbound_global +# define ts_scheme_delayed_rename scheme_delayed_rename +# define ts_scheme_checked_car scheme_checked_car +# define ts_scheme_checked_cdr scheme_checked_cdr +# define ts_scheme_checked_caar scheme_checked_caar +# define ts_scheme_checked_cadr scheme_checked_cadr +# define ts_scheme_checked_cdar scheme_checked_cdar +# define ts_scheme_checked_cddr scheme_checked_cddr +# define ts_scheme_checked_mcar scheme_checked_mcar +# define ts_scheme_checked_mcdr scheme_checked_mcdr +# define ts_scheme_checked_set_mcar scheme_checked_set_mcar +# define ts_scheme_checked_set_mcdr scheme_checked_set_mcdr +# define ts_scheme_unbox scheme_unbox +# define ts_scheme_vector_length scheme_vector_length +# define ts_tail_call_with_values_from_multiple_result tail_call_with_values_from_multiple_result +# define ts_raise_bad_call_with_values raise_bad_call_with_values +# define ts_call_with_values_from_multiple_result_multi call_with_values_from_multiple_result_multi +# define ts_call_with_values_from_multiple_result call_with_values_from_multiple_result +# define ts_scheme_checked_vector_ref scheme_checked_vector_ref +# define ts_scheme_checked_vector_set scheme_checked_vector_set +# define ts_scheme_checked_string_ref scheme_checked_string_ref +# define ts_scheme_checked_string_set scheme_checked_string_set +# define ts_scheme_checked_byte_string_ref scheme_checked_byte_string_ref +# define ts_scheme_checked_byte_string_set scheme_checked_byte_string_set +# define ts_scheme_checked_syntax_e scheme_checked_syntax_e +# define ts_scheme_extract_checked_procedure scheme_extract_checked_procedure +# define ts_apply_checked_fail apply_checked_fail +# define ts_scheme_build_list_offset scheme_build_list_offset +# define ts_wrong_argument_count wrong_argument_count +#endif diff --git a/src/mzscheme/src/jit_ts_def.c b/src/mzscheme/src/jit_ts_def.c new file mode 100644 index 0000000000..2f09ee2d9f --- /dev/null +++ b/src/mzscheme/src/jit_ts_def.c @@ -0,0 +1,180 @@ +#define define_ts_siS_s(id, src_type) \ +static Scheme_Object* ts_ ## id(Scheme_Object* g7, int g8, Scheme_Object** g9) \ + XFORM_SKIP_PROC \ +{ \ + if (scheme_use_rtcall) \ + return scheme_rtcall_siS_s("[" #id "]", src_type, id, g7, g8, g9); \ + else \ + return id(g7, g8, g9); \ +} +#define define_ts_iSs_s(id, src_type) \ +static Scheme_Object* ts_ ## id(int g10, Scheme_Object** g11, Scheme_Object* g12) \ + XFORM_SKIP_PROC \ +{ \ + if (scheme_use_rtcall) \ + return scheme_rtcall_iSs_s("[" #id "]", src_type, id, g10, g11, g12); \ + else \ + return id(g10, g11, g12); \ +} +#define define_ts_s_s(id, src_type) \ +static Scheme_Object* ts_ ## id(Scheme_Object* g13) \ + XFORM_SKIP_PROC \ +{ \ + if (scheme_use_rtcall) \ + return scheme_rtcall_s_s("[" #id "]", src_type, id, g13); \ + else \ + return id(g13); \ +} +#define define_ts_n_s(id, src_type) \ +static Scheme_Object* ts_ ## id(Scheme_Native_Closure_Data* g14) \ + XFORM_SKIP_PROC \ +{ \ + if (scheme_use_rtcall) \ + return scheme_rtcall_n_s("[" #id "]", src_type, id, g14); \ + else \ + return id(g14); \ +} +#define define_ts__s(id, src_type) \ +static Scheme_Object* ts_ ## id() \ + XFORM_SKIP_PROC \ +{ \ + if (scheme_use_rtcall) \ + return scheme_rtcall__s("[" #id "]", src_type, id, ); \ + else \ + return id(); \ +} +#define define_ts_ss_s(id, src_type) \ +static Scheme_Object* ts_ ## id(Scheme_Object* g15, Scheme_Object* g16) \ + XFORM_SKIP_PROC \ +{ \ + if (scheme_use_rtcall) \ + return scheme_rtcall_ss_s("[" #id "]", src_type, id, g15, g16); \ + else \ + return id(g15, g16); \ +} +#define define_ts_ss_m(id, src_type) \ +static MZ_MARK_STACK_TYPE ts_ ## id(Scheme_Object* g17, Scheme_Object* g18) \ + XFORM_SKIP_PROC \ +{ \ + if (scheme_use_rtcall) \ + return scheme_rtcall_ss_m("[" #id "]", src_type, id, g17, g18); \ + else \ + return id(g17, g18); \ +} +#define define_ts_Sl_s(id, src_type) \ +static Scheme_Object* ts_ ## id(Scheme_Object** g19, long g20) \ + XFORM_SKIP_PROC \ +{ \ + if (scheme_use_rtcall) \ + return scheme_rtcall_Sl_s("[" #id "]", src_type, id, g19, g20); \ + else \ + return id(g19, g20); \ +} +#define define_ts_l_s(id, src_type) \ +static Scheme_Object* ts_ ## id(long g21) \ + XFORM_SKIP_PROC \ +{ \ + if (scheme_use_rtcall) \ + return scheme_rtcall_l_s("[" #id "]", src_type, id, g21); \ + else \ + return id(g21); \ +} +#define define_ts_bsi_v(id, src_type) \ +static void ts_ ## id(Scheme_Bucket* g22, Scheme_Object* g23, int g24) \ + XFORM_SKIP_PROC \ +{ \ + if (scheme_use_rtcall) \ + scheme_rtcall_bsi_v("[" #id "]", src_type, id, g22, g23, g24); \ + else \ + id(g22, g23, g24); \ +} +#define define_ts_iiS_v(id, src_type) \ +static void ts_ ## id(int g25, int g26, Scheme_Object** g27) \ + XFORM_SKIP_PROC \ +{ \ + if (scheme_use_rtcall) \ + scheme_rtcall_iiS_v("[" #id "]", src_type, id, g25, g26, g27); \ + else \ + id(g25, g26, g27); \ +} +#define define_ts_ss_v(id, src_type) \ +static void ts_ ## id(Scheme_Object* g28, Scheme_Object* g29) \ + XFORM_SKIP_PROC \ +{ \ + if (scheme_use_rtcall) \ + scheme_rtcall_ss_v("[" #id "]", src_type, id, g28, g29); \ + else \ + id(g28, g29); \ +} +#define define_ts_b_v(id, src_type) \ +static void ts_ ## id(Scheme_Bucket* g30) \ + XFORM_SKIP_PROC \ +{ \ + if (scheme_use_rtcall) \ + scheme_rtcall_b_v("[" #id "]", src_type, id, g30); \ + else \ + id(g30); \ +} +#define define_ts_sl_s(id, src_type) \ +static Scheme_Object* ts_ ## id(Scheme_Object* g31, long g32) \ + XFORM_SKIP_PROC \ +{ \ + if (scheme_use_rtcall) \ + return scheme_rtcall_sl_s("[" #id "]", src_type, id, g31, g32); \ + else \ + return id(g31, g32); \ +} +#define define_ts_iS_s(id, src_type) \ +static Scheme_Object* ts_ ## id(int g33, Scheme_Object** g34) \ + XFORM_SKIP_PROC \ +{ \ + if (scheme_use_rtcall) \ + return scheme_rtcall_iS_s("[" #id "]", src_type, id, g33, g34); \ + else \ + return id(g33, g34); \ +} +#define define_ts_S_s(id, src_type) \ +static Scheme_Object* ts_ ## id(Scheme_Object** g35) \ + XFORM_SKIP_PROC \ +{ \ + if (scheme_use_rtcall) \ + return scheme_rtcall_S_s("[" #id "]", src_type, id, g35); \ + else \ + return id(g35); \ +} +#define define_ts_s_v(id, src_type) \ +static void ts_ ## id(Scheme_Object* g36) \ + XFORM_SKIP_PROC \ +{ \ + if (scheme_use_rtcall) \ + scheme_rtcall_s_v("[" #id "]", src_type, id, g36); \ + else \ + id(g36); \ +} +#define define_ts_iSi_s(id, src_type) \ +static Scheme_Object* ts_ ## id(int g37, Scheme_Object** g38, int g39) \ + XFORM_SKIP_PROC \ +{ \ + if (scheme_use_rtcall) \ + return scheme_rtcall_iSi_s("[" #id "]", src_type, id, g37, g38, g39); \ + else \ + return id(g37, g38, g39); \ +} +#define define_ts_siS_v(id, src_type) \ +static void ts_ ## id(Scheme_Object* g40, int g41, Scheme_Object** g42) \ + XFORM_SKIP_PROC \ +{ \ + if (scheme_use_rtcall) \ + scheme_rtcall_siS_v("[" #id "]", src_type, id, g40, g41, g42); \ + else \ + id(g40, g41, g42); \ +} +#define define_ts_z_p(id, src_type) \ +static void* ts_ ## id(size_t g43) \ + XFORM_SKIP_PROC \ +{ \ + if (scheme_use_rtcall) \ + return scheme_rtcall_z_p("[" #id "]", src_type, id, g43); \ + else \ + return id(g43); \ +} diff --git a/src/mzscheme/src/jit_ts_future_glue.c b/src/mzscheme/src/jit_ts_future_glue.c new file mode 100644 index 0000000000..a9cbc3fff5 --- /dev/null +++ b/src/mzscheme/src/jit_ts_future_glue.c @@ -0,0 +1,498 @@ + Scheme_Object* scheme_rtcall_siS_s(const char *who, int src_type, prim_siS_s f, Scheme_Object* g44, int g45, Scheme_Object** g46) + XFORM_SKIP_PROC +{ + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + future_t *future; + double tm; + Scheme_Object* retval; + + future = fts->current_ft; + future->prim_protocol = SIG_siS_s; + future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; + future->arg_s0 = g44; + future->arg_i1 = g45; + future->arg_S2 = g46; + + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; + retval = future->retval_s; + future->retval_s = 0; + receive_special_result(future, retval, 1); + return retval; +} + Scheme_Object* scheme_rtcall_iSs_s(const char *who, int src_type, prim_iSs_s f, int g47, Scheme_Object** g48, Scheme_Object* g49) + XFORM_SKIP_PROC +{ + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + future_t *future; + double tm; + Scheme_Object* retval; + + future = fts->current_ft; + future->prim_protocol = SIG_iSs_s; + future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; + future->arg_i0 = g47; + future->arg_S1 = g48; + future->arg_s2 = g49; + + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; + retval = future->retval_s; + future->retval_s = 0; + receive_special_result(future, retval, 1); + return retval; +} + Scheme_Object* scheme_rtcall_s_s(const char *who, int src_type, prim_s_s f, Scheme_Object* g50) + XFORM_SKIP_PROC +{ + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + future_t *future; + double tm; + Scheme_Object* retval; + + future = fts->current_ft; + future->prim_protocol = SIG_s_s; + future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; + future->arg_s0 = g50; + send_special_result(future, g50); + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; + retval = future->retval_s; + future->retval_s = 0; + receive_special_result(future, retval, 1); + return retval; +} + Scheme_Object* scheme_rtcall_n_s(const char *who, int src_type, prim_n_s f, Scheme_Native_Closure_Data* g51) + XFORM_SKIP_PROC +{ + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + future_t *future; + double tm; + Scheme_Object* retval; + + future = fts->current_ft; + future->prim_protocol = SIG_n_s; + future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; + future->arg_n0 = g51; + + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; + retval = future->retval_s; + future->retval_s = 0; + receive_special_result(future, retval, 1); + return retval; +} + Scheme_Object* scheme_rtcall__s(const char *who, int src_type, prim__s f ) + XFORM_SKIP_PROC +{ + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + future_t *future; + double tm; + Scheme_Object* retval; + + future = fts->current_ft; + future->prim_protocol = SIG__s; + future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; + + + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; + retval = future->retval_s; + future->retval_s = 0; + receive_special_result(future, retval, 1); + return retval; +} + Scheme_Object* scheme_rtcall_ss_s(const char *who, int src_type, prim_ss_s f, Scheme_Object* g52, Scheme_Object* g53) + XFORM_SKIP_PROC +{ + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + future_t *future; + double tm; + Scheme_Object* retval; + + future = fts->current_ft; + future->prim_protocol = SIG_ss_s; + future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; + future->arg_s0 = g52; + future->arg_s1 = g53; + + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; + retval = future->retval_s; + future->retval_s = 0; + receive_special_result(future, retval, 1); + return retval; +} + MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(const char *who, int src_type, prim_ss_m f, Scheme_Object* g54, Scheme_Object* g55) + XFORM_SKIP_PROC +{ + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + future_t *future; + double tm; + MZ_MARK_STACK_TYPE retval; + + future = fts->current_ft; + future->prim_protocol = SIG_ss_m; + future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; + future->arg_s0 = g54; + future->arg_s1 = g55; + + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; + retval = future->retval_m; + future->retval_m = 0; + + return retval; +} + Scheme_Object* scheme_rtcall_Sl_s(const char *who, int src_type, prim_Sl_s f, Scheme_Object** g56, long g57) + XFORM_SKIP_PROC +{ + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + future_t *future; + double tm; + Scheme_Object* retval; + + future = fts->current_ft; + future->prim_protocol = SIG_Sl_s; + future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; + future->arg_S0 = g56; + future->arg_l1 = g57; + + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; + retval = future->retval_s; + future->retval_s = 0; + receive_special_result(future, retval, 1); + return retval; +} + Scheme_Object* scheme_rtcall_l_s(const char *who, int src_type, prim_l_s f, long g58) + XFORM_SKIP_PROC +{ + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + future_t *future; + double tm; + Scheme_Object* retval; + + future = fts->current_ft; + future->prim_protocol = SIG_l_s; + future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; + future->arg_l0 = g58; + + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; + retval = future->retval_s; + future->retval_s = 0; + receive_special_result(future, retval, 1); + return retval; +} + void scheme_rtcall_bsi_v(const char *who, int src_type, prim_bsi_v f, Scheme_Bucket* g59, Scheme_Object* g60, int g61) + XFORM_SKIP_PROC +{ + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + future_t *future; + double tm; + + + future = fts->current_ft; + future->prim_protocol = SIG_bsi_v; + future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; + future->arg_b0 = g59; + future->arg_s1 = g60; + future->arg_i2 = g61; + + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; + + + + +} + void scheme_rtcall_iiS_v(const char *who, int src_type, prim_iiS_v f, int g62, int g63, Scheme_Object** g64) + XFORM_SKIP_PROC +{ + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + future_t *future; + double tm; + + + future = fts->current_ft; + future->prim_protocol = SIG_iiS_v; + future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; + future->arg_i0 = g62; + future->arg_i1 = g63; + future->arg_S2 = g64; + + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; + + + + +} + void scheme_rtcall_ss_v(const char *who, int src_type, prim_ss_v f, Scheme_Object* g65, Scheme_Object* g66) + XFORM_SKIP_PROC +{ + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + future_t *future; + double tm; + + + future = fts->current_ft; + future->prim_protocol = SIG_ss_v; + future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; + future->arg_s0 = g65; + future->arg_s1 = g66; + + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; + + + + +} + void scheme_rtcall_b_v(const char *who, int src_type, prim_b_v f, Scheme_Bucket* g67) + XFORM_SKIP_PROC +{ + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + future_t *future; + double tm; + + + future = fts->current_ft; + future->prim_protocol = SIG_b_v; + future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; + future->arg_b0 = g67; + + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; + + + + +} + Scheme_Object* scheme_rtcall_sl_s(const char *who, int src_type, prim_sl_s f, Scheme_Object* g68, long g69) + XFORM_SKIP_PROC +{ + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + future_t *future; + double tm; + Scheme_Object* retval; + + future = fts->current_ft; + future->prim_protocol = SIG_sl_s; + future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; + future->arg_s0 = g68; + future->arg_l1 = g69; + + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; + retval = future->retval_s; + future->retval_s = 0; + receive_special_result(future, retval, 1); + return retval; +} + Scheme_Object* scheme_rtcall_iS_s(const char *who, int src_type, prim_iS_s f, int g70, Scheme_Object** g71) + XFORM_SKIP_PROC +{ + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + future_t *future; + double tm; + Scheme_Object* retval; + + future = fts->current_ft; + future->prim_protocol = SIG_iS_s; + future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; + future->arg_i0 = g70; + future->arg_S1 = g71; + + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; + retval = future->retval_s; + future->retval_s = 0; + receive_special_result(future, retval, 1); + return retval; +} + Scheme_Object* scheme_rtcall_S_s(const char *who, int src_type, prim_S_s f, Scheme_Object** g72) + XFORM_SKIP_PROC +{ + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + future_t *future; + double tm; + Scheme_Object* retval; + + future = fts->current_ft; + future->prim_protocol = SIG_S_s; + future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; + future->arg_S0 = g72; + + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; + retval = future->retval_s; + future->retval_s = 0; + receive_special_result(future, retval, 1); + return retval; +} + void scheme_rtcall_s_v(const char *who, int src_type, prim_s_v f, Scheme_Object* g73) + XFORM_SKIP_PROC +{ + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + future_t *future; + double tm; + + + future = fts->current_ft; + future->prim_protocol = SIG_s_v; + future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; + future->arg_s0 = g73; + send_special_result(future, g73); + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; + + + + +} + Scheme_Object* scheme_rtcall_iSi_s(const char *who, int src_type, prim_iSi_s f, int g74, Scheme_Object** g75, int g76) + XFORM_SKIP_PROC +{ + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + future_t *future; + double tm; + Scheme_Object* retval; + + future = fts->current_ft; + future->prim_protocol = SIG_iSi_s; + future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; + future->arg_i0 = g74; + future->arg_S1 = g75; + future->arg_i2 = g76; + + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; + retval = future->retval_s; + future->retval_s = 0; + receive_special_result(future, retval, 1); + return retval; +} + void scheme_rtcall_siS_v(const char *who, int src_type, prim_siS_v f, Scheme_Object* g77, int g78, Scheme_Object** g79) + XFORM_SKIP_PROC +{ + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + future_t *future; + double tm; + + + future = fts->current_ft; + future->prim_protocol = SIG_siS_v; + future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; + future->arg_s0 = g77; + future->arg_i1 = g78; + future->arg_S2 = g79; + + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; + + + + +} + void* scheme_rtcall_z_p(const char *who, int src_type, prim_z_p f, size_t g80) + XFORM_SKIP_PROC +{ + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + future_t *future; + double tm; + void* retval; + + future = fts->current_ft; + future->prim_protocol = SIG_z_p; + future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; + future->arg_z0 = g80; + + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; + retval = future->retval_p; + future->retval_p = 0; + + return retval; +} diff --git a/src/mzscheme/src/jit_ts_protos.h b/src/mzscheme/src/jit_ts_protos.h new file mode 100644 index 0000000000..0d980befd4 --- /dev/null +++ b/src/mzscheme/src/jit_ts_protos.h @@ -0,0 +1,60 @@ +#define SIG_siS_s 5 +typedef Scheme_Object* (*prim_siS_s)(Scheme_Object*, int, Scheme_Object**); +Scheme_Object* scheme_rtcall_siS_s(const char *who, int src_type, prim_siS_s f, Scheme_Object* g118, int g119, Scheme_Object** g120); +#define SIG_iSs_s 6 +typedef Scheme_Object* (*prim_iSs_s)(int, Scheme_Object**, Scheme_Object*); +Scheme_Object* scheme_rtcall_iSs_s(const char *who, int src_type, prim_iSs_s f, int g121, Scheme_Object** g122, Scheme_Object* g123); +#define SIG_s_s 7 +typedef Scheme_Object* (*prim_s_s)(Scheme_Object*); +Scheme_Object* scheme_rtcall_s_s(const char *who, int src_type, prim_s_s f, Scheme_Object* g124); +#define SIG_n_s 8 +typedef Scheme_Object* (*prim_n_s)(Scheme_Native_Closure_Data*); +Scheme_Object* scheme_rtcall_n_s(const char *who, int src_type, prim_n_s f, Scheme_Native_Closure_Data* g125); +#define SIG__s 9 +typedef Scheme_Object* (*prim__s)(); +Scheme_Object* scheme_rtcall__s(const char *who, int src_type, prim__s f ); +#define SIG_ss_s 10 +typedef Scheme_Object* (*prim_ss_s)(Scheme_Object*, Scheme_Object*); +Scheme_Object* scheme_rtcall_ss_s(const char *who, int src_type, prim_ss_s f, Scheme_Object* g126, Scheme_Object* g127); +#define SIG_ss_m 11 +typedef MZ_MARK_STACK_TYPE (*prim_ss_m)(Scheme_Object*, Scheme_Object*); +MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(const char *who, int src_type, prim_ss_m f, Scheme_Object* g128, Scheme_Object* g129); +#define SIG_Sl_s 12 +typedef Scheme_Object* (*prim_Sl_s)(Scheme_Object**, long); +Scheme_Object* scheme_rtcall_Sl_s(const char *who, int src_type, prim_Sl_s f, Scheme_Object** g130, long g131); +#define SIG_l_s 13 +typedef Scheme_Object* (*prim_l_s)(long); +Scheme_Object* scheme_rtcall_l_s(const char *who, int src_type, prim_l_s f, long g132); +#define SIG_bsi_v 14 +typedef void (*prim_bsi_v)(Scheme_Bucket*, Scheme_Object*, int); +void scheme_rtcall_bsi_v(const char *who, int src_type, prim_bsi_v f, Scheme_Bucket* g133, Scheme_Object* g134, int g135); +#define SIG_iiS_v 15 +typedef void (*prim_iiS_v)(int, int, Scheme_Object**); +void scheme_rtcall_iiS_v(const char *who, int src_type, prim_iiS_v f, int g136, int g137, Scheme_Object** g138); +#define SIG_ss_v 16 +typedef void (*prim_ss_v)(Scheme_Object*, Scheme_Object*); +void scheme_rtcall_ss_v(const char *who, int src_type, prim_ss_v f, Scheme_Object* g139, Scheme_Object* g140); +#define SIG_b_v 17 +typedef void (*prim_b_v)(Scheme_Bucket*); +void scheme_rtcall_b_v(const char *who, int src_type, prim_b_v f, Scheme_Bucket* g141); +#define SIG_sl_s 18 +typedef Scheme_Object* (*prim_sl_s)(Scheme_Object*, long); +Scheme_Object* scheme_rtcall_sl_s(const char *who, int src_type, prim_sl_s f, Scheme_Object* g142, long g143); +#define SIG_iS_s 19 +typedef Scheme_Object* (*prim_iS_s)(int, Scheme_Object**); +Scheme_Object* scheme_rtcall_iS_s(const char *who, int src_type, prim_iS_s f, int g144, Scheme_Object** g145); +#define SIG_S_s 20 +typedef Scheme_Object* (*prim_S_s)(Scheme_Object**); +Scheme_Object* scheme_rtcall_S_s(const char *who, int src_type, prim_S_s f, Scheme_Object** g146); +#define SIG_s_v 21 +typedef void (*prim_s_v)(Scheme_Object*); +void scheme_rtcall_s_v(const char *who, int src_type, prim_s_v f, Scheme_Object* g147); +#define SIG_iSi_s 22 +typedef Scheme_Object* (*prim_iSi_s)(int, Scheme_Object**, int); +Scheme_Object* scheme_rtcall_iSi_s(const char *who, int src_type, prim_iSi_s f, int g148, Scheme_Object** g149, int g150); +#define SIG_siS_v 23 +typedef void (*prim_siS_v)(Scheme_Object*, int, Scheme_Object**); +void scheme_rtcall_siS_v(const char *who, int src_type, prim_siS_v f, Scheme_Object* g151, int g152, Scheme_Object** g153); +#define SIG_z_p 24 +typedef void* (*prim_z_p)(size_t); +void* scheme_rtcall_z_p(const char *who, int src_type, prim_z_p f, size_t g154); diff --git a/src/mzscheme/src/jit_ts_runtime_glue.c b/src/mzscheme/src/jit_ts_runtime_glue.c new file mode 100644 index 0000000000..587134ab03 --- /dev/null +++ b/src/mzscheme/src/jit_ts_runtime_glue.c @@ -0,0 +1,220 @@ +case SIG_siS_s: + { + prim_siS_s f = (prim_siS_s)future->prim_func; + Scheme_Object* retval; + + retval = + f(future->arg_s0, future->arg_i1, future->arg_S2); + future->retval_s = retval; + send_special_result(future, retval); + break; + } +case SIG_iSs_s: + { + prim_iSs_s f = (prim_iSs_s)future->prim_func; + Scheme_Object* retval; + + retval = + f(future->arg_i0, future->arg_S1, future->arg_s2); + future->retval_s = retval; + send_special_result(future, retval); + break; + } +case SIG_s_s: + { + prim_s_s f = (prim_s_s)future->prim_func; + Scheme_Object* retval; + receive_special_result(future, future->arg_s0, 1); + retval = + f(future->arg_s0); + future->retval_s = retval; + send_special_result(future, retval); + break; + } +case SIG_n_s: + { + prim_n_s f = (prim_n_s)future->prim_func; + Scheme_Object* retval; + + retval = + f(future->arg_n0); + future->retval_s = retval; + send_special_result(future, retval); + break; + } +case SIG__s: + { + prim__s f = (prim__s)future->prim_func; + Scheme_Object* retval; + + retval = + f(); + future->retval_s = retval; + send_special_result(future, retval); + break; + } +case SIG_ss_s: + { + prim_ss_s f = (prim_ss_s)future->prim_func; + Scheme_Object* retval; + + retval = + f(future->arg_s0, future->arg_s1); + future->retval_s = retval; + send_special_result(future, retval); + break; + } +case SIG_ss_m: + { + prim_ss_m f = (prim_ss_m)future->prim_func; + MZ_MARK_STACK_TYPE retval; + + retval = + f(future->arg_s0, future->arg_s1); + future->retval_m = retval; + + break; + } +case SIG_Sl_s: + { + prim_Sl_s f = (prim_Sl_s)future->prim_func; + Scheme_Object* retval; + + retval = + f(future->arg_S0, future->arg_l1); + future->retval_s = retval; + send_special_result(future, retval); + break; + } +case SIG_l_s: + { + prim_l_s f = (prim_l_s)future->prim_func; + Scheme_Object* retval; + + retval = + f(future->arg_l0); + future->retval_s = retval; + send_special_result(future, retval); + break; + } +case SIG_bsi_v: + { + prim_bsi_v f = (prim_bsi_v)future->prim_func; + + + + f(future->arg_b0, future->arg_s1, future->arg_i2); + + + break; + } +case SIG_iiS_v: + { + prim_iiS_v f = (prim_iiS_v)future->prim_func; + + + + f(future->arg_i0, future->arg_i1, future->arg_S2); + + + break; + } +case SIG_ss_v: + { + prim_ss_v f = (prim_ss_v)future->prim_func; + + + + f(future->arg_s0, future->arg_s1); + + + break; + } +case SIG_b_v: + { + prim_b_v f = (prim_b_v)future->prim_func; + + + + f(future->arg_b0); + + + break; + } +case SIG_sl_s: + { + prim_sl_s f = (prim_sl_s)future->prim_func; + Scheme_Object* retval; + + retval = + f(future->arg_s0, future->arg_l1); + future->retval_s = retval; + send_special_result(future, retval); + break; + } +case SIG_iS_s: + { + prim_iS_s f = (prim_iS_s)future->prim_func; + Scheme_Object* retval; + + retval = + f(future->arg_i0, future->arg_S1); + future->retval_s = retval; + send_special_result(future, retval); + break; + } +case SIG_S_s: + { + prim_S_s f = (prim_S_s)future->prim_func; + Scheme_Object* retval; + + retval = + f(future->arg_S0); + future->retval_s = retval; + send_special_result(future, retval); + break; + } +case SIG_s_v: + { + prim_s_v f = (prim_s_v)future->prim_func; + + receive_special_result(future, future->arg_s0, 1); + + f(future->arg_s0); + + + break; + } +case SIG_iSi_s: + { + prim_iSi_s f = (prim_iSi_s)future->prim_func; + Scheme_Object* retval; + + retval = + f(future->arg_i0, future->arg_S1, future->arg_i2); + future->retval_s = retval; + send_special_result(future, retval); + break; + } +case SIG_siS_v: + { + prim_siS_v f = (prim_siS_v)future->prim_func; + + + + f(future->arg_s0, future->arg_i1, future->arg_S2); + + + break; + } +case SIG_z_p: + { + prim_z_p f = (prim_z_p)future->prim_func; + void* retval; + + retval = + f(future->arg_z0); + future->retval_p = retval; + + break; + } diff --git a/src/mzscheme/src/lightning/i386/core.h b/src/mzscheme/src/lightning/i386/core.h index f41bb3cd43..e6f72085a4 100644 --- a/src/mzscheme/src/lightning/i386/core.h +++ b/src/mzscheme/src/lightning/i386/core.h @@ -373,6 +373,8 @@ struct jit_local_state { #define jit_prepare_d(nd) (_jitl.argssize += 2 * (nd)) #ifdef JIT_X86_64 # define jit_pusharg_i(rs) (_jitl.argssize++, MOVQrr(rs, JIT_CALLTMPSTART + _jitl.argssize - 1)) +# define jit_save_argstate(curstate) curstate = _jitl.argssize; +# define jit_restore_argstate(curstate) _jitl.argssize = curstate; # define jit_finish(sub) (jit_shift_args(), (void)jit_calli((sub)), jit_restore_locals()) # define jit_normal_finish(sub) jit_calli((sub)) # define jit_reg_is_arg(reg) ((reg == _EDI) || (reg ==_ESI) || (reg == _EDX)) @@ -396,6 +398,8 @@ struct jit_local_state { (MOVQrr(_R12, _ESI), MOVQrr(_R13, _EDI)) #else # define jit_pusharg_i(rs) PUSHLr(rs) +# define jit_save_argstate(curstate) curstate = _jitl.argssize; +# define jit_restore_argstate(curstate) _jitl.argssize = curstate; # define jit_finish(sub) ((void)jit_calli((sub)), ADDLir(sizeof(long) * _jitl.argssize, JIT_SP), _jitl.argssize = 0) # define jit_finishr(reg) (jit_callr((reg)), ADDLir(sizeof(long) * _jitl.argssize, JIT_SP), _jitl.argssize = 0) # define jit_normal_finish(sub) jit_finish(sub) diff --git a/src/mzscheme/src/lightning/ppc/core.h b/src/mzscheme/src/lightning/ppc/core.h index de6f406b3d..534a213651 100644 --- a/src/mzscheme/src/lightning/ppc/core.h +++ b/src/mzscheme/src/lightning/ppc/core.h @@ -246,6 +246,8 @@ struct jit_local_state { #define jit_prolog(n) _jit_prolog(&_jit, (n)) #define jit_pushr_i(rs) STWUrm((rs), -4, 1) #define jit_pusharg_i(rs) (--_jitl.nextarg_puti, MRrr((3 + _jitl.nextarg_putd * 2 + _jitl.nextarg_putf + _jitl.nextarg_puti), (rs))) +#define jit_save_argstate(curstate) (curstate = _jitl.nextarg_puti) +#define jit_restore_argstate(curstate) (_jitl.nextarg_puti = curstate) #define jit_ret() _jit_epilog(&_jit) #define jit_retval_i(rd) MRrr((rd), 3) #define jit_rsbi_i(d, rs, is) jit_chk_ims((is), SUBFICrri((d), (rs), (is)), SUBFCrrr((d), (rs), JIT_AUX)) diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index c2c8dc974d..5ff15d2952 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -5413,6 +5413,8 @@ static int native_unclosed_proc_plus_case_FIXUP(void *p) { #ifdef MARKS_FOR_FUTURE_C +#ifdef FUTURES_ENABLED + static int future_SIZE(void *p) { return gcBYTES_TO_WORDS(sizeof(future_t)); @@ -5420,13 +5422,20 @@ static int future_SIZE(void *p) { static int future_MARK(void *p) { future_t *f = (future_t *)p; - gcMARK(f->runstack); - gcMARK(f->runstack_start); gcMARK(f->orig_lambda); - gcMARK(f->prim_data.p); - gcMARK(f->prim_data.argv); - gcMARK(f->prim_data.retval); + gcMARK(f->arg_s0); + gcMARK(f->arg_S0); + gcMARK(f->arg_b0); + gcMARK(f->arg_n0); + gcMARK(f->arg_s1); + gcMARK(f->arg_S1); + gcMARK(f->arg_s2); + gcMARK(f->arg_S2); + gcMARK(f->retval_s); gcMARK(f->retval); + gcMARK(f->multiple_array); + gcMARK(f->tail_rator); + gcMARK(f->tail_rands); gcMARK(f->prev); gcMARK(f->next); gcMARK(f->next_waiting_atomic); @@ -5436,13 +5445,20 @@ static int future_MARK(void *p) { static int future_FIXUP(void *p) { future_t *f = (future_t *)p; - gcFIXUP(f->runstack); - gcFIXUP(f->runstack_start); gcFIXUP(f->orig_lambda); - gcFIXUP(f->prim_data.p); - gcFIXUP(f->prim_data.argv); - gcFIXUP(f->prim_data.retval); + gcFIXUP(f->arg_s0); + gcFIXUP(f->arg_S0); + gcFIXUP(f->arg_b0); + gcFIXUP(f->arg_n0); + gcFIXUP(f->arg_s1); + gcFIXUP(f->arg_S1); + gcFIXUP(f->arg_s2); + gcFIXUP(f->arg_S2); + gcFIXUP(f->retval_s); gcFIXUP(f->retval); + gcFIXUP(f->multiple_array); + gcFIXUP(f->tail_rator); + gcFIXUP(f->tail_rands); gcFIXUP(f->prev); gcFIXUP(f->next); gcFIXUP(f->next_waiting_atomic); @@ -5454,6 +5470,39 @@ static int future_FIXUP(void *p) { #define future_IS_CONST_SIZE 1 +#else + +static int sequential_future_SIZE(void *p) { + return + gcBYTES_TO_WORDS(sizeof(future_t)); +} + +static int sequential_future_MARK(void *p) { + future_t *f = (future_t *)p; + gcMARK(f->orig_lambda); + gcMARK(f->running_sema); + gcMARK(f->retval); + gcMARK(f->multiple_array); + return + gcBYTES_TO_WORDS(sizeof(future_t)); +} + +static int sequential_future_FIXUP(void *p) { + future_t *f = (future_t *)p; + gcFIXUP(f->orig_lambda); + gcFIXUP(f->running_sema); + gcFIXUP(f->retval); + gcFIXUP(f->multiple_array); + return + gcBYTES_TO_WORDS(sizeof(future_t)); +} + +#define sequential_future_IS_ATOMIC 0 +#define sequential_future_IS_CONST_SIZE 1 + + +#endif + #endif /* FUTURE */ /**********************************************************************/ diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index 12599cc9ed..e850efbb0b 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -2220,16 +2220,25 @@ END jit; START future; +#ifdef FUTURES_ENABLED + future { mark: future_t *f = (future_t *)p; - gcMARK(f->runstack); - gcMARK(f->runstack_start); gcMARK(f->orig_lambda); - gcMARK(f->prim_data.p); - gcMARK(f->prim_data.argv); - gcMARK(f->prim_data.retval); + gcMARK(f->arg_s0); + gcMARK(f->arg_S0); + gcMARK(f->arg_b0); + gcMARK(f->arg_n0); + gcMARK(f->arg_s1); + gcMARK(f->arg_S1); + gcMARK(f->arg_s2); + gcMARK(f->arg_S2); + gcMARK(f->retval_s); gcMARK(f->retval); + gcMARK(f->multiple_array); + gcMARK(f->tail_rator); + gcMARK(f->tail_rands); gcMARK(f->prev); gcMARK(f->next); gcMARK(f->next_waiting_atomic); @@ -2237,6 +2246,21 @@ future { gcBYTES_TO_WORDS(sizeof(future_t)); } +#else + +sequential_future { + mark: + future_t *f = (future_t *)p; + gcMARK(f->orig_lambda); + gcMARK(f->running_sema); + gcMARK(f->retval); + gcMARK(f->multiple_array); + size: + gcBYTES_TO_WORDS(sizeof(future_t)); +} + +#endif + END future; /**********************************************************************/ diff --git a/src/mzscheme/src/network.c b/src/mzscheme/src/network.c index eaafaec2ac..30205f60f7 100644 --- a/src/mzscheme/src/network.c +++ b/src/mzscheme/src/network.c @@ -338,11 +338,9 @@ static struct protoent *proto; # define mz_gai_strerror gai_strerror #else # define mzAI_PASSIVE 0 -# ifdef MZ_XFORM -START_XFORM_SKIP; -# endif static int mz_getaddrinfo(const char *nodename, const char *servname, const struct mz_addrinfo *hints, struct mz_addrinfo **res) + XFORM_SKIP_PROC { struct hostent *h; @@ -386,17 +384,16 @@ static int mz_getaddrinfo(const char *nodename, const char *servname, return h_errno; } void mz_freeaddrinfo(struct mz_addrinfo *ai) + XFORM_SKIP_PROC { free(ai->ai_addr); free(ai); } const char *mz_gai_strerror(int ecode) + XFORM_SKIP_PROC { return hstrerror(ecode); } -# ifdef MZ_XFORM -END_XFORM_SKIP; -# endif #endif #if defined(USE_WINSOCK_TCP) || defined(PTHREADS_OK_FOR_GHBN) @@ -441,11 +438,8 @@ HANDLE ready_sema; int ready_fd; # endif -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - static long getaddrinfo_in_thread(void *data) + XFORM_SKIP_PROC { int ok; struct mz_addrinfo *res, hints; @@ -487,10 +481,6 @@ static long getaddrinfo_in_thread(void *data) return 1; } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - static void release_ghbn_lock(GHBN_Rec *rec) { ghbn_lock = 0; diff --git a/src/mzscheme/src/numcomp.c b/src/mzscheme/src/numcomp.c index 48744b9129..6e678070d6 100644 --- a/src/mzscheme/src/numcomp.c +++ b/src/mzscheme/src/numcomp.c @@ -150,11 +150,8 @@ void scheme_init_unsafe_numcomp(Scheme_Env *env) /* Prototype needed for 3m conversion: */ static MZ_INLINE Scheme_Object *force_rat(Scheme_Object *n, Small_Rational *sr); -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - static MZ_INLINE Scheme_Object *force_rat(Scheme_Object *n, Small_Rational *sr) + XFORM_SKIP_PROC { Scheme_Type t = SCHEME_TYPE(n); if (t == scheme_rational_type) @@ -163,10 +160,6 @@ static MZ_INLINE Scheme_Object *force_rat(Scheme_Object *n, Small_Rational *sr) return scheme_make_small_bn_rational(n, sr); } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - GEN_NARY_COMP(eq, "=", scheme_bin_eq, SCHEME_NUMBERP, "number") GEN_NARY_COMP(lt, "<", scheme_bin_lt, SCHEME_REALP, REAL_NUMBER_STR) GEN_NARY_COMP(gt, ">", scheme_bin_gt, SCHEME_REALP, REAL_NUMBER_STR) diff --git a/src/mzscheme/src/port.c b/src/mzscheme/src/port.c index 35bfb7f79e..be14d99b34 100644 --- a/src/mzscheme/src/port.c +++ b/src/mzscheme/src/port.c @@ -206,11 +206,8 @@ static int *malloc_refcount() return (int *)malloc(sizeof(int)); } -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - static int dec_refcount(int *refcount) + XFORM_SKIP_PROC { int rc; @@ -227,10 +224,6 @@ static int dec_refcount(int *refcount) return rc; } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - #else static int *malloc_refcount() @@ -693,11 +686,8 @@ static int dynamic_fd_size; # define STORED_ACTUAL_FDSET_LIMIT # define FDSET_LIMIT(fd) (*(int *)((char *)fd XFORM_OK_PLUS dynamic_fd_size)) -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - void *scheme_alloc_fdset_array(int count, int permanent) + XFORM_SKIP_PROC { /* Note: alloc only at the end, because this function isn't annotated. We skip annotation so that it's @@ -722,10 +712,6 @@ void *scheme_alloc_fdset_array(int count, int permanent) return scheme_malloc_atomic(count * (dynamic_fd_size + sizeof(long))); } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - void *scheme_init_fdset_array(void *fdarray, int count) { return fdarray; @@ -1184,11 +1170,8 @@ void scheme_remember_subthread(struct Scheme_Thread_Memory *tm, void *t) tm->subhandle = t; } -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - void scheme_forget_thread(struct Scheme_Thread_Memory *tm) + XFORM_SKIP_PROC { if (tm->prev) tm->prev->next = tm->next; @@ -1207,11 +1190,13 @@ void scheme_forget_thread(struct Scheme_Thread_Memory *tm) } void scheme_forget_subthread(struct Scheme_Thread_Memory *tm) + XFORM_SKIP_PROC { tm->subhandle = NULL; } void scheme_suspend_remembered_threads(void) + XFORM_SKIP_PROC { Scheme_Thread_Memory *tm, *next, *prev = NULL; int keep; @@ -1249,6 +1234,7 @@ void scheme_suspend_remembered_threads(void) } void scheme_resume_remembered_threads(void) + XFORM_SKIP_PROC { Scheme_Thread_Memory *tm; @@ -1259,10 +1245,6 @@ void scheme_resume_remembered_threads(void) } } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - #endif /*========================================================================*/ @@ -5442,11 +5424,8 @@ make_fd_input_port(int fd, Scheme_Object *name, int regfile, int win_textmode, i # ifdef WINDOWS_FILE_HANDLES -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - static long WindowsFDReader(Win_FD_Input_Thread *th) + XFORM_SKIP_PROC { DWORD toget, got; int perma_eof = 0; @@ -5502,6 +5481,7 @@ static long WindowsFDReader(Win_FD_Input_Thread *th) } static void WindowsFDICleanup(Win_FD_Input_Thread *th) + XFORM_SKIP_PROC { int rc; @@ -5516,10 +5496,6 @@ static void WindowsFDICleanup(Win_FD_Input_Thread *th) free(th); } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - # endif #endif @@ -6649,11 +6625,8 @@ static void flush_if_output_fds(Scheme_Object *o, Scheme_Close_Custodian_Client #ifdef WINDOWS_FILE_HANDLES -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - static long WindowsFDWriter(Win_FD_Output_Thread *oth) + XFORM_SKIP_PROC { DWORD towrite, wrote, start; int ok, more_work = 0, err_no; @@ -6717,6 +6690,7 @@ static long WindowsFDWriter(Win_FD_Output_Thread *oth) } static void WindowsFDOCleanup(Win_FD_Output_Thread *oth) + XFORM_SKIP_PROC { int rc; @@ -6732,10 +6706,6 @@ static void WindowsFDOCleanup(Win_FD_Output_Thread *oth) free(oth); } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - #endif #endif @@ -6827,11 +6797,8 @@ static int MyPipe(int *ph, int near_index) { static int need_to_check_children; -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - void scheme_block_child_signals(int block) + XFORM_SKIP_PROC { sigset_t sigs; @@ -6844,6 +6811,7 @@ void scheme_block_child_signals(int block) } static void child_done(int ingored) + XFORM_SKIP_PROC { need_to_check_children = 1; scheme_signal_received(); @@ -6853,10 +6821,6 @@ static void child_done(int ingored) # endif } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - static int sigchld_installed = 0; static void init_sigchld(void) @@ -8115,16 +8079,12 @@ void scheme_notify_sleep_progress() /******************** Main sleep function *****************/ /* The simple select() stuff is buried in Windows complexity. */ +static void default_sleep(float v, void *fds) +#ifdef OS_X + XFORM_SKIP_PROC +#endif /* This sleep function is not allowed to allocate in OS X, because it is called in a non-main thread. */ - -#ifdef OS_X -# ifdef MZ_XFORM -START_XFORM_SKIP; -# endif -#endif - -static void default_sleep(float v, void *fds) { /* REMEMBER: don't allocate in this function (at least not GCable memory) for OS X. Not that FD setups are ok, because they use @@ -8359,17 +8319,8 @@ static void default_sleep(float v, void *fds) #endif } -#ifdef OS_X -# ifdef MZ_XFORM -END_XFORM_SKIP; -# endif -#endif - -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - void scheme_signal_received_at(void *h) + XFORM_SKIP_PROC /* Ensure that MzScheme wakes up if asleep. */ { #if defined(FILES_HAVE_FDS) @@ -8387,6 +8338,7 @@ void scheme_signal_received_at(void *h) } void *scheme_get_signal_handle() + XFORM_SKIP_PROC { #if defined(FILES_HAVE_FDS) return &put_external_event_fd; @@ -8400,14 +8352,11 @@ void *scheme_get_signal_handle() } void scheme_signal_received(void) + XFORM_SKIP_PROC { scheme_signal_received_at(scheme_get_signal_handle()); } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - int scheme_get_external_event_fd(void) { #if defined(FILES_HAVE_FDS) @@ -8423,11 +8372,8 @@ static HANDLE itimer; static OS_SEMAPHORE_TYPE itimer_semaphore; static long itimer_delay; -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - static long ITimer(void) + XFORM_SKIP_PROC { WaitForSingleObject(itimer_semaphore, INFINITE); @@ -8440,10 +8386,6 @@ static long ITimer(void) } } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - static void scheme_start_itimer_thread(long usec) { DWORD id; @@ -8477,11 +8419,8 @@ typedef struct ITimer_Data { THREAD_LOCAL_DECL(static ITimer_Data *itimerdata); -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - static void *green_thread_timer(void *data) + XFORM_SKIP_PROC { ITimer_Data *itimer_data; itimer_data = (ITimer_Data *)data; @@ -8510,10 +8449,6 @@ static void *green_thread_timer(void *data) return NULL; } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - static void start_green_thread_timer(long usec) { itimerdata->die = 0; @@ -8581,11 +8516,8 @@ static void scheme_start_itimer_thread(long usec) #ifdef USE_ITIMER -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - static void itimer_expired(int ignored) + XFORM_SKIP_PROC { scheme_fuel_counter = 0; scheme_jit_stack_boundary = (unsigned long)-1; @@ -8594,7 +8526,9 @@ static void itimer_expired(int ignored) # endif } -static void kickoff_itimer(long usec) { +static void kickoff_itimer(long usec) + XFORM_SKIP_PROC +{ struct itimerval t; struct itimerval old; static int itimer_handler_installed = 0; @@ -8612,10 +8546,6 @@ static void kickoff_itimer(long usec) { setitimer(ITIMER_PROF, &t, &old); } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - #endif void scheme_kickoff_green_thread_time_slice_timer(long usec) { diff --git a/src/mzscheme/src/print.c b/src/mzscheme/src/print.c index 90c2c3608d..6a960455ea 100644 --- a/src/mzscheme/src/print.c +++ b/src/mzscheme/src/print.c @@ -534,16 +534,13 @@ static int check_cycles(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht return 0; } -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - /* The fast cycle-checker plays a dangerous game: it changes type tags. No GCs can occur here, and no thread switches. If the fast version takes to long, we back out to the general case. (We don't even check for stack overflow, so keep the max limit low.) */ static int check_cycles_fast(Scheme_Object *obj, PrintParams *pp, int *fast_checker_counter) + XFORM_SKIP_PROC { Scheme_Type t; int cycle = 0; @@ -618,10 +615,6 @@ static int check_cycles_fast(Scheme_Object *obj, PrintParams *pp, int *fast_chec return cycle; } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - #ifdef DO_STACK_CHECK static void setup_graph_table(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht, int *counter, PrintParams *pp); diff --git a/src/mzscheme/src/rational.c b/src/mzscheme/src/rational.c index 85ea6d30f2..34a0a1db5c 100644 --- a/src/mzscheme/src/rational.c +++ b/src/mzscheme/src/rational.c @@ -56,11 +56,8 @@ Scheme_Object *scheme_integer_to_rational(const Scheme_Object *n) return make_rational(n, one, 0); } -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - Scheme_Object *scheme_make_small_rational(long n, Small_Rational *s) + XFORM_SKIP_PROC { s->so.type = scheme_rational_type; s->num = scheme_make_integer(n); @@ -70,6 +67,7 @@ Scheme_Object *scheme_make_small_rational(long n, Small_Rational *s) } Scheme_Object *scheme_make_small_bn_rational(Scheme_Object *n, Small_Rational *s) + XFORM_SKIP_PROC { s->so.type = scheme_rational_type; s->num = n; @@ -78,10 +76,6 @@ Scheme_Object *scheme_make_small_bn_rational(Scheme_Object *n, Small_Rational *s return (Scheme_Object *)s; } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - int scheme_is_rational_positive(const Scheme_Object *o) { Scheme_Rational *r = (Scheme_Rational *)o; diff --git a/src/mzscheme/src/salloc.c b/src/mzscheme/src/salloc.c index a492d2f8d7..87e4dc715e 100644 --- a/src/mzscheme/src/salloc.c +++ b/src/mzscheme/src/salloc.c @@ -157,20 +157,11 @@ int scheme_main_setup(int no_auto_statics, Scheme_Env_Main _main, int argc, char return scheme_main_stack_setup(no_auto_statics, call_with_basic, &d); } -int scheme_main_stack_setup(int no_auto_statics, Scheme_Nested_Main _main, void *data) +static int do_main_stack_setup(int no_auto_statics, Scheme_Nested_Main _main, void *data) { void *stack_start; int volatile return_code; -#ifdef IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS - if (pthread_key_create(&scheme_thread_local_key, NULL)) { - fprintf(stderr, "pthread key create failed"); - abort(); - } -#endif - - scheme_init_os_thread(); - #ifdef USE_THREAD_LOCAL scheme_vars = scheme_get_thread_local_variables(); #endif @@ -187,6 +178,57 @@ int scheme_main_stack_setup(int no_auto_statics, Scheme_Nested_Main _main, void return return_code; } +int scheme_main_stack_setup(int no_auto_statics, Scheme_Nested_Main _main, void *data) XFORM_SKIP_PROC +{ +#ifdef IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS +# ifdef INLINE_GETSPECIFIC_ASSEMBLY_CODE + /* Our [highly questionable] strategy for inlining pthread_getspecific() is taken from + the Go implementation (see "http://golang.org/src/libcgo/darwin_386.c"). + In brief, we assume that thread-local variables are going to be + accessed via the gs segment register at offset 0x48 (i386) or 0x60 (x86_64), + and we also hardwire the therad-local key 0x108. Here we have to try to get + that particular key and double-check that it worked. */ + pthread_key_t unwanted[16]; + int num_unwanted = 0; +# endif + + while (1) { + if (pthread_key_create(&scheme_thread_local_key, NULL)) { + fprintf(stderr, "pthread key create failed\n"); + abort(); + } +# ifdef INLINE_GETSPECIFIC_ASSEMBLY_CODE + if (scheme_thread_local_key == 0x108) + break; + else { + if (num_unwanted == 16) { + fprintf(stderr, "pthread key create never produced 0x108 for inline hack\n"); + abort(); + } + unwanted[num_unwanted++] = scheme_thread_local_key; + } +# else + break; +# endif + } + +# ifdef INLINE_GETSPECIFIC_ASSEMBLY_CODE + pthread_setspecific(scheme_thread_local_key, (void *)0xaced); + if (scheme_get_thread_local_variables() != (Thread_Local_Variables *)0xaced) { + fprintf(stderr, "pthread getspecific inline hack failed\n"); + abort(); + } + while (num_unwanted--) { + pthread_key_delete(unwanted[num_unwanted]); + } +# endif +#endif + + scheme_init_os_thread(); + + return do_main_stack_setup(no_auto_statics, _main, data); +} + void scheme_set_stack_bounds(void *base, void *deepest, int no_auto_statics) { scheme_set_stack_base(base, no_auto_statics); @@ -233,24 +275,13 @@ extern void GC_attach_current_thread_exceptions_to_handler(); # endif #endif -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif -void scheme_init_os_thread() +void scheme_init_os_thread() XFORM_SKIP_PROC { #ifdef IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS Thread_Local_Variables *vars; vars = (Thread_Local_Variables *)malloc(sizeof(Thread_Local_Variables)); memset(vars, 0, sizeof(Thread_Local_Variables)); pthread_setspecific(scheme_thread_local_key, vars); -# ifdef OS_X - /* A hack that smehow avoids a problem with calling vm_allocate() - later. There must be some deeper bug that I have't found, yet. */ - if (1) { - void *r; - vm_allocate(mach_task_self(), (vm_address_t*)&r, 4096, TRUE); - } -# endif #endif #ifdef OS_X # ifdef MZ_PRECISE_GC @@ -258,9 +289,6 @@ void scheme_init_os_thread() # endif #endif } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif /************************************************************************/ /* memory utils */ @@ -535,11 +563,7 @@ void *scheme_malloc_uncollectable(size_t size_in_bytes) } #endif -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - -void scheme_register_static(void *ptr, long size) +void scheme_register_static(void *ptr, long size) XFORM_SKIP_PROC { #if defined(MZ_PRECISE_GC) || defined(USE_SENORA_GC) /* Always register for precise and Senora GC: */ @@ -553,10 +577,6 @@ void scheme_register_static(void *ptr, long size) #endif } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - #ifdef USE_TAGGED_ALLOCATION struct GC_Set *tagged, *real_tagged, *tagged_atomic, *tagged_eternal, *tagged_uncollectable, *stacks, *envunbox; diff --git a/src/mzscheme/src/schnapp.inc b/src/mzscheme/src/schnapp.inc index a12f945453..c045d7ef66 100644 --- a/src/mzscheme/src/schnapp.inc +++ b/src/mzscheme/src/schnapp.inc @@ -31,9 +31,7 @@ static MZ_INLINE Scheme_Object *PRIM_APPLY_NAME_FAST(Scheme_Object *rator, } f = (Scheme_Primitive_Closure_Proc *)prim->prim_val; - LOG_PRIM_START(f); v = f(argc, argv, (Scheme_Object *)prim); - LOG_PRIM_END(f); #if PRIM_CHECK_VALUE if (v == SCHEME_TAIL_CALL_WAITING) { diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index d89cd69b12..5c4c3b6989 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -230,11 +230,14 @@ void scheme_init_print_buffers_places(void); void scheme_init_eval_places(void); void scheme_init_port_places(void); void scheme_init_regexp_places(void); -void scheme_init_stx_places(void); +void scheme_init_stx_places(int initial_main_os_thread); void scheme_init_fun_places(void); void scheme_init_sema_places(void); void scheme_init_gmp_places(void); void scheme_init_print_global_constants(void); +void scheme_init_logger(void); +Scheme_Logger *scheme_get_main_logger(void); +void scheme_init_logger_config(void); void register_network_evts(); @@ -2422,6 +2425,7 @@ int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count); #define SCHEME_OUT_OF_CONTEXT_LOCAL 8192 Scheme_Hash_Table *scheme_map_constants_to_globals(void); +const char *scheme_look_for_primitive(void *code); Scheme_Object *scheme_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); @@ -2943,8 +2947,6 @@ typedef struct Scheme_Log_Reader { Scheme_Object *head, *tail; } Scheme_Log_Reader; -extern Scheme_Logger *scheme_main_logger; - char *scheme_optimize_context_to_string(Scheme_Object *context); void scheme_write_proc_context(Scheme_Object *port, int print_width, diff --git a/src/mzscheme/src/setjmpup.c b/src/mzscheme/src/setjmpup.c index 90807ca0d1..f5d8063249 100644 --- a/src/mzscheme/src/setjmpup.c +++ b/src/mzscheme/src/setjmpup.c @@ -221,9 +221,8 @@ THREAD_LOCAL_DECL(static long stack_copy_size_cache[STACK_COPY_CACHE_SIZE]); THREAD_LOCAL_DECL(static int scc_pos); #define SCC_OK_EXTRA_AMT 100 -START_XFORM_SKIP; - void scheme_flush_stack_copy_cache(void) + XFORM_SKIP_PROC { int i; for (i = 0; i < STACK_COPY_CACHE_SIZE; i++) { @@ -232,8 +231,6 @@ void scheme_flush_stack_copy_cache(void) } } -END_XFORM_SKIP; - #endif /**********************************************************************/ diff --git a/src/mzscheme/src/string.c b/src/mzscheme/src/string.c index 738982be6b..19a0beaed5 100644 --- a/src/mzscheme/src/string.c +++ b/src/mzscheme/src/string.c @@ -383,6 +383,7 @@ scheme_init_string (Scheme_Env *env) platform_3m_path = scheme_make_path(SCHEME_PLATFORM_LIBRARY_SUBPATH MZ3M_SUBDIR); REGISTER_SO(putenv_str_table); + REGISTER_SO(embedding_banner); REGISTER_SO(current_locale_name); @@ -1978,33 +1979,83 @@ int scheme_any_string_has_null(Scheme_Object *o) } } -#ifdef DOS_FILE_SYSTEM -# include -static char *mzGETENV(char *s) -{ - int sz, got; - char *res; +/***********************************************************************/ +/* Environment Variables */ +/***********************************************************************/ - sz = GetEnvironmentVariable(s, NULL, 0); - if (!sz) - return NULL; - res = scheme_malloc_atomic(sz); - got = GetEnvironmentVariable(s, res, sz); - if (got < sz) - res[got] = 0; - return res; +#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) +static char* clone_str_with_gc(const char* buffer) { + int length; + char *newbuffer; + length = strlen(buffer); + newbuffer = scheme_malloc_atomic(length+1); + memcpy(newbuffer, buffer, length+1); + return newbuffer; } - -static int mzPUTENV(char *var, char *val, char *together) -{ - return !SetEnvironmentVariable(var, val); -} - -#else -# define mzGETENV getenv -# define mzPUTENV(var, val, s) MSC_IZE(putenv)(s) #endif +static void create_putenv_str_table_if_needed() { + if (!putenv_str_table) { + putenv_str_table = scheme_make_hash_table(SCHEME_hash_string); + } +} + +#ifndef DOS_FILE_SYSTEM +static void putenv_str_table_put_name(Scheme_Object *name, Scheme_Object *value) { +#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) + void *original_gc; + Scheme_Object *name_copy; + original_gc = GC_switch_to_master_gc(); + name_copy = (Scheme_Object *) clone_str_with_gc((Scheme_Object *) name); + create_putenv_str_table_if_needed(); + scheme_hash_set(putenv_str_table, name_copy, value); + GC_switch_back_from_master(original_gc); +#else + create_putenv_str_table_if_needed(); + scheme_hash_set(putenv_str_table, name, value); +#endif +} +#endif + +#ifndef GETENV_FUNCTION +static void putenv_str_table_put_name_value(Scheme_Object *name, Scheme_Object *value) { +#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) + void *original_gc; + Scheme_Object *name_copy; + Scheme_Object *value_copy; + original_gc = GC_switch_to_master_gc(); + name_copy = (Scheme_Object *) clone_str_with_gc((Scheme_Object *) name); + value_copy = (Scheme_Object *) clone_str_with_gc((Scheme_Object *) value); + create_putenv_str_table_if_needed(); + scheme_hash_set(putenv_str_table, name_copy, value_copy); + GC_switch_back_from_master(original_gc); +#else + create_putenv_str_table_if_needed(); + scheme_hash_set(putenv_str_table, name, value); +#endif +} +#endif + +#if !defined(GETENV_FUNCTION) || defined(MZ_PRECISE_GC) +static Scheme_Object *putenv_str_table_get(Scheme_Object *name) { +#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) + void *original_gc; + Scheme_Object *value; + original_gc = GC_switch_to_master_gc(); + create_putenv_str_table_if_needed(); + value = scheme_hash_get(putenv_str_table, name); + GC_switch_back_from_master(original_gc); + return value; +#else + create_putenv_str_table_if_needed(); + return scheme_hash_get(putenv_str_table, name); +#endif +} +#endif + + +static Scheme_Object *sch_bool_getenv(const char* name); + void scheme_init_getenv(void) { @@ -2017,126 +2068,164 @@ scheme_init_getenv(void) scheme_current_thread->error_buf = &newbuf; if (!scheme_setjmp(newbuf)) { while (1) { - Scheme_Object *v = scheme_read(p); - if (SCHEME_EOFP(v)) - break; + Scheme_Object *v = scheme_read(p); + if (SCHEME_EOFP(v)) + break; - if (SCHEME_PAIRP(v) && SCHEME_PAIRP(SCHEME_CDR(v)) - && SCHEME_NULLP(SCHEME_CDR(SCHEME_CDR(v)))) { - Scheme_Object *key = SCHEME_CAR(v); - Scheme_Object *val = SCHEME_CADR(v); - if (SCHEME_STRINGP(key) && SCHEME_STRINGP(val)) { - Scheme_Object *a[2]; - a[0] = key; - a[1] = val; - sch_putenv(2, a); - v = NULL; - } - } + if (SCHEME_PAIRP(v) && SCHEME_PAIRP(SCHEME_CDR(v)) + && SCHEME_NULLP(SCHEME_CDR(SCHEME_CDR(v)))) { + Scheme_Object *key = SCHEME_CAR(v); + Scheme_Object *val = SCHEME_CADR(v); + if (SCHEME_STRINGP(key) && SCHEME_STRINGP(val)) { + Scheme_Object *a[2]; + a[0] = key; + a[1] = val; + sch_putenv(2, a); + v = NULL; + } + } - if (v) - scheme_signal_error("bad environment specification: %V", v); + if (v) + scheme_signal_error("bad environment specification: %V", v); } } scheme_current_thread->error_buf = savebuf; scheme_close_input_port(p); - - if (scheme_hash_get(putenv_str_table, (Scheme_Object *)"PLTNOMZJIT")) { - scheme_set_startup_use_jit(0); - } - } -#else - if (mzGETENV("PLTNOMZJIT")) { - scheme_set_startup_use_jit(0); } #endif + if (sch_bool_getenv("PLTNOMZJIT")) { + scheme_set_startup_use_jit(0); + } +} + +#ifdef DOS_FILE_SYSTEM +# include +static char *dos_win_getenv(const char *name) { + int value_size; + value_size = GetEnvironmentVariable(s, NULL, 0); + if (value_size) { + char *value; + int got; + value = scheme_malloc_atomic(value_size); + got = GetEnvironmentVariable(name, value, value_size); + if (got < value_size) + value[got] = 0; + return value; + } + return name; +} +#endif + +static Scheme_Object *sch_bool_getenv(const char* name) { + Scheme_Object *rc; + rc = scheme_false; +#ifdef GETENV_FUNCTION +# ifdef DOS_FILE_SYSTEM + if (GetEnvironmentVariable(s, NULL, 0)) rc = scheme_true; +# else + if (getenv(name)) rc = scheme_true; +# endif +#else + if (putenv_str_table_get(name)) rc = scheme_true; +#endif + return rc; } static Scheme_Object *sch_getenv(int argc, Scheme_Object *argv[]) { - char *s; + char *name; + char *value; Scheme_Object *bs; - if (!SCHEME_CHAR_STRINGP(argv[0]) - || scheme_any_string_has_null(argv[0])) + if (!SCHEME_CHAR_STRINGP(argv[0]) || scheme_any_string_has_null(argv[0])) scheme_wrong_type("getenv", CHAR_STRING_W_NO_NULLS, 0, argc, argv); bs = scheme_char_string_to_byte_string_locale(argv[0]); + name = SCHEME_BYTE_STR_VAL(bs); #ifdef GETENV_FUNCTION - s = mzGETENV(SCHEME_BYTE_STR_VAL(bs)); +# ifdef DOS_FILE_SYSTEM + value = dos_win_getenv(name); +# else + value = getenv(name); +# endif #else - if (putenv_str_table) { - s = (char *)scheme_hash_get(putenv_str_table, (Scheme_Object *)SCHEME_BYTE_STR_VAL(argv[0])); - /* If found, skip over the `=' in the table: */ - if (s) - s += SCHEME_BYTE_STRTAG_VAL(bs) + 1; - } else - s = NULL; -#endif - - if (s) - return scheme_make_locale_string(s); - - return scheme_false; -} - -static Scheme_Object *sch_putenv(int argc, Scheme_Object *argv[]) -{ - char *s, *var, *val; - long varlen, vallen; - Scheme_Object *bs; - - if (!SCHEME_CHAR_STRINGP(argv[0]) - || scheme_any_string_has_null(argv[0])) - scheme_wrong_type("putenv", CHAR_STRING_W_NO_NULLS, 0, argc, argv); - if (!SCHEME_CHAR_STRINGP(argv[1]) - || scheme_any_string_has_null(argv[1])) - scheme_wrong_type("putenv", CHAR_STRING_W_NO_NULLS, 1, argc, argv); - - bs = scheme_char_string_to_byte_string_locale(argv[0]); - var = SCHEME_BYTE_STR_VAL(bs); - - bs = scheme_char_string_to_byte_string_locale(argv[1]); - val = SCHEME_BYTE_STR_VAL(bs); - - varlen = strlen(var); - vallen = strlen(val); - - s = (char *)scheme_malloc_atomic(varlen + vallen + 2); - memcpy(s, var, varlen); - memcpy(s + varlen + 1, val, vallen + 1); - s[varlen] = '='; - -#ifdef MZ_PRECISE_GC { - /* Can't put moveable string into array. */ - char *ss; - ss = s; - s = malloc(varlen + vallen + 2); - memcpy(s, ss, varlen + vallen + 2); - - /* Free old, if in table: */ - if (putenv_str_table) { - ss = (char *)scheme_hash_get(putenv_str_table, (Scheme_Object *)var); - if (ss) - free(ss); - } + Scheme_Object *hash_value; + hash_value = putenv_str_table_get(name); + return hash_value ? hash_value : scheme_false; } #endif - if (!putenv_str_table) - putenv_str_table = scheme_make_hash_table(SCHEME_hash_string); + return value ? scheme_make_locale_string(value) : scheme_false; +} - scheme_hash_set(putenv_str_table, (Scheme_Object *)var, (Scheme_Object *)s); +static int sch_unix_putenv(const char *var, const char *val, const long varlen, const long vallen) { + char *buffer; + long total_length; + total_length = varlen + vallen + 2; + +#ifdef MZ_PRECISE_GC + /* Can't put moveable string into array. */ + buffer = malloc(total_length); +#else + buffer = (char *)scheme_malloc_atomic(total_length); +#endif + memcpy(buffer, var, varlen); + buffer[varlen] = '='; + memcpy(buffer + varlen + 1, val, vallen + 1); + +#ifdef MZ_PRECISE_GC + { + /* Free old, if in table: */ + char *oldbuffer; + oldbuffer = (char *)putenv_str_table_get((Scheme_Object *)var); + if (oldbuffer) + free(oldbuffer); + } +#endif + + /* if precise the buffer needs to be remembered so it can be freed */ + /* if not precise the buffer needs to be rooted so it doesn't get collected prematurely */ + putenv_str_table_put_name((Scheme_Object *)var, (Scheme_Object *)buffer); + return putenv(buffer); +} + +static Scheme_Object *sch_putenv(int argc, Scheme_Object *argv[]) +{ + Scheme_Object *varbs; + Scheme_Object *valbs; + char *var; + char *val; + int rc = 0; + + if (!SCHEME_CHAR_STRINGP(argv[0]) || scheme_any_string_has_null(argv[0])) + scheme_wrong_type("putenv", CHAR_STRING_W_NO_NULLS, 0, argc, argv); + if (!SCHEME_CHAR_STRINGP(argv[1]) || scheme_any_string_has_null(argv[1])) + scheme_wrong_type("putenv", CHAR_STRING_W_NO_NULLS, 1, argc, argv); + + varbs = scheme_char_string_to_byte_string_locale(argv[0]); + var = SCHEME_BYTE_STR_VAL(varbs); + + valbs = scheme_char_string_to_byte_string_locale(argv[1]); + val = SCHEME_BYTE_STR_VAL(valbs); #ifdef GETENV_FUNCTION - return mzPUTENV(var, val, s) ? scheme_false : scheme_true; +# ifdef DOS_FILE_SYSTEM + rc = !SetEnvironmentVariable(var, val); +# else + rc = sch_unix_putenv(var, val, SCHEME_BYTE_STRLEN_VAL(varbs), SCHEME_BYTE_STRLEN_VAL(valbs)); +# endif #else - return scheme_true; + putenv_str_table_put_name_value(argv[0], argv[1]); #endif + return rc ? scheme_false : scheme_true; } +/***********************************************************************/ +/* End Environment Variables */ +/***********************************************************************/ + static void machine_details(char *s); static Scheme_Object *system_type(int argc, Scheme_Object *argv[]) diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 76c90aea1e..f50b26835b 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -631,7 +631,7 @@ void scheme_init_stx(Scheme_Env *env) scheme_install_type_reader2(scheme_free_id_info_type, read_free_id_info_prefix); } -void scheme_init_stx_places() { +void scheme_init_stx_places(int initial_main_os_thread) { REGISTER_SO(last_phase_shift); REGISTER_SO(nominal_ipair_cache); REGISTER_SO(quick_hash_table); @@ -639,6 +639,14 @@ void scheme_init_stx_places() { REGISTER_SO(than_id_marks_ht); REGISTER_SO(interned_skip_ribs); REGISTER_SO(unsealed_dependencies); + + if (!initial_main_os_thread) { + REGISTER_SO(mark_id); + REGISTER_SO(current_rib_timestamp); + mark_id = scheme_make_integer(0); + current_rib_timestamp = scheme_make_integer(0); + } + interned_skip_ribs = scheme_make_weak_equal_table(); } diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c index 96e72532a9..86995727bc 100644 --- a/src/mzscheme/src/thread.c +++ b/src/mzscheme/src/thread.c @@ -1550,14 +1550,11 @@ Scheme_Thread *scheme_do_close_managed(Scheme_Custodian *m, Scheme_Exit_Closer_F return kill_self; } -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - typedef void (*Scheme_For_Each_Func)(Scheme_Object *); static void for_each_managed(Scheme_Type type, Scheme_For_Each_Func cf) - /* This function must not allocate. */ + XFORM_SKIP_PROC +/* This function must not allocate. */ { Scheme_Custodian *m; int i; @@ -1600,10 +1597,6 @@ static void for_each_managed(Scheme_Type type, Scheme_For_Each_Func cf) } } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - void scheme_close_managed(Scheme_Custodian *m) /* The trick is that we may need to kill the thread that is running us. If so, delay it to the very @@ -2436,11 +2429,8 @@ void *scheme_tls_get(int pos) return p->user_tls[pos]; } -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - Scheme_Object **scheme_alloc_runstack(long len) + XFORM_SKIP_PROC { #ifdef MZ_PRECISE_GC long sz; @@ -2458,6 +2448,7 @@ Scheme_Object **scheme_alloc_runstack(long len) } void scheme_set_runstack_limits(Scheme_Object **rs, long len, long start, long end) + XFORM_SKIP_PROC /* With 3m, we can tell the GC not to scan the unused parts, and we can have the fixup function zero out the unused parts; that avoids writing and scanning pages that could be skipped for a minor @@ -2474,10 +2465,6 @@ void scheme_set_runstack_limits(Scheme_Object **rs, long len, long start, long e #endif } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - /*========================================================================*/ /* thread creation and swapping */ /*========================================================================*/ @@ -6842,11 +6829,8 @@ static Scheme_Object *current_thread_initial_stack_size(int argc, Scheme_Object /* namespaces */ /*========================================================================*/ -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - Scheme_Env *scheme_get_env(Scheme_Config *c) + XFORM_SKIP_PROC { Scheme_Object *o; @@ -6857,10 +6841,6 @@ Scheme_Env *scheme_get_env(Scheme_Config *c) return (Scheme_Env *)o; } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - void scheme_add_namespace_option(Scheme_Object *key, void (*f)(Scheme_Env *)) { Scheme_NSO *old = namespace_options; @@ -7428,7 +7408,8 @@ static void done_with_GC() #ifdef MZ_PRECISE_GC static void inform_GC(int major_gc, long pre_used, long post_used) { - if (scheme_main_logger) { + Scheme_Logger *logger = scheme_get_main_logger(); + if (logger) { /* Don't use scheme_log(), because it wants to allocate a buffer based on the max value-print width, and we may not be at a point where parameters are available. */ @@ -7442,10 +7423,7 @@ static void inform_GC(int major_gc, long pre_used, long post_used) end_this_gc_time - start_this_gc_time); buflen = strlen(buf); - scheme_log_message(scheme_main_logger, - SCHEME_LOG_DEBUG, - buf, buflen, - NULL); + scheme_log_message(logger, SCHEME_LOG_DEBUG, buf, buflen, NULL); } }