sync branch to trunk

svn: r17046

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)
+                  ((apply +
-                                                    (bytes-length (string->bytes/utf-8 s)))
+                          (map (lambda (s)
-                                                  cmdline)) . < . 50))
+                                 (+ 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)])

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)
+                   (cond
-                        (regexp-match #rx"GC_VARIABLE_STACK_THOUGH_TABLE" (pragma-s e))))
+                    [(and (pragma? e)
-                 e-raw))
+                          (regexp-match #rx"GC_VARIABLE_STACK_THOUGH_TABLE" (pragma-s e)))
-        (define gc-var-stack-through-thread-local?
+                     'table]
-          (ormap (lambda (e)
+                    [(and (tok? e)
-                   (and (tok? e)
+                          (eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL))
-                        (eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL)))
+                     'thread-local]
-                 e-raw))
+                    [(and (tok? e)
-        (define gc-var-stack-through-getspecific?
+                          (eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_GETSPECIFIC))
-          (ormap (lambda (e)
+                     'getspecific]
-                   (and (tok? e)
+                    [(and (tok? e)
-                        (eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_GETSPECIFIC)))
+                          (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
+          (printf (case gc-var-stack-mode
-                   [gc-var-stack-through-table?
+                   [(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-mode (list-ref l 8))))))
-                (set! gc-var-stack-through-getspecific? (list-ref l 9))))))
         
         ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
         ;; Pretty-printing output
@@ -1519,6 +1523,8 @@
                          null
                          e))))]
             [(function? e)
+             (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))
@@ -1555,7 +1561,7 @@
                                      (cons (car e) (loop (cdr e))))))
                               null)
                           e))
-                   (convert-function e name)))]
+                       (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,6 +1712,7 @@
                      (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
@@ -1712,6 +1720,9 @@
                                      (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)
           (let ([l (length e)])
@@ -4003,8 +4014,7 @@
                     (marshall non-pointer-types)
                     (marshall struct-defs)
 		    non-gcing-functions
-                    gc-var-stack-through-thread-local?
+                    (list 'quote gc-var-stack-mode))])
-                    gc-var-stack-through-getspecific?)])
               (with-output-to-file (change-suffix file-out #".zo")
                 (lambda ()
                   (let ([orig (current-namespace)])

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
+      'stepper-replace
-      #t))
+      #'#t))
     (_ (raise-syntax-error #f "`check-property' erwartet einen einzelnen Operanden"
 			   stx))))
 

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))

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")]
+					  [(i386-macosx i386-darwin) '("-m32" "-fno-common")]
-					  [(ppc-darwin) '("-fno-common")]
+					  [(ppc-macosx ppc-darwin x86_64-macosx x86_64-darwin) '("-fno-common")]
 					  [(win32\\i386) '("-DAS_MSVC_EXTENSION")]
 					  [else null])
 					gcc-cpp-flags))

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 ([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")
+                                     "with-syntax")))
                          (λ (x) (and (list? x) (andmap string? x))))
 
 (preferences:set-default 'framework:white-on-black? #f boolean?)

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 ([admin (get-admin)])
+                        (if admin
                             (let ([b1 (box 0)]
                                   [b2 (box 0)]
                                   [b3 (box 0)]
                                   [b4 (box 0)])
-                        (send (get-admin) get-view b1 b2 b3 b4)
+                              (send admin get-view b1 b2 b3 b4)
                               (values (unbox b1)
                                       (unbox b2)
                                       (unbox b3)
-                                (unbox b4)))])
+                                      (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)]

collects/games/jewel/jewel.scm

@@ -1432,6 +1432,11 @@
 		   
       )
 
+      ;; 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)))

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]

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]

collects/macro-debugger/syntax-browser/display.ss

@@ -31,63 +31,30 @@
 ;;                       -> 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)

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)

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<%>

collects/macro-debugger/syntax-browser/prefs.ss

@@ -30,15 +30,24 @@
 
     ;; colors : (listof string)
     (define-notify colors
-      (new notify-box%
+      (new notify-box% (value the-colors)))
-           (value '("black" "red" "blue"
+
+    (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"))))
+    "orange" "salmon" "darkgoldenrod" "olive"))
-
-    (super-new)))
 
 (define syntax-prefs-base%
   (class* prefs-base% (config<%>)

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
+;; Use syntax-dummy, and extend pretty-print-remap-stylable to look inside.
-;;     (Symbols are useful: see pretty-print's style table)
+
-;;   - else : map it to a syntax-dummy object
+;; 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))
+             (make-id-syntax-dummy sym sym)
-             (suffix (syntax-e id) n))))))
+             (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)))

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 :
+;; FIXME: Need to disable printing of structs with custom-write property
-;;   syntax port partition (listof string) SuffixOption number
+
+;; 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
+    (syntax->datum/tables stx primary-partition colors suffix-option))
-                          (length 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

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])
+    (let ([tmp (unbox h)])
-      (set! h w)
+      (set-box! h (unbox w))
-      (set! w tmp))))
+      (set-box! w tmp))))
 
 ;; ----------------------------------------
 

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?

collects/repos-time-stamp/stamp.ss

@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "19nov2009")
+#lang scheme/base (provide stamp) (define stamp "23nov2009")

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)
+  (cond
+    [(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)]
-  (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)

collects/scheme/future.ss

@@ -0,0 +1,7 @@
+#lang scheme/base
+(require '#%futures)
+
+(provide future?
+         future
+         touch
+         processor-count)

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'
+Based on "Fast mergesort implementation based on half-copying merge algorithm",
-;; function, or precompiled versions with inlinable common comparison
+Cezary Juszczak, http://kicia.ift.uni.wroc.pl/algorytmy/mergesortpaper.pdf
-;; predicates) -- they are local macros so they're not left in the compiled
+Written in Scheme by Eli Barzilay.  (Note: the reason for the seemingly
-;; code.
+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
+The source uses macros to optimize some common cases (eg, no `getkey'
-;; that this module provide is then wrapped up by a keyworded version in
+function, or precompiled versions with inlinable common comparison
-;; "scheme/private/list.ss", and that's what everybody sees.  The wrapper is
+predicates) -- they are local macros so they're not left in the compiled
-;; doing these checks.
+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)
+(define-syntax-rule (i+ x y) (+ x y))
-  (begin
+(define-syntax-rule (i- x y) (- x y))
-    (define-syntax-rule (less? x y)
+(define-syntax-rule (i= x y) (= x y))
-      (if has-getkey? (*less? (getkey x) (getkey y)) (*less? x y)))
+(define-syntax-rule (i< x y) (< x y))
-    (define (merge-sorted! a b)
+(define-syntax-rule (i<= x y) (<= x y))
-      ;; r-a? for optimization -- is r connected to a?
+(define-syntax-rule (i>> x y) (arithmetic-shift x (- y)))
-      (define (loop r a b r-a?)
+(define-syntax-rule (vref v i) (vector-ref v i))
-        (if (less? (mcar b) (mcar a))
+(define-syntax-rule (vset! v i x) (vector-set! v i x))
-          (begin
+
-            (when r-a? (set-mcdr! r b))
+(define-syntax-rule (sort-internal-body v *<? n has-getkey? getkey)
-            (if (null? (mcdr b)) (set-mcdr! b a) (loop b a (mcdr b) #f)))
+  (let* ([n/2- (i>> n 1)] [n/2+ (i- n n/2-)])
-          ;; (car a) <= (car b)
+    (define-syntax-rule (<? x y)
-          (begin
+      (if has-getkey? (*<? (getkey x) (getkey y)) (*<? x y)))
-            (unless r-a? (set-mcdr! r a))
+    (define-syntax-rule (ref n) (vref v n))
-            (if (null? (mcdr a)) (set-mcdr! a b) (loop a (mcdr a) b #t)))))
+    (define-syntax-rule (set! n x) (vset! v n x))
-      (cond [(null? a) b]
+
-            [(null? b) a]
+    (define-syntax-rule (merge lo? A1 A2 B1 B2 C1)
-            [(less? (mcar b) (mcar a))
+      (let ([b2 B2])
-             (if (null? (mcdr b)) (set-mcdr! b a) (loop b a (mcdr b) #f))
+        (let loop ([a1 A1] [b1 B1] [c1 C1])
-             b]
+          (let ([x (ref a1)] [y (ref b1)])
-            [else ; (car a) <= (car b)
+            (if (if lo? (not (<? y x)) (<? x y))
-             (if (null? (mcdr a)) (set-mcdr! a b) (loop a (mcdr a) b #t))
+              (begin (set! c1 x)
-             a]))
+                     (let ([a1 (i+ a1 1)] [c1 (i+ c1 1)])
-    (let step ([n n])
+                       (when (i< c1 b1) (loop a1 b1 c1))))
-      (cond [(> n 3)
+              (begin (set! c1 y)
-             (let* (; let* not really needed with mzscheme's l->r eval
+                     (let ([b1 (i+ b1 1)] [c1 (i+ c1 1)])
-                    [j (quotient n 2)] [a (step j)] [b (step (- n j))])
+                       (if (i<= b2 b1)
-               (merge-sorted! a b))]
+                         (let loop ([a1 a1] [c1 c1])
-            ;; the following two cases are just explicit treatment of sublists
+                           (when (i< c1 b1)
-            ;; of length 2 and 3, could remove both (and use the above case for
+                             (set! c1 (ref a1))
-            ;; n>1) and it would still work, except a little slower
+                             (loop (i+ a1 1) (i+ c1 1))))
-            [(= n 3) (let ([p lst] [p1 (mcdr lst)] [p2 (mcdr (mcdr lst))])
+                         (loop a1 b1 c1)))))))))
-                       (let ([x (mcar p)] [y (mcar p1)] [z (mcar p2)])
+
-                         (set! lst (mcdr p2))
+    (define-syntax-rule (copying-insertionsort Alo Blo n)
-                         (cond [(less? y x) ; y x
+      (let iloop ([i 0] [A Alo])
-                                (cond [(less? z y) ; z y x
+        (when (i< i n)
-                                       (set-mcar! p  z)
+          (let ([ref-i (ref A)])
-                                       (set-mcar! p1 y)
+            (let jloop ([j (i+ Blo i)])
-                                       (set-mcar! p2 x)]
+              (let ([ref-j-1 (ref (i- j 1))])
-                                      [(less? z x) ; y z x
+                (if (and (i< Blo j) (<? ref-i ref-j-1))
-                                       (set-mcar! p  y)
+                  (begin (set! j ref-j-1) (jloop (i- j 1)))
-                                       (set-mcar! p1 z)
+                  (begin (set! j ref-i) (iloop (i+ i 1) (i+ A 1))))))))))
-                                       (set-mcar! p2 x)]
+
-                                      [else ; y x z
+    (define (copying-mergesort Alo Blo n)
-                                       (set-mcar! p  y)
+      (cond
-                                       (set-mcar! p1 x)])]
+        ;; n is never 0, smaller values are more frequent
-                               [(less? z x) ; z x y
+        [(i= n 1) (set! Blo (ref Alo))]
-                                (set-mcar! p  z)
+        [(i= n 2) (let ([x (ref Alo)] [y (ref (i+ Alo 1))])
-                                (set-mcar! p1 x)
+                    (if (<? y x)
-                                (set-mcar! p2 y)]
+                      (begin (set! Blo y) (set! (i+ Blo 1) x))
-                               [(less? z y) ; x z y
+                      (begin (set! Blo x) (set! (i+ Blo 1) y))))]
-                                (set-mcar! p1 z)
+        ;; insertion sort for small chunks (not much difference up to ~30)
-                                (set-mcar! p2 y)])
+        [(i< n 16) (copying-insertionsort Alo Blo n)]
-                         (set-mcdr! p2 '())
+        [else (let* ([n/2- (i>> n 1)] [n/2+ (i- n n/2-)])
-                         p))]
+                (let ([Amid1 (i+ Alo n/2-)]
-            [(= n 2) (let ([x (mcar lst)] [y (mcar (mcdr lst))] [p lst])
+                      [Amid2 (i+ Alo n/2+)]
-                       (set! lst (mcdr (mcdr lst)))
+                      [Bmid1 (i+ Blo n/2-)])
-                       (when (less? y x)
+                  (copying-mergesort Amid1 Bmid1 n/2+)
-                         (set-mcar! p y)
+                  (copying-mergesort Alo Amid2 n/2-)
-                         (set-mcar! (mcdr p) x))
+                  (merge #t Amid2 (i+ Alo n) Bmid1 (i+ Blo n) Blo)))]))
-                       (set-mcdr! (mcdr p) '())
+
-                       p)]
+    (let ([Alo 0] [Amid1 n/2-] [Amid2 n/2+] [Ahi n] [B1lo n])
-            [(= n 1) (let ([p lst])
+      (copying-mergesort Amid1 B1lo n/2+)
-                       (set! lst (mcdr lst))
+      (unless (zero? n/2-) (copying-mergesort Alo Amid2 n/2-))
-                       (set-mcdr! p '())
+      (merge #f B1lo (i+ B1lo n/2+) Amid2 Ahi Alo))))
-                       p)]
-            [else '()]))))
 
 (define sort-internals (make-hasheq))
 (define _
   (let ()
-    (define-syntax-rule (precomp less? more ...)
+    (define-syntax-rule (precomp <? more ...)
-      (let ([proc (lambda (lst n) (sort-internal-body lst less? n #f #f))])
+      (let ([proc (lambda (vec n) (sort-internal-body vec <? n #f #f))])
-        (hash-set! sort-internals less? proc)
+        (hash-set! sort-internals <? proc)
         (hash-set! sort-internals more proc) ...))
     (precomp < <=)
     (precomp > >=)
@@ -110,94 +121,99 @@
     (precomp string-ci<? string-ci<=?)
     (precomp keyword<?)))
 
-(define sort-internal
+(define-syntax sort-internal
-  (case-lambda
+  (syntax-rules ()
-    [(less? lst n)
+    [(_ <? vec n)
-     (let ([si (hash-ref sort-internals less? #f)])
+     (let ([si (hash-ref sort-internals <? #f)])
        (if si
          ;; use a precompiled function if found
-         (si lst n)
+         (si vec n)
          ;; otherwise, use the generic code
-         (let () (sort-internal-body lst less? n #f #f))))]
+         (let () (sort-internal-body vec <? n #f #f))))]
-    [(less? lst n getkey)
+    [(_ <? vec n getkey)
-     (sort-internal-body lst less? n #t getkey)]))
+     (let () (sort-internal-body vec <? n #t getkey))]))
 
-(define-syntax-rule (sort-body lst *less? has-getkey? getkey cache-keys?)
+(define-syntax-rule (sort-body lst *<? has-getkey? getkey cache-keys?)
   (let ([n (length lst)])
-    (define-syntax-rule (less? x y)
+    (define-syntax-rule (<? x y)
-      (if has-getkey? (*less? (getkey x) (getkey y)) (*less? x y)))
+      (if has-getkey? (*<? (getkey x) (getkey y)) (*<? x y)))
     (cond
       ;; trivial case
       [(= n 0) lst]
       ;; below we can assume a non-empty input list
       [cache-keys?
-       ;; decorate while converting to an mlist, and undecorate when going
+       ;; decorate while converting to a vector, and undecorate when going
        ;; back, always do this for consistency
-       (let (;; list -> decorated-mlist
+       (let ([vec (make-vector (+ n (ceiling (/ n 2))))])
-             [mlst (let ([x (car lst)]) (mcons (cons (getkey x) x) null))])
+         ;; list -> decorated-vector
-         (let loop ([last mlst] [lst (cdr lst)])
+         (let loop ([i 0] [lst lst])
            (when (pair? lst)
-             (let ([new (let ([x (car lst)]) (mcons (cons (getkey x) x) null))])
+             (let ([x (car lst)])
-               (set-mcdr! last new)
+               (vector-set! vec i (cons (getkey x) x))
-               (loop new (cdr lst)))))
+               (loop (add1 i) (cdr lst)))))
-         ;; decorated-mlist -> list
+         ;; sort
-         (let loop ([r (sort-internal *less? mlst n car)])
+         (sort-internal *<? vec n car)
-           (if (null? r) r (cons (cdr (mcar r)) (loop (mcdr r))))))]
+         ;; decorated-vector -> 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 (<? (car next) last))
                   (loop (car next) (cdr next)))))
        lst]
       ;; below we can assume an unsorted list
       ;; inlined case, for optimization of short lists
-      [(< n 3)
+      [(<= n 3)
        (if (= n 2)
          ;; (because of the above test, we can assume that the input is
          ;; unsorted)
          (list (cadr lst) (car lst))
          (let ([a (car lst)] [b (cadr lst)] [c (caddr lst)])
            ;; General note: we need a stable sort, so we should always compare
-           ;; (less? later-item earlier-item) since it gives more information.
+           ;; (<? later-item earlier-item) since it gives more information.  A
-           ;; A good way to see that we have good code is to check that each
+           ;; good way to see that we have good code is to check that each
            ;; permutation appears exactly once.  This means that n=4 will have
            ;; 23 cases, so don't bother.  (Homework: write a macro to generate
            ;; code for a specific N.  Bonus: prove correctness.  Extra bonus:
            ;; prove optimal solution.  Extra extra bonus: prove optimal
            ;; solution exists, extract macro from proof.)
            (let ([a (car lst)] [b (cadr lst)] [c (caddr lst)])
-             (if (less? b a)
+             (if (<? b a)
                ;; b<a
-               (if (less? c b)
+               (if (<? c b)
                  (list c b a)
                  ;; b<a, b<=c
-                 (if (less? c a) (list b c a) (list b a c)))
+                 (if (<? c a) (list b c a) (list b a c)))
                ;; a<=b, so c<b (b<=c is impossible due to above test)
-               (if (less? c a) (list c a b) (list a c b))))))]
+               (if (<? c a) (list c a b) (list a c b))))))]
-      [else (let (;; list -> mlist
+      [else (let ([vec (make-vector (+ n (ceiling (/ n 2))))])
-                  [mlst (mcons (car lst) null)])
+              ;; list -> vector
-              (let loop ([last mlst] [lst (cdr lst)])
+              (let loop ([i 0] [lst lst])
                 (when (pair? lst)
-                  (let ([new (mcons (car lst) null)])
+                  (vector-set! vec i (car lst))
-                    (set-mcdr! last new)
+                  (loop (add1 i) (cdr lst))))
-                    (loop new (cdr lst)))))
+              ;; sort
-              ;; mlist -> list
+              (if getkey
-              (let loop ([r (if getkey
+                (sort-internal *<? vec n getkey)
-                              (sort-internal *less? mlst n getkey)
+                (sort-internal *<? vec n))
-                              (sort-internal *less? mlst n))])
+              ;; vector -> list
-                (if (null? r) r (cons (mcar r) (loop (mcdr r))))))])))
+              (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 <?) (sort-body lst <? #f #f #f)]
-  [(lst less? getkey)
+  [(lst <? getkey)
    (if (and getkey (not (eq? values getkey)))
-     (sort lst less? getkey #f) (sort lst less?))]
+     (sort lst <? getkey #f) (sort lst <?))]
-  [(lst less? getkey cache-keys?)
+  [(lst <? getkey cache-keys?)
    (if (and getkey (not (eq? values getkey)))
-     (sort-body lst less? #t getkey cache-keys?) (sort lst less?))])
+     (sort-body lst <? #t getkey cache-keys?) (sort lst <?))])
 
 )))

collects/scheme/vector.ss

@@ -20,19 +20,31 @@
   (unless (exact-nonnegative-integer? start)
     (raise-type-error 'vector-copy "non-negative exact integer" 1 start))
   (let ([len (vector-length v)])
+    (cond
+      [(= len 0)
+       (unless (= start 0)
+         (raise-mismatch-error 'vector-copy
+                               "start index must be 0 for empty vector, got "
+                               start))
+       (unless (= end 0)
+         (raise-mismatch-error 'vector-copy
+                               "end index must be 0 for empty vector, got "
+                               end))
+       (vector)]
+      [else
        (unless (and (<= 0 start) (< start len))
          (raise-mismatch-error
           'vector-copy
-       (format "start index ~e out of range [~e, ~e] for vector ~e"
+          (format "start index ~e out of range [~e, ~e] for vector: "
-               start 0 len v)
+                  start 0 len)
           v))
        (unless (and (<= start end) (<= end len))
          (raise-mismatch-error
           'vector-copy
-       (format "end index ~e out of range [~e, ~e] for vector ~e"
+          (format "end index ~e out of range [~e, ~e] for vector: "
-               end start len v)
+                  end start len)
           v))
-    (vector-copy* v start end)))
+       (vector-copy* v start end)])))
 
 ;; do vector-map, putting the result in `target'
 ;; length is passed to save the computation

collects/scribble/html-render.ss

@@ -359,7 +359,8 @@
          `((a ([href ,(dest->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)
+                 (body ([id ,(or (extract-part-body-id d ri)
-                                 "scribble-plt-scheme-org")))
+                                 "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))))

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("<style>mynoscript { display:none; }</style>");
+
+// Interactions ---------------------------------------------------------------
+
 function DoSearchKey(event, field, ver, top_path) {
   var val = field.value;
   if (event && event.keyCode == 13) {
@@ -62,6 +104,34 @@ function TocviewToggle(glyph,id) {
   glyph.innerHTML = expand ? "&#9660;" : "&#9658;";
 }
 
-// `noscript' is problematic in some browsers (always renders as a
+// Page Init ------------------------------------------------------------------
-// block), use this hack instead (does not always work!)
+
-// document.write("<style>mynoscript { display:none; }</style>");
+// 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<on_load_funcs.length; i++) on_load_funcs[i]();
+};
+
+var cur_plt_lang = GetArgFromURL(location,"lang");
+
+function PropagateLangInLink(a) {
+  // the attribute's value doesn't matter
+  if (cur_plt_lang
+      && a.attributes["pltdoc"] && a.attributes["pltdoc"].value != ""
+      && !GetArgFromURL(a,"lang"))
+    SetArgInURL(a, "lang", cur_plt_lang);
+}
+
+AddOnLoad(function(){
+    if (!cur_plt_lang) return;
+    var indicator = document.getElementById("langindicator");
+    if (indicator) {
+      indicator.innerHTML = cur_plt_lang;
+      indicator.style.display = "block";
+    }
+    var links = document.getElementsByTagName("a");
+    for (var i=0; i<links.length; i++) PropagateLangInLink(links[i]);
+  });

collects/scribble/scribble.css

@@ -119,6 +119,18 @@ table td {
   vertical-align: middle;
 }
 
+#langindicator {
+  position: fixed;
+  background-color: #c6f;
+  color: #000;
+  font-family: monospace;
+  font-weight: bold;
+  padding: 2px 10px;
+  display: none;
+  right: 0;
+  bottom: 0;
+}
+
 /* ---------------------------------------- */
 /* Version */
 

collects/scribblings/futures/futures.scrbl

@@ -0,0 +1,41 @@
+#lang scribble/doc
+
+@title{@bold{Futures}: Fine-grained Parallelism}
+
+@; ----------------------------------------------------------------------
+
+@(require scribble/manual
+          scribble/urls
+          scribble/struct
+          (for-label scheme/base
+                     scheme/contract
+                     scheme/future))
+
+@; ----------------------------------------------------------------------
+
+PLT's parallel-future support is only enabled if you pass
+@DFlag{enable-futures} to @exec{configure} when you build PLT (and
+that build currently only works with @exec{mzscheme}, not with
+@exec{mred}). When parallel-future support is not enabled,
+@scheme[future] just remembers the given thunk to call sequentially
+on a later @scheme[touch].
+
+@defmodule[scheme/future]{}
+
+@defproc[(future [thunk (-> 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.
+}
+

collects/scribblings/futures/info.ss

@@ -0,0 +1,3 @@
+#lang setup/infotab
+
+(define scribblings '(("futures.scrbl" ())))

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.
 

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

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 init_q = GetArgFromURL(location,"q");
-    var paramstrs = location.search.substring(1).split(/[;&]/);
+  if (init_q && init_q != "") query.value = init_q;
-    for (var i=0; i<paramstrs.length; i++) {
-      var param = paramstrs[i].split(/=/);
-      // ignores an empty "q=" (param.length will be 1)
-      if (param.length == 2 && param[0] == "q") {
-        query.value = unescape(param[1]);
-        break;
-      }
-    }
-  }
   ContextFilter();
   DoSearch();
   query.focus();
@@ -342,8 +333,15 @@ function UrlToManual(url) {
 //   "L:scheme" (no exact matches except for the `scheme' module)
 //   "L:schem" (only module names that match `schem')
 
+// Additional "hidden" operators:
+//   "A:{ foo bar }" -- an `and' query
+//   "O:{ foo bar }" -- an `or' query
+//   "Q:foo" -- stands for just "foo", useful for quoting Q:} inside the above
+// Note: they're "hidden" because the syntax might change, and it's intended
+// mostly for context queries.
+
 function CompileTerm(term) {
-  var op = ((term.search(/^[LMT]:/) == 0) && term.substring(0,1));
+  var op = ((term.search(/^[NLMTQ]:/) == 0) && term.substring(0,1));
   if (op) term = term.substring(2);
   term = term.toLowerCase();
   switch (op) {
@@ -370,6 +368,7 @@ function CompileTerm(term) {
       else if (x[1].search(/\/index\.html$/) > 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<words.length; i++)
@@ -387,6 +386,51 @@ function CompileTerm(term) {
   }
 }
 
+function CompileAndTerms(preds) {
+  return function(x) {
+    var r = C_max;
+    for (var i=0; i<preds.length; i++) {
+      r = Math.min(r, preds[i](x));
+      if (r <= C_min) return r;
+    }
+    return r;
+  };
+}
+
+function CompileOrTerms(preds) {
+  return function(x) {
+    var r = C_min;
+    for (var i=0; i<preds.length; i++) {
+      r = Math.max(r, preds[i](x));
+      if (r >= 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(/ /);
+  var preds = (term=="") ? [] : CompileTerms(term.split(/ /), false);
-  for (var i=0; i<preds.length; i++) preds[i] = CompileTerm(preds[i]);
   if (preds.length == 0) {
     var ret = is_pre ? [0,data] : [0,[]];
     if (K) { K(ret); return killer; }
@@ -439,20 +482,21 @@ function Search(data, term, is_pre, K) {
       var r, min = C_max, max = C_min;
       for (var j=0; j<preds.length; j++) {
         r = preds[j](data[i]); min = Math.min(r, min); max = Math.max(r, max);
+        if (min <= C_min) break; // get out if it's hopeless
       }
       if (max >= 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<data.length) t = setTimeout(DoChunk,15);
+    if (i<data.length) t = setTimeout(DoChunk,5);
     else {
       r = [exacts.length, exacts.concat(matches).concat(wordmatches)];
       if (K) K(r); else return r;
     }
   };
   if (!K) return DoChunk();
-  else { progress(0); t = setTimeout(DoChunk,15); return killer; }
+  else { progress(0); t = setTimeout(DoChunk,5); return killer; }
 }
 
 function GetContextHTML() {
@@ -555,6 +599,7 @@ function UpdateResults() {
   if (first_search_result < 0 ||
       first_search_result >= search_results.length)
     first_search_result = 0;
+  var link_lang = (cur_plt_lang && ("?lang="+escape(cur_plt_lang)));
   for (var i=0; i<result_links.length; i++) {
     var n = i + first_search_result;
     if (n < search_results.length) {
@@ -593,9 +638,16 @@ function UpdateResults() {
       }
       if (note)
         note = '&nbsp;&nbsp;<span class="smaller">' + note + '</span>';
+      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 =
-        '<a href="' + UncompactUrl(res[1]) + '"'
+        '<a href="' + href + '" class="indexlink" tabIndex="2">'
-         +' class="indexlink" tabIndex="2">'
         + UncompactHtml(res[2]) + '</a>' + (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);
 
 })();

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
-                 (make-style style
+                style
                 (list (make-attributes
+                       `(,@(if (eq? root 'user)
                              `([onclick
                                 . ,(format "return GotoPLTRoot(\"~a\", \"~a\");"
-                                                  (version) path)]))))
+                                           (version) path)])
-                 style))
+                             `())
+                         ;; 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))))

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)

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
+                (string-join (map symbol->string (available-mzscheme-variants))
-                       (map (lambda (s) (format " ~a" s))
+                             ", "))
-                            (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
+    (append* (specific-collections)
-           (specific-collections)
+             (for/list ([x (in-list (archives))])
-           (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)))
+                       (current-target-plt-directory-getter)))))
-                (archives))))
 
   ;; specific-planet-dir ::=
   ;;    - (list path[directory] string[owner] string[package-name] (listof string[extra package path]) Nat[maj] Nat[min]), or
@@ -854,8 +851,9 @@
                   kind mzlns))]
               [(and (or (not mzlls) (= (length mzlns) (length mzlls)))
                     (or (not mzlfs) (= (length mzlns) (length mzlfs))))
-               (for-each
+               (for ([mzln (in-list mzlns)]
-                (lambda (mzln mzll mzlf)
+                     [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)
@@ -880,23 +878,17 @@
                       (or mzlf
                           (if (cc-collection cc)
                             (list "-l-" (string-append
-                                          (apply string-append
+                                         (string-append*
-                                                 (map (lambda (s)
+                                          (map (lambda (s) (format "~a/" 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))))
+                      aux))))]
-                mzlns
-                (or mzlls (map (lambda (_) #f) mzlns))
-                (or mzlfs (map (lambda (_) #f) mzlns)))]
               [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"

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

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)

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))))

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))))))

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)))

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 ()

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 "match/plt-match-tests.ss"]
- ;   ;; [require "stepper/automatic-tests.ss" (lib "scheme/base")]
+    ;; [require "stepper/automatic-tests.ss" (lib "scheme/base")]
     [require "lazy/main.ss"]
-   ; [require "scribble/main.ss"]
+    [require "scribble/main.ss"]
-    ;[require "net/main.ss"]
+    [require "net/main.ss"]
-;    [require "file/main.ss"]
+    [require "file/main.ss"]
- ;   [require "profile/main.ss"]
+    [require "profile/main.ss"]
     ))
 
 (require scheme/runtime-path)

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.
+In this syntax, the @scheme['messages] paths are relative to the
-All the paths in @scheme['paths] are relative to @scheme['host-root] (other than @scheme['host-root] obviously.)
+@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].
 

doc/release-notes/drscheme/HISTORY.txt

@@ -1,3 +1,9 @@
+------------------------------
+        Version 4.2.3
+------------------------------
+
+  . minor bug fixes
+
 ------------------------------
         Version 4.2.2
 ------------------------------

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

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

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

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.

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]
 

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@
 

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"

src/mzscheme/gc2/gc2.h

@@ -2,11 +2,13 @@
 #ifndef __mzscheme_gc_2__
 #define __mzscheme_gc_2__
 
+#ifndef GC2_JUST_MACROS
 # ifdef INCLUDE_WITHOUT_PATHS
 #  include "schthread.h"
 # else
 #  include "../include/schthread.h"
 # endif
+#endif
 
 /***************************************************************************/
 /***   See README for a general overview of the interface architecture.  ***/
@@ -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.
 */
 
 

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;

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 /**/

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,21 +216,38 @@ 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
+  struct Scheme_Logger *scheme_main_logger_;
-  pthread_cond_t worker_can_continue_cv_;
-  void *jit_future_storage_[2];
-#endif
 } Thread_Local_Variables;
 
 #if defined(IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS)
 /* Using Pthread getspecific() */
 # include <pthread.h>
 MZ_EXTERN pthread_key_t scheme_thread_local_key;
+# 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: */
 MZ_EXTERN THREAD_LOCAL Thread_Local_Variables scheme_thread_locals;
 # define scheme_get_thread_local_variables() (&scheme_thread_locals)
@@ -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 scheme_main_logger XOA (scheme_get_thread_local_variables()->scheme_main_logger_)
-#define jit_future_storage XOA (scheme_get_thread_local_variables()->jit_future_storage_)
 
 /* **************************************** */
 

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            */
 

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) \

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;

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;

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);

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               */
 /*========================================================================*/

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;
+THREAD_LOCAL_DECL(static Scheme_Logger *scheme_main_logger);
-static void init_logger_config();
 
 /* 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,8 +333,13 @@ 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++];
+            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)
 {

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) {

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

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 <stdio.h>
 
-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;
+  unsigned long alloc_retval;
-  void *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_t *prev;
-  struct future *next;
+  struct future_t *next;
-  struct future *next_waiting_atomic;
+
+  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
+# include "jit_ts_protos.h"
-#define SIG_INT_POBJ_OBJ_OBJ 17			//int -> Scheme_Object** -> Scheme_Object* -> Scheme_Object* 
+
-#define SIG_PVOID_PVOID_PVOID	18		//void* -> void* -> void*
+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 void scheme_rtcall_void_void_3args(const char *who, int src_type, prim_void_void_3args_t f);
-extern int rtcall_alloc_void_pvoid(void (*f)(), void **retval);
+extern unsigned long scheme_rtcall_alloc_void_pvoid(const char *who, int src_type, prim_alloc_void_pvoid_t f);
-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);
 
 #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();

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)))

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

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); \
+}

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;
+}

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);

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;
+  }

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)

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))

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->arg_s0);
-  gcMARK(f->prim_data.argv);
+  gcMARK(f->arg_S0);
-  gcMARK(f->prim_data.retval);
+  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->arg_s0);
-  gcFIXUP(f->prim_data.argv);
+  gcFIXUP(f->arg_S0);
-  gcFIXUP(f->prim_data.retval);
+  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 */
 
 /**********************************************************************/

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->arg_s0);
-  gcMARK(f->prim_data.argv);
+  gcMARK(f->arg_S0);
-  gcMARK(f->prim_data.retval);
+  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;
 
 /**********************************************************************/

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;

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)

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) {

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);
 

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;

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
+void scheme_init_os_thread() XFORM_SKIP_PROC
-START_XFORM_SKIP;
-#endif
-void scheme_init_os_thread()
 {
 #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
+void scheme_register_static(void *ptr, long size) XFORM_SKIP_PROC
-START_XFORM_SKIP;
-#endif
-
-void scheme_register_static(void *ptr, long size)
 {
 #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;

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) {

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,

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
 
 /**********************************************************************/

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 <windows.h>
+/* Environment Variables                                               */
-static char *mzGETENV(char *s)
+/***********************************************************************/
-{
-  int sz, got;
-  char *res;
 
-  sz = GetEnvironmentVariable(s, NULL, 0);
+#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
-  if (!sz)
+static char* clone_str_with_gc(const char* buffer) {
-    return NULL;
+  int length;
-  res = scheme_malloc_atomic(sz);
+  char *newbuffer;
-  got = GetEnvironmentVariable(s, res, sz);
+  length = strlen(buffer);
-  if (got < sz)
+  newbuffer = scheme_malloc_atomic(length+1);
-    res[got] = 0;
+  memcpy(newbuffer, buffer, length+1);
-  return res;
+  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)
 {
@@ -2040,103 +2091,141 @@ scheme_init_getenv(void)
     }
     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 <windows.h>
+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])
+  if (!SCHEME_CHAR_STRINGP(argv[0]) || scheme_any_string_has_null(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
-  if (putenv_str_table) {
+  value = getenv(name);
-    s = (char *)scheme_hash_get(putenv_str_table, (Scheme_Object *)SCHEME_BYTE_STR_VAL(argv[0]));
+# endif
-    /* If found, skip over the `=' in the table: */
+#else
-    if (s)
+  {
-      s += SCHEME_BYTE_STRTAG_VAL(bs) + 1;
+    Scheme_Object *hash_value;
-  } else
+    hash_value = putenv_str_table_get(name); 
-    s = NULL;
+    return hash_value ? hash_value : scheme_false;
+  }
 #endif
 
-  if (s)
+  return value ? scheme_make_locale_string(value) : scheme_false;
-    return scheme_make_locale_string(s);
+}
 
-  return scheme_false;
+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[])
 {
-  char *s, *var, *val;
+  Scheme_Object *varbs;
-  long varlen, vallen;
+  Scheme_Object *valbs;
-  Scheme_Object *bs;
+  char *var;
+  char *val;
+  int rc = 0;
 
-  if (!SCHEME_CHAR_STRINGP(argv[0])
+  if (!SCHEME_CHAR_STRINGP(argv[0]) || scheme_any_string_has_null(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])
+  if (!SCHEME_CHAR_STRINGP(argv[1]) || scheme_any_string_has_null(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]);
+  varbs = scheme_char_string_to_byte_string_locale(argv[0]);
-  var = SCHEME_BYTE_STR_VAL(bs);
+  var = SCHEME_BYTE_STR_VAL(varbs);
 
-  bs = scheme_char_string_to_byte_string_locale(argv[1]);
+  valbs = scheme_char_string_to_byte_string_locale(argv[1]);
-  val = SCHEME_BYTE_STR_VAL(bs);
+  val = SCHEME_BYTE_STR_VAL(valbs);
-
-  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);
-    }
-  }
-#endif
-
-  if (!putenv_str_table)
-    putenv_str_table = scheme_make_hash_table(SCHEME_hash_string);
-
-  scheme_hash_set(putenv_str_table, (Scheme_Object *)var, (Scheme_Object *)s);
 
 #ifdef GETENV_FUNCTION
-  return mzPUTENV(var, val, s) ? scheme_false : scheme_true;
+# ifdef DOS_FILE_SYSTEM
+  rc = !SetEnvironmentVariable(var, val);
 # else
-  return scheme_true;
+  rc = sch_unix_putenv(var, val, SCHEME_BYTE_STRLEN_VAL(varbs), SCHEME_BYTE_STRLEN_VAL(valbs));
 # endif
+#else
+  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[])

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();
 }
 

src/mzscheme/src/thread.c

@@ -1550,13 +1550,10 @@ 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)
+  XFORM_SKIP_PROC
 /* This function must not allocate. */
 {
   Scheme_Custodian *m;
@@ -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_message(logger, SCHEME_LOG_DEBUG, buf, buflen, NULL);
-                       SCHEME_LOG_DEBUG,
-                       buf, buflen,
-                       NULL);
   }
 
 }