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

sync branch to trunk

Browse Source 
svn: r17046
This commit is contained in:
Sam Tobin-Hochstadt 2009-11-24 18:47:48 +00:00
commit 1efedeb758
88 changed files with 3755 additions and 2041 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/compiler/embed-unit.ss
View File

@ -1008,10 +1008,12 @@
mac-mred-collects-path-adjust
values)
collects-path)))
(define word-size (if (fixnum? (expt 2 32)) 8 4))
(unless (or long-cmdline?
((apply + (length cmdline) (map (lambda (s)
(bytes-length (string->bytes/utf-8 s)))
cmdline)) . < . 50))
((apply +
(map (lambda (s)
(+ word-size (bytes-length (string->bytes/utf-8 s))))
cmdline)) . < . 60))
(error 'create-embedding-executable "command line too long"))
(check-collects-path 'create-embedding-executable collects-path collects-path-bytes)
(let ([exe (find-exe mred? variant)])

126
collects/compiler/private/xform.ss
View File

@ -585,20 +585,22 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define per-block-push? #t)
(define gc-var-stack-through-table?
(define gc-var-stack-mode
(ormap (lambda (e)
(and (pragma? e)
(regexp-match #rx"GC_VARIABLE_STACK_THOUGH_TABLE" (pragma-s e))))
e-raw))
(define gc-var-stack-through-thread-local?
(ormap (lambda (e)
(and (tok? e)
(eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL)))
e-raw))
(define gc-var-stack-through-getspecific?
(ormap (lambda (e)
(and (tok? e)
(eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_GETSPECIFIC)))
(cond
[(and (pragma? e)
(regexp-match #rx"GC_VARIABLE_STACK_THOUGH_TABLE" (pragma-s e)))
'table]
[(and (tok? e)
(eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL))
'thread-local]
[(and (tok? e)
(eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_GETSPECIFIC))
'getspecific]
[(and (tok? e)
(eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_FUNCTION))
'function]
[else #f]))
e-raw))
;; The code produced by xform uses a number of macros. These macros
@ -608,12 +610,14 @@
(when (and pgc? (not precompiled-header))
;; Setup GC_variable_stack macro
(printf (cond
[gc-var-stack-through-table?
(printf (case gc-var-stack-mode
[(table)
"#define GC_VARIABLE_STACK (scheme_extension_table->GC_variable_stack)~n"]
[gc-var-stack-through-getspecific?
[(getspecific)
"#define GC_VARIABLE_STACK (((Thread_Local_Variables *)pthread_getspecific(scheme_thread_local_key))->GC_variable_stack_)~n"]
[gc-var-stack-through-thread-local?
[(function)
"#define GC_VARIABLE_STACK ((scheme_get_thread_local_variables())->GC_variable_stack_)~n"]
[(thread-local)
"#define GC_VARIABLE_STACK ((&scheme_thread_locals)->GC_variable_stack_)~n"]
[else "#define GC_VARIABLE_STACK GC_variable_stack~n"]))
@ -726,6 +730,7 @@
(printf "#define XFORM_END_SKIP /**/~n")
(printf "#define XFORM_START_SUSPEND /**/~n")
(printf "#define XFORM_END_SUSPEND /**/~n")
(printf "#define XFORM_SKIP_PROC /**/~n")
;; For avoiding warnings:
(printf "#define XFORM_OK_PLUS +~n")
(printf "#define XFORM_OK_MINUS -~n")
@ -1075,8 +1080,7 @@
(set! non-gcing-functions (hash-table-copy (list-ref l 7)))
(set! gc-var-stack-through-thread-local? (list-ref l 8))
(set! gc-var-stack-through-getspecific? (list-ref l 9))))))
(set! gc-var-stack-mode (list-ref l 8))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Pretty-printing output
@ -1519,43 +1523,45 @@
null
e))))]
[(function? e)
(let ([name (register-proto-information e)])
(when (eq? (tok-n (car e)) '__xform_nongcing__)
(hash-table-put! non-gcing-functions name #t))
(when show-info? (printf "/* FUNCTION ~a */~n" name))
(if (or (positive? suspend-xform)
(not pgc?)
(and where
(regexp-match re:h where)
(let loop ([e e][prev #f])
(cond
[(null? e) #t]
[(and (eq? '|::| (tok-n (car e)))
prev
(eq? (tok-n prev) (tok-n (cadr e))))
;; inline constructor: need to convert
#f]
[else (loop (cdr e) (car e))]))))
;; Not pgc, xform suspended,
;; or still in headers and probably a simple inlined function
(let ([palm-static? (and palm? (eq? 'static (tok-n (car e))))])
(when palm?
(fprintf map-port "(~aimpl ~s)~n"
(if palm-static? "s" "")
name)
(call-graph name e))
(append
(if palm-static?
;; Need to make sure prototype is there for section
(add-segment-label
name
(let loop ([e e])
(if (braces? (car e))
(list (make-tok semi #f #f))
(cons (car e) (loop (cdr e))))))
null)
e))
(convert-function e name)))]
(if (skip-function? e)
e
(let ([name (register-proto-information e)])
(when (eq? (tok-n (car e)) '__xform_nongcing__)
(hash-table-put! non-gcing-functions name #t))
(when show-info? (printf "/* FUNCTION ~a */~n" name))
(if (or (positive? suspend-xform)
(not pgc?)
(and where
(regexp-match re:h where)
(let loop ([e e][prev #f])
(cond
[(null? e) #t]
[(and (eq? '|::| (tok-n (car e)))
prev
(eq? (tok-n prev) (tok-n (cadr e))))
;; inline constructor: need to convert
#f]
[else (loop (cdr e) (car e))]))))
;; Not pgc, xform suspended,
;; or still in headers and probably a simple inlined function
(let ([palm-static? (and palm? (eq? 'static (tok-n (car e))))])
(when palm?
(fprintf map-port "(~aimpl ~s)~n"
(if palm-static? "s" "")
name)
(call-graph name e))
(append
(if palm-static?
;; Need to make sure prototype is there for section
(add-segment-label
name
(let loop ([e e])
(if (braces? (car e))
(list (make-tok semi #f #f))
(cons (car e) (loop (cdr e))))))
null)
e))
(convert-function e name))))]
[(var-decl? e)
(when show-info? (printf "/* VAR */~n"))
(if (and can-drop-vars?
@ -1611,6 +1617,7 @@
(define (threadlocal-decl? e)
(and (pair? e)
(or (eq? 'XFORM_GC_VARIABLE_STACK_THROUGH_GETSPECIFIC (tok-n (car e)))
(eq? 'XFORM_GC_VARIABLE_STACK_THROUGH_FUNCTION (tok-n (car e)))
(eq? 'XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL (tok-n (car e))))))
(define (access-modifier? e)
@ -1705,12 +1712,16 @@
(and (braces? v)
(let ([v (list-ref e (sub1 ll))])
(or (parens? v)
(eq? (tok-n v) 'XFORM_SKIP_PROC)
;; `const' can appear between the arg parens
;; and the function body; this happens in the
;; OS X headers
(and (eq? 'const (tok-n v))
(positive? (sub1 ll))
(parens? (list-ref e (- ll 2))))))))))))
(define (skip-function? e)
(ormap (lambda (v) (eq? (tok-n v) 'XFORM_SKIP_PROC)) e))
;; Recognize a top-level variable declaration:
(define (var-decl? e)
@ -4003,8 +4014,7 @@
(marshall non-pointer-types)
(marshall struct-defs)
non-gcing-functions
gc-var-stack-through-thread-local?
gc-var-stack-through-getspecific?)])
(list 'quote gc-var-stack-mode))])
(with-output-to-file (change-suffix file-out #".zo")
(lambda ()
(let ([orig (current-namespace)])

4
collects/deinprogramm/DMdA.ss
View File

@ -1006,8 +1006,8 @@
(stepper-syntax-property
(check-expect-maker stx #'check-property-error #'?prop '()
'comes-from-check-property)
'stepper-skip-completely
#t))
'stepper-replace
#'#t))
(_ (raise-syntax-error #f "`check-property' erwartet einen einzelnen Operanden"
stx))))

4
collects/deinprogramm/convert-explicit.scm
View File

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

4
collects/dynext/compile-unit.ss
View File

@ -73,8 +73,8 @@
(define gcc-compile-flags (append '("-c" "-O2" "-fPIC")
(case (string->symbol (path->string (system-library-subpath #f)))
[(ppc-macosx i386-macosx x86_64-macosx) '("-fno-common")]
[(ppc-darwin) '("-fno-common")]
[(i386-macosx i386-darwin) '("-m32" "-fno-common")]
[(ppc-macosx ppc-darwin x86_64-macosx x86_64-darwin) '("-fno-common")]
[(win32\\i386) '("-DAS_MSVC_EXTENSION")]
[else null])
gcc-cpp-flags))

18
collects/framework/private/main.ss
View File

@ -76,13 +76,17 @@
'("local")
(λ (x) (and (list? x) (andmap string? x))))
(preferences:set-default 'framework:square-bracket:letrec
'("let"
"let*" "let-values" "let*-values"
"let-syntax" "let-struct" "let-syntaxes"
"letrec"
"letrec-syntaxes" "letrec-syntaxes+values" "letrec-values"
"parameterize"
"with-syntax")
(let ([fors '("for" "for/list" "for/hash" "for/and" "for/or" "for/first" "for/last")])
(append fors
(map (λ (x) (regexp-replace #rx"for" x "for*"))
fors)
'("let"
"let*" "let-values" "let*-values"
"let-syntax" "let-struct" "let-syntaxes"
"letrec"
"letrec-syntaxes" "letrec-syntaxes+values" "letrec-values"
"parameterize"
"with-syntax")))
(λ (x) (and (list? x) (andmap string? x))))
(preferences:set-default 'framework:white-on-black? #f boolean?)

21
collects/framework/private/text.ss
View File

@ -451,15 +451,18 @@ WARNING: printf is rebound in the body of the unit to always
(super on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret)
(when before
(let-values ([(view-x view-y view-width view-height)
(let ([b1 (box 0)]
[b2 (box 0)]
[b3 (box 0)]
[b4 (box 0)])
(send (get-admin) get-view b1 b2 b3 b4)
(values (unbox b1)
(unbox b2)
(unbox b3)
(unbox b4)))])
(let ([admin (get-admin)])
(if admin
(let ([b1 (box 0)]
[b2 (box 0)]
[b3 (box 0)]
[b4 (box 0)])
(send admin get-view b1 b2 b3 b4)
(values (unbox b1)
(unbox b2)
(unbox b3)
(unbox b4)))
(values left-margin top-margin right-margin bottom-margin)))])
(let* ([old-pen (send dc get-pen)]
[old-brush (send dc get-brush)]
[old-smoothing (send dc get-smoothing)]

9
collects/games/jewel/jewel.scm
View File

@ -1431,7 +1431,12 @@
(counter 0)
)
;; This shouldnt do anything, but it fixes drawing in
;; Snow Leopard. Bug in the game or in Snow Leopard?
(glEnable GL_LIGHT2)
(glDisable GL_LIGHT2)
(glEnable GL_BLEND)
(do ((iy 0 (+ iy 1))) ((= iy ey))
(set! x (* (- t) (- (/ ex 2.0) 0.5)))
@ -1461,7 +1466,7 @@
(set! xt nx)
(set! yt ny)
(set! zt nz)
(if (and (equal? gamestate 'PLAYING)
(= cposx ix) (= cposy iy))
(begin

5
collects/lang/htdp-langs.ss
View File

@ -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]

2
collects/macro-debugger/model/reductions.ss
View File

@ -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]

73
collects/macro-debugger/syntax-browser/display.ss
View File

@ -28,66 +28,33 @@
;; FIXME: assumes text never moves
;; print-syntax-to-editor : syntax text controller<%> config number number
;; -> display<%>
;; -> display<%>
(define (print-syntax-to-editor stx text controller config columns insertion-point)
(begin-with-definitions
(define **entry (now))
(define output-port (open-output-string/count-lines))
(define range
(pretty-print-syntax stx output-port
(send: controller controller<%> get-primary-partition)
(send: config config<%> get-colors)
(length (send: config config<%> get-colors))
(send: config config<%> get-suffix-option)
columns))
(define **range (now))
(define output-string (get-output-string output-port))
(define output-length (sub1 (string-length output-string))) ;; skip final newline
(fixup-parentheses output-string range)
(define **fixup (now))
(send text begin-edit-sequence #f)
(send text insert output-length output-string insertion-point)
(define display
(new display%
(text text)
(controller controller)
(config config)
(range range)
(base-style (standard-font text config))
(start-position insertion-point)
(end-position (+ insertion-point output-length))))
(send text begin-edit-sequence #f)
(define **editing (now))
(send text insert output-length output-string insertion-point)
(define **inserted (now))
(add-clickbacks text range controller insertion-point)
(define **clickbacks (now))
(send display initialize)
(define **colorize (now))
(send text end-edit-sequence)
(define **finished (now))
(when TIME-PRINTING?
(eprintf "** pretty-print: ~s\n" (- **range **entry))
(eprintf "** fixup, begin-edit-sequence: ~s\n" (- **editing **range))
(eprintf "** > insert: ~s\n" (- **inserted **editing))
(eprintf "** > clickback: ~s\n" (- **clickbacks **inserted))
(eprintf "** > colorize: ~s\n" (- **colorize **clickbacks))
(eprintf "** finish: ~s\n" (- **finished **colorize))
(eprintf "** total: ~s\n" (- **finished **entry))
(eprintf "\n"))
display))
;; add-clickbacks : text% range% controller<%> number -> void
(define (add-clickbacks text range controller insertion-point)
(for ([range (send: range range<%> all-ranges)])
(let ([stx (range-obj range)]
[start (range-start range)]
[end (range-end range)])
(send text set-clickback (+ insertion-point start) (+ insertion-point end)
(lambda (_1 _2 _3)
(send: controller selection-manager<%>
set-selected-syntax stx))))))
(define (standard-font text config)
(code-style text (send: config config<%> get-syntax-font-size)))
;; display%
(define display%
(class* object% (display<%>)
@ -95,18 +62,48 @@
[config config<%>]
[range range<%>])
(init-field text
base-style
start-position
end-position)
(define base-style
(code-style text (send: config config<%> get-syntax-font-size)))
(define extra-styles (make-hasheq))
;; initialize : -> void
(define/public (initialize)
(send text change-style base-style start-position end-position #f)
(apply-primary-partition-styles)
(add-clickbacks)
(refresh))
;; add-clickbacks : -> void
(define/private (add-clickbacks)
(define (the-clickback editor start end)
(send: controller selection-manager<%> set-selected-syntax
(clickback->stx
(- start start-position) (- end start-position))))
(for ([range (send: range range<%> all-ranges)])
(let ([stx (range-obj range)]
[start (range-start range)]
[end (range-end range)])
(send text set-clickback (+ start-position start) (+ start-position end)
the-clickback))))
;; clickback->stx : num num -> syntax
;; FIXME: use vectors for treerange-subs and do binary search to narrow?
(define/private (clickback->stx start end)
(let ([treeranges (send: range range<%> get-treeranges)])
(let loop* ([treeranges treeranges])
(for/or ([tr treeranges])
(cond [(and (= (treerange-start tr) start)
(= (treerange-end tr) end))
(treerange-obj tr)]
[(and (<= (treerange-start tr) start)
(<= end (treerange-end tr)))
(loop* (treerange-subs tr))]
[else #f])))))
;; refresh : -> void
;; Clears all highlighting and reapplies all non-foreground styles.
(define/public (refresh)

96
collects/macro-debugger/syntax-browser/image.ss Normal file
View File

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

1
collects/macro-debugger/syntax-browser/interfaces.ss
View File

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

25
collects/macro-debugger/syntax-browser/prefs.ss
View File

@ -29,17 +29,26 @@
(define-notify syntax-font-size (new notify-box% (value #f)))
;; colors : (listof string)
(define-notify colors
(new notify-box%
(value '("black" "red" "blue"
"mediumforestgreen" "darkgreen"
"darkred"
"cornflowerblue" "royalblue" "steelblue" "darkslategray" "darkblue"
"indigo" "purple"
"orange" "salmon" "darkgoldenrod" "olive"))))
(define-notify colors
(new notify-box% (value the-colors)))
(super-new)))
(define alt-colors
'("black"
"red" "blue" "forestgreen" "purple" "brown"
"firebrick" "darkblue" "seagreen" "violetred" "chocolate"
"darkred" "cornflowerblue" "darkgreen" "indigo" "sandybrown"
"orange" "cadetblue" "olive" "mediumpurple" "goldenrod"))
(define the-colors
'("black" "red" "blue"
"mediumforestgreen" "darkgreen"
"darkred"
"cornflowerblue" "royalblue" "steelblue" "darkslategray" "darkblue"
"indigo" "purple"
"orange" "salmon" "darkgoldenrod" "olive"))
(define syntax-prefs-base%
(class* prefs-base% (config<%>)
(init readonly?)

26
collects/macro-debugger/syntax-browser/pretty-helper.ss
View File

@ -14,9 +14,9 @@
;; Solution: Rather than map stx to (syntax-e stx), in the cases where
;; (syntax-e stx) is confusable, map it to a different, unique, value.
;; - stx is identifier : map it to an uninterned symbol w/ same rep
;; (Symbols are useful: see pretty-print's style table)
;; - else : map it to a syntax-dummy object
;; Use syntax-dummy, and extend pretty-print-remap-stylable to look inside.
;; Old solution: same, except map identifiers to uninterned symbols instead
;; NOTE: Nulls are only wrapped when *not* list-terminators.
;; If they were always wrapped, the pretty-printer would screw up
@ -35,6 +35,7 @@
(pretty-print datum port)))
(define-struct syntax-dummy (val))
(define-struct (id-syntax-dummy syntax-dummy) (remap))
;; A SuffixOption is one of
;; - 'never -- never
@ -58,16 +59,20 @@
;; table : syntax maybe-partition% maybe-num SuffixOption -> (values s-expr hashtable hashtable)
(define (table stx partition limit suffixopt)
(define (make-identifier-proxy id)
(define sym (syntax-e id))
(case suffixopt
((never) (unintern (syntax-e id)))
((never)
(make-id-syntax-dummy sym sym))
((always)
(let ([n (send: partition partition<%> get-partition id)])
(if (zero? n) (unintern (syntax-e id)) (suffix (syntax-e id) n))))
(if (zero? n)
(make-id-syntax-dummy sym sym)
(make-id-syntax-dummy (suffix sym n) sym))))
((over-limit)
(let ([n (send: partition partition<%> get-partition id)])
(if (<= n limit)
(unintern (syntax-e id))
(suffix (syntax-e id) n))))))
(make-id-syntax-dummy sym sym)
(make-id-syntax-dummy (suffix sym n) sym))))))
(let/ec escape
(let ([flat=>stx (make-hasheq)]
@ -111,7 +116,7 @@
(refold (map loop fields)))
obj))]
[(symbol? obj)
(unintern obj)]
(make-id-syntax-dummy obj obj)]
[(null? obj)
(make-syntax-dummy obj)]
[(boolean? obj)
@ -169,8 +174,5 @@
'(quote quasiquote unquote unquote-splicing syntax))
;; FIXME: quasisyntax unsyntax unsyntax-splicing
(define (unintern sym)
(string->uninterned-symbol (symbol->string sym)))
(define (suffix sym n)
(string->uninterned-symbol (format "~a:~a" sym n)))
(string->symbol (format "~a:~a" sym n)))

33
collects/macro-debugger/syntax-browser/pretty-printer.ss
View File

@ -1,6 +1,3 @@
;; FIXME: Need to disable printing of structs with custom-write property
#lang scheme/base
(require scheme/list
scheme/class
@ -10,15 +7,14 @@
"interfaces.ss")
(provide pretty-print-syntax)
;; pretty-print-syntax :
;; syntax port partition (listof string) SuffixOption number
;; -> range%
;; FIXME: Need to disable printing of structs with custom-write property
;; pretty-print-syntax : syntax port partition number SuffixOption number
;; -> range%
(define (pretty-print-syntax stx port primary-partition colors suffix-option columns)
(define range-builder (new range-builder%))
(define-values (datum ht:flat=>stx ht:stx=>flat)
(syntax->datum/tables stx primary-partition
(length colors)
suffix-option))
(syntax->datum/tables stx primary-partition colors suffix-option))
(define identifier-list
(filter identifier? (hash-map ht:stx=>flat (lambda (k v) k))))
(define (flat=>stx obj)
@ -40,13 +36,6 @@
[end (current-position)])
(when (and start stx)
(send range-builder add-range stx (cons start end)))))
(define (pp-extend-style-table identifier-list)
(let* ([syms (map (lambda (x) (stx=>flat x)) identifier-list)]
[like-syms (map syntax-e identifier-list)])
(pretty-print-extend-style-table (pp-better-style-table)
syms
like-syms)))
(unless (syntax? stx)
(raise-type-error 'pretty-print-syntax "syntax" stx))
@ -55,7 +44,8 @@
[pretty-print-post-print-hook pp-post-hook]
[pretty-print-size-hook pp-size-hook]
[pretty-print-print-hook pp-print-hook]
[pretty-print-current-style-table (pp-extend-style-table identifier-list)]
[pretty-print-remap-stylable pp-remap-stylable]
[pretty-print-current-style-table (pp-better-style-table)]
[pretty-print-columns columns])
(pretty-print/defaults datum port)
(new range%
@ -79,9 +69,13 @@
(string-length (get-output-string ostring)))]
[else #f]))
(define (pp-remap-stylable obj)
(and (id-syntax-dummy? obj) (id-syntax-dummy-remap obj)))
(define (pp-better-style-table)
(basic-style-list)
#; ;; Messes up formatting too much :(
#|
;; Messes up formatting too much :(
(let* ([pref (pref:tabify)]
[table (car pref)]
[begin-rx (cadr pref)]
@ -91,7 +85,8 @@
(pretty-print-extend-style-table
(basic-style-list)
(map car style-list)
(map cdr style-list)))))
(map cdr style-list))))
|#)
(define (basic-style-list)
(pretty-print-extend-style-table

6
collects/mred/private/wxme/editor.ss
View File

@ -97,9 +97,9 @@
(set-box! w PAGE-WIDTH)
(set-box! h PAGE-HEIGHT)
(when (eq? (get-printer-orientation) 'landscape)
(let ([tmp h])
(set! h w)
(set! w tmp))))
(let ([tmp (unbox h)])
(set-box! h (unbox w))
(set-box! w tmp))))
;; ----------------------------------------

2
collects/mred/private/wxme/pasteboard.ss
View File

@ -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?

2
collects/repos-time-stamp/stamp.ss
View File

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

14
collects/scheme/contract/private/guts.ss
View File

@ -361,10 +361,16 @@
(define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
(define (check-flat-named-contract predicate) (coerce-flat-contract 'flat-named-contract predicate))
(define (flat-named-contract name predicate)
(unless (and (procedure? predicate)
(procedure-arity-includes? predicate 1))
(error 'flat-named-contract "expected a procedure of arity 1 as second argument, got ~e" predicate))
(make-predicate-contract name predicate))
(cond
[(and (procedure? predicate)
(procedure-arity-includes? predicate 1))
(make-predicate-contract name predicate)]
[(flat-contract? predicate)
(make-predicate-contract name (flat-contract-predicate predicate))]
[else
(error 'flat-named-contract
"expected a flat contract or procedure of arity 1 as second argument, got ~e"
predicate)]))
;; build-compound-type-name : (union contract symbol) ... -> (-> sexp)
(define (build-compound-type-name . fs)

7
collects/scheme/future.ss Normal file
View File

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

276
collects/scheme/private/sort.ss
View File

@ -4,23 +4,36 @@
(#%provide sort)
;; This is a destructive stable merge-sort, adapted from slib and improved by
;; Eli Barzilay.
;; The original source said:
;; It uses a version of merge-sort invented, to the best of my knowledge, by
;; David H. D. Warren, and first used in the DEC-10 Prolog system.
;; R. A. O'Keefe adapted it to work destructively in Scheme.
;; but it's a plain destructive merge sort, which I optimized further.
#|
;; The source uses macros to optimize some common cases (eg, no `getkey'
;; function, or precompiled versions with inlinable common comparison
;; predicates) -- they are local macros so they're not left in the compiled
;; code.
Based on "Fast mergesort implementation based on half-copying merge algorithm",
Cezary Juszczak, http://kicia.ift.uni.wroc.pl/algorytmy/mergesortpaper.pdf
Written in Scheme by Eli Barzilay. (Note: the reason for the seemingly
redundant pointer arithmetic in that paper is dealing with cases of uneven
number of elements.)
;; Note that there is no error checking on the arguments -- the `sort' function
;; that this module provide is then wrapped up by a keyworded version in
;; "scheme/private/list.ss", and that's what everybody sees. The wrapper is
;; doing these checks.
The source uses macros to optimize some common cases (eg, no `getkey'
function, or precompiled versions with inlinable common comparison
predicates) -- they are local macros so they're not left in the compiled
code.
Note that there is no error checking on the arguments -- the `sort' function
that this module provide is then wrapped up by a keyworded version in
"scheme/private/list.ss", and that's what everybody sees. The wrapper is
doing these checks.
|#
;; This code works with unsafe operations, but don't use it for a while to
;; catch potential problems.
;; (#%require (rename '#%unsafe i+ unsafe-fx+)
;; (rename '#%unsafe i- unsafe-fx-)
;; (rename '#%unsafe i= unsafe-fx=)
;; (rename '#%unsafe i< unsafe-fx<)
;; (rename '#%unsafe i<= unsafe-fx<=)
;; (rename '#%unsafe i>> unsafe-fxrshift)
;; (rename '#%unsafe vref unsafe-vector-ref)
;; (rename '#%unsafe vset! unsafe-vector-set!))
(define sort (let ()
@ -29,80 +42,78 @@
[(dr (foo . pattern) template)
(define-syntax foo (syntax-rules () [(_ . pattern) template]))]))
(define-syntax-rule (sort-internal-body lst *less? n has-getkey? getkey)
(begin
(define-syntax-rule (less? x y)
(if has-getkey? (*less? (getkey x) (getkey y)) (*less? x y)))
(define (merge-sorted! a b)
;; r-a? for optimization -- is r connected to a?
(define (loop r a b r-a?)
(if (less? (mcar b) (mcar a))
(begin
(when r-a? (set-mcdr! r b))
(if (null? (mcdr b)) (set-mcdr! b a) (loop b a (mcdr b) #f)))
;; (car a) <= (car b)
(begin
(unless r-a? (set-mcdr! r a))
(if (null? (mcdr a)) (set-mcdr! a b) (loop a (mcdr a) b #t)))))
(cond [(null? a) b]
[(null? b) a]
[(less? (mcar b) (mcar a))
(if (null? (mcdr b)) (set-mcdr! b a) (loop b a (mcdr b) #f))
b]
[else ; (car a) <= (car b)
(if (null? (mcdr a)) (set-mcdr! a b) (loop a (mcdr a) b #t))
a]))
(let step ([n n])
(cond [(> n 3)
(let* (; let* not really needed with mzscheme's l->r eval
[j (quotient n 2)] [a (step j)] [b (step (- n j))])
(merge-sorted! a b))]
;; the following two cases are just explicit treatment of sublists
;; of length 2 and 3, could remove both (and use the above case for
;; n>1) and it would still work, except a little slower
[(= n 3) (let ([p lst] [p1 (mcdr lst)] [p2 (mcdr (mcdr lst))])
(let ([x (mcar p)] [y (mcar p1)] [z (mcar p2)])
(set! lst (mcdr p2))
(cond [(less? y x) ; y x
(cond [(less? z y) ; z y x
(set-mcar! p z)
(set-mcar! p1 y)
(set-mcar! p2 x)]
[(less? z x) ; y z x
(set-mcar! p y)
(set-mcar! p1 z)
(set-mcar! p2 x)]
[else ; y x z
(set-mcar! p y)
(set-mcar! p1 x)])]
[(less? z x) ; z x y
(set-mcar! p z)
(set-mcar! p1 x)
(set-mcar! p2 y)]
[(less? z y) ; x z y
(set-mcar! p1 z)
(set-mcar! p2 y)])
(set-mcdr! p2 '())
p))]
[(= n 2) (let ([x (mcar lst)] [y (mcar (mcdr lst))] [p lst])
(set! lst (mcdr (mcdr lst)))
(when (less? y x)
(set-mcar! p y)
(set-mcar! (mcdr p) x))
(set-mcdr! (mcdr p) '())
p)]
[(= n 1) (let ([p lst])
(set! lst (mcdr lst))
(set-mcdr! p '())
p)]
[else '()]))))
(define-syntax-rule (i+ x y) (+ x y))
(define-syntax-rule (i- x y) (- x y))
(define-syntax-rule (i= x y) (= x y))
(define-syntax-rule (i< x y) (< x y))
(define-syntax-rule (i<= x y) (<= x y))
(define-syntax-rule (i>> x y) (arithmetic-shift x (- y)))
(define-syntax-rule (vref v i) (vector-ref v i))
(define-syntax-rule (vset! v i x) (vector-set! v i x))
(define-syntax-rule (sort-internal-body v *<? n has-getkey? getkey)
(let* ([n/2- (i>> n 1)] [n/2+ (i- n n/2-)])
(define-syntax-rule (<? x y)
(if has-getkey? (*<? (getkey x) (getkey y)) (*<? x y)))
(define-syntax-rule (ref n) (vref v n))
(define-syntax-rule (set! n x) (vset! v n x))
(define-syntax-rule (merge lo? A1 A2 B1 B2 C1)
(let ([b2 B2])
(let loop ([a1 A1] [b1 B1] [c1 C1])
(let ([x (ref a1)] [y (ref b1)])
(if (if lo? (not (<? y x)) (<? x y))
(begin (set! c1 x)
(let ([a1 (i+ a1 1)] [c1 (i+ c1 1)])
(when (i< c1 b1) (loop a1 b1 c1))))
(begin (set! c1 y)
(let ([b1 (i+ b1 1)] [c1 (i+ c1 1)])
(if (i<= b2 b1)
(let loop ([a1 a1] [c1 c1])
(when (i< c1 b1)
(set! c1 (ref a1))
(loop (i+ a1 1) (i+ c1 1))))
(loop a1 b1 c1)))))))))
(define-syntax-rule (copying-insertionsort Alo Blo n)
(let iloop ([i 0] [A Alo])
(when (i< i n)
(let ([ref-i (ref A)])
(let jloop ([j (i+ Blo i)])
(let ([ref-j-1 (ref (i- j 1))])
(if (and (i< Blo j) (<? ref-i ref-j-1))
(begin (set! j ref-j-1) (jloop (i- j 1)))
(begin (set! j ref-i) (iloop (i+ i 1) (i+ A 1))))))))))
(define (copying-mergesort Alo Blo n)
(cond
;; n is never 0, smaller values are more frequent
[(i= n 1) (set! Blo (ref Alo))]
[(i= n 2) (let ([x (ref Alo)] [y (ref (i+ Alo 1))])
(if (<? y x)
(begin (set! Blo y) (set! (i+ Blo 1) x))
(begin (set! Blo x) (set! (i+ Blo 1) y))))]
;; insertion sort for small chunks (not much difference up to ~30)
[(i< n 16) (copying-insertionsort Alo Blo n)]
[else (let* ([n/2- (i>> n 1)] [n/2+ (i- n n/2-)])
(let ([Amid1 (i+ Alo n/2-)]
[Amid2 (i+ Alo n/2+)]
[Bmid1 (i+ Blo n/2-)])
(copying-mergesort Amid1 Bmid1 n/2+)
(copying-mergesort Alo Amid2 n/2-)
(merge #t Amid2 (i+ Alo n) Bmid1 (i+ Blo n) Blo)))]))
(let ([Alo 0] [Amid1 n/2-] [Amid2 n/2+] [Ahi n] [B1lo n])
(copying-mergesort Amid1 B1lo n/2+)
(unless (zero? n/2-) (copying-mergesort Alo Amid2 n/2-))
(merge #f B1lo (i+ B1lo n/2+) Amid2 Ahi Alo))))
(define sort-internals (make-hasheq))
(define _
(let ()
(define-syntax-rule (precomp less? more ...)
(let ([proc (lambda (lst n) (sort-internal-body lst less? n #f #f))])
(hash-set! sort-internals less? proc)
(define-syntax-rule (precomp <? more ...)
(let ([proc (lambda (vec n) (sort-internal-body vec <? n #f #f))])
(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
(case-lambda
[(less? lst n)
(let ([si (hash-ref sort-internals less? #f)])
(define-syntax sort-internal
(syntax-rules ()
[(_ <? vec n)
(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))))]
[(less? lst n getkey)
(sort-internal-body lst less? n #t getkey)]))
(let () (sort-internal-body vec <? n #f #f))))]
[(_ <? vec n 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)
(if has-getkey? (*less? (getkey x) (getkey y)) (*less? x y)))
(define-syntax-rule (<? 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
[mlst (let ([x (car lst)]) (mcons (cons (getkey x) x) null))])
(let loop ([last mlst] [lst (cdr lst)])
(let ([vec (make-vector (+ n (ceiling (/ n 2))))])
;; list -> decorated-vector
(let loop ([i 0] [lst lst])
(when (pair? lst)
(let ([new (let ([x (car lst)]) (mcons (cons (getkey x) x) null))])
(set-mcdr! last new)
(loop new (cdr lst)))))
;; decorated-mlist -> list
(let loop ([r (sort-internal *less? mlst n car)])
(if (null? r) r (cons (cdr (mcar r)) (loop (mcdr r))))))]
(let ([x (car lst)])
(vector-set! vec i (cons (getkey x) x))
(loop (add1 i) (cdr lst)))))
;; sort
(sort-internal *<? vec n car)
;; 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.
;; A good way to see that we have good code is to check that each
;; (<? later-item earlier-item) since it gives more information. A
;; 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))))))]
[else (let (;; list -> mlist
[mlst (mcons (car lst) null)])
(let loop ([last mlst] [lst (cdr lst)])
(if (<? c a) (list c a b) (list a c b))))))]
[else (let ([vec (make-vector (+ n (ceiling (/ n 2))))])
;; list -> vector
(let loop ([i 0] [lst lst])
(when (pair? lst)
(let ([new (mcons (car lst) null)])
(set-mcdr! last new)
(loop new (cdr lst)))))
;; mlist -> list
(let loop ([r (if getkey
(sort-internal *less? mlst n getkey)
(sort-internal *less? mlst n))])
(if (null? r) r (cons (mcar r) (loop (mcdr r))))))])))
(vector-set! vec i (car lst))
(loop (add1 i) (cdr lst))))
;; sort
(if getkey
(sort-internal *<? vec n getkey)
(sort-internal *<? vec n))
;; vector -> list
(let loop ([i n] [r '()])
(let ([i (sub1 i)])
(if (< i 0) r (loop i (cons (vector-ref vec i) r))))))])))
;; Finally, this is the provided `sort' value
(case-lambda
[(lst less?) (sort-body lst less? #f #f #f)]
[(lst less? getkey)
[(lst <?) (sort-body lst <? #f #f #f)]
[(lst <? getkey)
(if (and getkey (not (eq? values getkey)))
(sort lst less? getkey #f) (sort lst less?))]
[(lst less? getkey cache-keys?)
(sort lst <? getkey #f) (sort lst <?))]
[(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 <?))])
)))

40
collects/scheme/vector.ss
View File

@ -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)])
(unless (and (<= 0 start) (< start len))
(raise-mismatch-error
'vector-copy
(format "start index ~e out of range [~e, ~e] for vector ~e"
start 0 len v)
v))
(unless (and (<= start end) (<= end len))
(raise-mismatch-error
'vector-copy
(format "end index ~e out of range [~e, ~e] for vector ~e"
end start len v)
v))
(vector-copy* v start end)))
(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: "
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: "
end start len)
v))
(vector-copy* v start end)])))
;; do vector-map, putting the result in `target'
;; length is passed to save the computation
@ -133,7 +145,7 @@
(unless (<= 0 n len)
(raise-mismatch-error
name
(format "index out of range [~e, ~e] for vector" 0 len)
(format "index out of range [~e, ~e] for vector " 0 len)
v))
len))

17
collects/scribble/html-render.ss
View File

@ -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)
"scribble-plt-scheme-org")))
(body ([id ,(or (extract-part-body-id d ri)
"scribble-plt-scheme-org")])
,@(render-toc-view d ri)
(div ([class "maincolumn"])
(div ([class "main"])
@ -616,7 +618,8 @@
(render-version d ri))
,@(navigation d ri #t)
,@(render-part d ri)
,@(navigation d ri #f)))))))))))
,@(navigation d ri #f)))
(div ([id "langindicator"]) nbsp)))))))))
(define/private (part-parent d ri)
(collected-info-parent (part-collected-info d ri)))
@ -705,6 +708,7 @@
(make-target-url url)
(make-attributes
`([title . ,(if title* (string-append label " to " title*) label)]
[pltdoc . "x"]
,@more)))))
(define top-link
(titled-url
@ -987,7 +991,8 @@
[else
;; Normal link:
(dest->url dest)]))
,@(attribs)]
,@(attribs)
[pltdoc "x"]]
,@(if (empty-content? (element-content e))
(render-content (strip-aux (dest-title dest)) part ri)
(render-content (element-content e) part ri))))

78
collects/scribble/scribble-common.js
View File

@ -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) {
@ -55,13 +97,41 @@ function DoSearchKey(event, field, ver, top_path) {
return true;
}
function TocviewToggle(glyph,id) {
function TocviewToggle(glyph, id) {
var s = document.getElementById(id).style;
var expand = s.display == "none";
s.display = expand ? "block" : "none";
glyph.innerHTML = expand ? "&#9660;" : "&#9658;";
}
// `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>");
// Page Init ------------------------------------------------------------------
// Note: could make a function that inspects and uses window.onload to chain to
// a previous one, but this file needs to be required first anyway, since it
// contains utilities for all other files.
var on_load_funcs = [];
function AddOnLoad(fun) { on_load_funcs.push(fun); }
window.onload = function() {
for (var i=0; i<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]);
});

32
collects/scribble/scribble.css
View File

@ -77,14 +77,14 @@ table td {
padding: 0.25em 0 0.25em 0;
}
.navsettop {
margin-bottom: 1.5em;
border-bottom: 2px solid #e0e0c0;
.navsettop {
margin-bottom: 1.5em;
border-bottom: 2px solid #e0e0c0;
}
.navsetbottom {
margin-top: 2em;
border-top: 2px solid #e0e0c0;
.navsetbottom {
margin-top: 2em;
border-top: 2px solid #e0e0c0;
}
.navleft {
@ -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 */
@ -224,11 +236,11 @@ table td {
padding-left: 0.8em;
}
.tocviewsublist {
margin-bottom: 1em;
margin-bottom: 1em;
}
.tocviewsublist table,
.tocviewsublist table,
.tocviewsublistonly table,
.tocviewsublisttop table,
.tocviewsublisttop table,
.tocviewsublistbottom table {
font-size: 75%;
}
@ -411,4 +423,4 @@ i {
.author {
display: inline;
white-space: nowrap;
}
}

41
collects/scribblings/futures/futures.scrbl Normal file
View File

@ -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.
}

3
collects/scribblings/futures/info.ss Normal file
View File

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

11
collects/scribblings/inside/memory.scrbl
View File

@ -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.

7
collects/scribblings/main/private/make-search.ss
View File

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

92
collects/scribblings/main/private/search.js
View File

@ -226,17 +226,8 @@ function InitializeSearch() {
result_links.push(n);
AdjustResultsNum();
// get search string
if (location.search.length > 0) {
var paramstrs = location.search.substring(1).split(/[;&]/);
for (var i=0; i<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;
}
}
}
var init_q = GetArgFromURL(location,"q");
if (init_q && init_q != "") query.value = init_q;
ContextFilter();
DoSearch();
query.focus();
@ -342,11 +333,18 @@ 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) {
switch (op) {
case "N":
op = CompileTerm(term);
// return C_exact if it's not found, so it doesn't disqualify exact matches
@ -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(/ /);
for (var i=0; i<preds.length; i++) preds[i] = CompileTerm(preds[i]);
var preds = (term=="") ? [] : CompileTerms(term.split(/ /), false);
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]) + '"'
+' class="indexlink" tabIndex="2">'
'<a href="' + href + '" 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);
})();

19
collects/scribblings/main/private/utils.ss
View File

@ -103,13 +103,18 @@
[(#f) path]
[else (error "internal error (main-page)")]))
(define (onclick style)
(if (eq? root 'user)
(make-style style
(list (make-attributes
`([onclick
. ,(format "return GotoPLTRoot(\"~a\", \"~a\");"
(version) path)]))))
style))
(make-style
style
(list (make-attributes
`(,@(if (eq? root 'user)
`([onclick
. ,(format "return GotoPLTRoot(\"~a\", \"~a\");"
(version) path)])
`())
;; note: root=#f means an external link, but in this
;; case this is the bugs link, so *keep* it and later
;; use it on the bugs page
[pltdoc . "x"])))))
(define (elt style)
(make-toc-element
#f null (list (hyperlink dest #:style (onclick style) text))))

13
collects/scribblings/reference/contracts.scrbl
View File

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

102
collects/setup/setup-unit.ss
View File

@ -76,9 +76,8 @@
(setup-printf "version" "~a [~a]" (version) (system-type 'gc))
(setup-printf "variants" "~a"
(apply string-append
(map (lambda (s) (format " ~a" s))
(available-mzscheme-variants))))
(string-join (map symbol->string (available-mzscheme-variants))
", "))
(setup-printf "main collects" "~a" (path->string main-collects-dir))
(setup-printf "collects paths"
(if (null? (current-library-collection-paths)) " empty!" ""))
@ -136,16 +135,14 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define x-specific-collections
(apply append
(specific-collections)
(map (lambda (x)
(unpack x
(build-path main-collects-dir 'up)
(lambda (s) (setup-printf #f "~a" s))
(current-target-directory-getter)
(force-unpacks)
(current-target-plt-directory-getter)))
(archives))))
(append* (specific-collections)
(for/list ([x (in-list (archives))])
(unpack x
(build-path main-collects-dir 'up)
(lambda (s) (setup-printf #f "~a" s))
(current-target-directory-getter)
(force-unpacks)
(current-target-plt-directory-getter)))))
;; specific-planet-dir ::=
;; - (list path[directory] string[owner] string[package-name] (listof string[extra package path]) Nat[maj] Nat[min]), or
@ -854,49 +851,44 @@
kind mzlns))]
[(and (or (not mzlls) (= (length mzlns) (length mzlls)))
(or (not mzlfs) (= (length mzlns) (length mzlfs))))
(for-each
(lambda (mzln mzll mzlf)
(let ([p (program-launcher-path mzln)]
[aux (list* `(exe-name . ,mzln)
'(framework-root . #f)
'(dll-dir . #f)
`(relative? . ,(not absolute-installation?))
(build-aux-from-path
(build-path (cc-path cc)
(path-replace-suffix
(or mzll mzln)
#""))))])
(unless (up-to-date? p aux)
(setup-printf
"launcher"
"~a~a"
(path->name p #:prefix (format "~a-bin" kind)
#:base (if (equal? kind 'console)
find-console-bin-dir
find-gui-bin-dir))
(let ([v (current-launcher-variant)])
(if (eq? v (system-type 'gc)) "" (format " [~a]" v))))
(make-launcher
(or mzlf
(if (cc-collection cc)
(list "-l-" (string-append
(apply string-append
(map (lambda (s)
(string-append
(if (path? s)
(path->string s)
s)
"/"))
(cc-collection cc)))
mzll))
(list "-t-" (path->string (build-path (cc-path cc) mzll)))))
p
aux))))
mzlns
(or mzlls (map (lambda (_) #f) mzlns))
(or mzlfs (map (lambda (_) #f) mzlns)))]
(for ([mzln (in-list mzlns)]
[mzll (in-list (or mzlls (map (lambda (_) #f) mzlns)))]
[mzlf (in-list (or mzlfs (map (lambda (_) #f) mzlns)))])
(let ([p (program-launcher-path mzln)]
[aux (list* `(exe-name . ,mzln)
'(framework-root . #f)
'(dll-dir . #f)
`(relative? . ,(not absolute-installation?))
(build-aux-from-path
(build-path (cc-path cc)
(path-replace-suffix
(or mzll mzln)
#""))))])
(unless (up-to-date? p aux)
(setup-printf
"launcher"
"~a~a"
(path->name p #:prefix (format "~a-bin" kind)
#:base (if (equal? kind 'console)
find-console-bin-dir
find-gui-bin-dir))
(let ([v (current-launcher-variant)])
(if (eq? v (system-type 'gc)) "" (format " [~a]" v))))
(make-launcher
(or mzlf
(if (cc-collection cc)
(list "-l-" (string-append
(string-append*
(map (lambda (s) (format "~a/" s))
(cc-collection cc)))
mzll))
(list "-t-" (path->string (build-path (cc-path cc) mzll)))))
p
aux))))]
[else
(let ([fault (if (or (not mzlls) (= (length mzlns) (length mzlls))) 'f 'l)])
(let ([fault (if (or (not mzlls)
(= (length mzlns) (length mzlls)))
'f 'l)])
(setup-printf
"WARNING"
"~s launcher name list ~s doesn't match ~a list; ~s"

6
collects/stepper/internal-docs.txt
View File

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

3
collects/stepper/private/annotate.ss
View File

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

37
collects/tests/framework/text.ss
View File

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

2
collects/tests/mzscheme/benchmarks/common/nucleic2.sch
View File

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

13
collects/tests/mzscheme/list.ss
View File

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

11
collects/tests/mzscheme/vector.ss
View File

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

14
collects/tests/run-automated-tests.ss
View File

@ -31,16 +31,16 @@
;; special flag that means that errors raised by the test suite are
;; ignored, and should only be used by the mzscheme tests.)
(define tests
'(;[no-handler load "mzscheme/quiet.ss" (lib "scheme/init")]
'([no-handler load "mzscheme/quiet.ss" (lib "scheme/init")]
;; [require "planet/lang.ss"]
[require "typed-scheme/nightly-run.ss"]
; [require "match/plt-match-tests.ss"]
; ;; [require "stepper/automatic-tests.ss" (lib "scheme/base")]
[require "match/plt-match-tests.ss"]
;; [require "stepper/automatic-tests.ss" (lib "scheme/base")]
[require "lazy/main.ss"]
; [require "scribble/main.ss"]
;[require "net/main.ss"]
; [require "file/main.ss"]
; [require "profile/main.ss"]
[require "scribble/main.ss"]
[require "net/main.ss"]
[require "file/main.ss"]
[require "profile/main.ss"]
))
(require scheme/runtime-path)

7
collects/web-server/scribblings/ctable.scrbl
View File

@ -67,8 +67,11 @@ where a @scheme[host-table-sexpr] is:
(mime-types ,path-string?)
(password-authentication ,path-string?)))]
In this syntax, the @scheme['messages] paths are relative to the @scheme['configuration-root] directory.
All the paths in @scheme['paths] are relative to @scheme['host-root] (other than @scheme['host-root] obviously.)
In this syntax, the @scheme['messages] paths are relative to the
@scheme['configuration-root] directory. All the paths in
@scheme['paths] except for @scheme['servlet-root] are relative to
@scheme['host-root] (other than @scheme['host-root] obviously.)
The @scheme['servlet-root] path is relative to @scheme['file-root].
Allowable @scheme['log-format]s are those accepted by @scheme[log-format->format].

8
doc/release-notes/drscheme/HISTORY.txt
View File

@ -1,9 +1,15 @@
------------------------------
Version 4.2.3
------------------------------
. minor bug fixes
------------------------------
Version 4.2.2
------------------------------
. DrScheme now (by default) automatically compiles your source
files, saving them in the compiled/drscheme/ subdirectory.
files, saving them in the compiled/drscheme/ subdirectory.
. Syntax coloring now works for languages using the @-reader
(ie, Scribble)

6
doc/release-notes/mred/HISTORY.txt
View File

@ -1,3 +1,9 @@
Version 4.2.3, November 2009
Minor bug fixes
----------------------------------------------------------------------
Version 4.2.2, September 2009
Minor bug fixes

5
doc/release-notes/mzscheme/HISTORY.txt
View File

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

2
doc/release-notes/redex/HISTORY.txt
View File

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

4
doc/release-notes/stepper/HISTORY.txt
View File

@ -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.

6
doc/release-notes/teachpack/HISTORY.txt
View File

@ -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]

2
src/mred/gc2/Makefile.in
View File

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

4
src/mzscheme/cmdline.inc
View File

@ -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"

17
src/mzscheme/gc2/gc2.h
View File

@ -2,10 +2,12 @@
#ifndef __mzscheme_gc_2__
#define __mzscheme_gc_2__
#ifdef INCLUDE_WITHOUT_PATHS
# include "schthread.h"
#else
# include "../include/schthread.h"
#ifndef GC2_JUST_MACROS
# ifdef INCLUDE_WITHOUT_PATHS
# include "schthread.h"
# else
# include "../include/schthread.h"
# endif
#endif
/***************************************************************************/
@ -409,9 +411,12 @@ GC2_EXTERN void GC_switch_back_from_master(void *gc);
Switches to back to gc from the master GC
*/
GC2_EXTERN void *GC_make_jit_nursery_page();
GC2_EXTERN unsigned long GC_make_jit_nursery_page();
/*
obtains a nursery page from the GC for thread local allocation
Obtains a nursery page from the GC for thread local allocation.
The result is an unsigned long because it's not a valid
pointer to a GCable object. The result becomes invalid (i.e. it's collected)
with the next GC.
*/

26
src/mzscheme/gc2/newgc.c
View File

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

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

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

47
src/mzscheme/include/schthread.h
View File

@ -25,6 +25,9 @@
# define THREAD_LOCAL __declspec(thread)
# elif defined(OS_X)
# define IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS
# if defined(__x86_64__) || defined(__i386__)
# define INLINE_GETSPECIFIC_ASSEMBLY_CODE
# endif
# else
# define THREAD_LOCAL __thread
# endif
@ -92,6 +95,7 @@ typedef struct Thread_Local_Variables {
unsigned long scheme_stack_boundary_;
unsigned long volatile scheme_jit_stack_boundary_;
volatile int scheme_future_need_gc_pause_;
int scheme_use_rtcall_;
struct Scheme_Object *quick_stx_;
int scheme_continuation_application_count_;
int scheme_cont_capture_count_;
@ -109,7 +113,6 @@ typedef struct Thread_Local_Variables {
struct Scheme_Overflow *offstack_overflow_;
struct Scheme_Overflow_Jmp *scheme_overflow_jmp_;
void *scheme_overflow_stack_start_;
struct future_t *current_ft_;
void **codetab_tree_;
int during_set_;
Stack_Cache_Elem stack_cache_stack_[STACK_CACHE_SIZE];
@ -180,7 +183,9 @@ typedef struct Thread_Local_Variables {
int swap_no_setjmp_;
int thread_swap_count_;
int scheme_did_gc_count_;
int worker_gc_counter_;
struct Scheme_Future_State *scheme_future_state_;
struct Scheme_Future_Thread_State *scheme_future_thread_state_;
void *jit_future_storage_[2];
struct Scheme_Object **scheme_current_runstack_start_;
struct Scheme_Object **scheme_current_runstack_;
MZ_MARK_STACK_TYPE scheme_current_cont_mark_stack_;
@ -211,19 +216,36 @@ typedef struct Thread_Local_Variables {
unsigned long current_total_allocation_;
struct gmp_tmp_stack gmp_tmp_xxx_;
struct gmp_tmp_stack *gmp_tmp_current_;
#if FUTURES_ENABLED
pthread_cond_t worker_can_continue_cv_;
void *jit_future_storage_[2];
#endif
struct Scheme_Logger *scheme_main_logger_;
} Thread_Local_Variables;
#if defined(IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS)
/* Using Pthread getspecific() */
# include <pthread.h>
MZ_EXTERN pthread_key_t scheme_thread_local_key;
# define scheme_get_thread_local_variables() ((Thread_Local_Variables *)pthread_getspecific(scheme_thread_local_key))
#ifdef MZ_XFORM
# ifndef INLINE_GETSPECIFIC_ASSEMBLY_CODE
# define scheme_get_thread_local_variables() ((Thread_Local_Variables *)pthread_getspecific(scheme_thread_local_key))
# ifdef MZ_XFORM
XFORM_GC_VARIABLE_STACK_THROUGH_GETSPECIFIC;
# endif
# else
# ifdef MZ_XFORM
START_XFORM_SKIP;
# endif
static inline Thread_Local_Variables *scheme_get_thread_local_variables() __attribute__((used));
static inline Thread_Local_Variables *scheme_get_thread_local_variables() {
Thread_Local_Variables *x;
# if defined(__x86_64__)
asm volatile("movq %%gs:0x8A0, %0" : "=r"(x));
# else
asm volatile("movl %%gs:0x468, %0" : "=r"(x));
# endif
return x;
}
# ifdef MZ_XFORM
END_XFORM_SKIP;
XFORM_GC_VARIABLE_STACK_THROUGH_FUNCTION;
# endif
# endif
#else
/* Using `THREAD_LOCAL' variable: */
@ -255,6 +277,7 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL;
#define scheme_stack_boundary XOA (scheme_get_thread_local_variables()->scheme_stack_boundary_)
#define scheme_jit_stack_boundary XOA (scheme_get_thread_local_variables()->scheme_jit_stack_boundary_)
#define scheme_future_need_gc_pause XOA (scheme_get_thread_local_variables()->scheme_future_need_gc_pause_)
#define scheme_use_rtcall XOA (scheme_get_thread_local_variables()->scheme_use_rtcall_)
#define quick_stx XOA (scheme_get_thread_local_variables()->quick_stx_)
#define scheme_continuation_application_count XOA (scheme_get_thread_local_variables()->scheme_continuation_application_count_)
#define scheme_cont_capture_count XOA (scheme_get_thread_local_variables()->scheme_cont_capture_count_)
@ -272,7 +295,6 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL;
#define offstack_overflow XOA (scheme_get_thread_local_variables()->offstack_overflow_)
#define scheme_overflow_jmp XOA (scheme_get_thread_local_variables()->scheme_overflow_jmp_)
#define scheme_overflow_stack_start XOA (scheme_get_thread_local_variables()->scheme_overflow_stack_start_)
#define current_ft XOA (scheme_get_thread_local_variables()->current_ft_)
#define codetab_tree XOA (scheme_get_thread_local_variables()->codetab_tree_)
#define during_set XOA (scheme_get_thread_local_variables()->during_set_)
#define thread_local_pointers XOA (scheme_get_thread_local_variables()->thread_local_pointers_)
@ -344,7 +366,9 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL;
#define swap_no_setjmp XOA (scheme_get_thread_local_variables()->swap_no_setjmp_)
#define thread_swap_count XOA (scheme_get_thread_local_variables()->thread_swap_count_)
#define scheme_did_gc_count XOA (scheme_get_thread_local_variables()->scheme_did_gc_count_)
#define worker_gc_counter XOA (scheme_get_thread_local_variables()->worker_gc_counter_)
#define scheme_future_state XOA (scheme_get_thread_local_variables()->scheme_future_state_)
#define scheme_future_thread_state XOA (scheme_get_thread_local_variables()->scheme_future_thread_state_)
#define jit_future_storage XOA (scheme_get_thread_local_variables()->jit_future_storage_)
#define scheme_current_runstack_start XOA (scheme_get_thread_local_variables()->scheme_current_runstack_start_)
#define scheme_current_runstack XOA (scheme_get_thread_local_variables()->scheme_current_runstack_)
#define scheme_current_cont_mark_stack XOA (scheme_get_thread_local_variables()->scheme_current_cont_mark_stack_)
@ -375,8 +399,7 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL;
#define current_total_allocation XOA (scheme_get_thread_local_variables()->current_total_allocation_)
#define gmp_tmp_xxx XOA (scheme_get_thread_local_variables()->gmp_tmp_xxx_)
#define gmp_tmp_current XOA (scheme_get_thread_local_variables()->gmp_tmp_current_)
#define worker_can_continue_cv XOA (scheme_get_thread_local_variables()->worker_can_continue_cv_)
#define jit_future_storage XOA (scheme_get_thread_local_variables()->jit_future_storage_)
#define scheme_main_logger XOA (scheme_get_thread_local_variables()->scheme_main_logger_)
/* **************************************** */

8
src/mzscheme/main.c
View File

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

5
src/mzscheme/src/Makefile.in
View File

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

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

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

9
src/mzscheme/src/complex.c
View File

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

9
src/mzscheme/src/dynext.c
View File

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

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

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

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

@ -50,8 +50,7 @@ void (*scheme_console_output)(char *str, long len);
static int init_syslog_level = INIT_SYSLOG_LEVEL;
static int init_stderr_level = SCHEME_LOG_ERROR;
Scheme_Logger *scheme_main_logger;
static void init_logger_config();
THREAD_LOCAL_DECL(static Scheme_Logger *scheme_main_logger);
/* readonly globals */
const char *scheme_compile_stx_string = "compile";
@ -177,6 +176,7 @@ Scheme_Config *scheme_init_error_escape_proc(Scheme_Config *config)
%c = unicode char
%d = int
%ld = long int
%lx = long int
%o = int, octal
%f = double
%% = percent
@ -333,9 +333,14 @@ static long sch_vsprintf(char *s, long maxlen, const char *msg, va_list args, ch
case 'l':
{
long d;
int as_hex;
as_hex = (msg[j] == 'x');
j++;
d = ints[ip++];
sprintf(buf, "%ld", d);
if (as_hex)
sprintf(buf, "%lx", d);
else
sprintf(buf, "%ld", d);
t = buf;
tlen = strlen(t);
}
@ -343,7 +348,6 @@ static long sch_vsprintf(char *s, long maxlen, const char *msg, va_list args, ch
case 'f':
{
double f;
j++;
f = dbls[dp++];
sprintf(buf, "%f", f);
t = buf;
@ -584,7 +588,13 @@ void scheme_init_error(Scheme_Env *env)
scheme_add_evt(scheme_log_reader_type, (Scheme_Ready_Fun)log_reader_get, NULL, NULL, 1);
REGISTER_SO(scheme_def_exit_proc);
REGISTER_SO(default_display_handler);
REGISTER_SO(emergency_display_handler);
scheme_def_exit_proc = scheme_make_prim_w_arity(def_exit_handler_proc, "default-exit-handler", 1, 1);
default_display_handler = scheme_make_prim_w_arity(def_error_display_proc, "default-error-display-handler", 2, 2);
emergency_display_handler = scheme_make_prim_w_arity(emergency_error_display_proc, "emergency-error-display-handler", 2, 2);
REGISTER_SO(def_err_val_proc);
def_err_val_proc = scheme_make_prim_w_arity(def_error_value_string_proc, "default-error-value->string-handler", 2, 2);
@ -600,14 +610,6 @@ void scheme_init_error(Scheme_Env *env)
info_symbol = scheme_intern_symbol("info");
debug_symbol = scheme_intern_symbol("debug");
{
REGISTER_SO(scheme_main_logger);
scheme_main_logger = make_a_logger(NULL, NULL);
scheme_main_logger->syslog_level = init_syslog_level;
scheme_main_logger->stderr_level = init_stderr_level;
}
init_logger_config();
REGISTER_SO(arity_property);
{
Scheme_Object *guard;
@ -620,27 +622,29 @@ void scheme_init_error(Scheme_Env *env)
scheme_init_error_config();
}
static void init_logger_config()
void scheme_init_logger()
{
scheme_set_root_param(MZCONFIG_LOGGER, (Scheme_Object *)scheme_main_logger);
REGISTER_SO(scheme_main_logger);
scheme_main_logger = make_a_logger(NULL, NULL);
scheme_main_logger->syslog_level = init_syslog_level;
scheme_main_logger->stderr_level = init_stderr_level;
}
Scheme_Logger *scheme_get_main_logger() {
return scheme_main_logger;
}
void scheme_init_error_config(void)
{
init_logger_config();
scheme_set_root_param(MZCONFIG_EXIT_HANDLER, scheme_def_exit_proc);
REGISTER_SO(default_display_handler);
REGISTER_SO(emergency_display_handler);
default_display_handler = scheme_make_prim_w_arity(def_error_display_proc, "default-error-display-handler", 2, 2);
emergency_display_handler = scheme_make_prim_w_arity(emergency_error_display_proc, "emergency-error-display-handler", 2, 2);
scheme_set_root_param(MZCONFIG_ERROR_DISPLAY_HANDLER, default_display_handler);
scheme_set_root_param(MZCONFIG_ERROR_PRINT_VALUE_HANDLER, def_err_val_proc);
}
void scheme_init_logger_config() {
scheme_set_root_param(MZCONFIG_LOGGER, (Scheme_Object *)scheme_main_logger);
}
static void
scheme_inescapeable_error(const char *a, const char *b)
{

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

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

14
src/mzscheme/src/fun.c
View File

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

1523
src/mzscheme/src/future.c
View File

File diff suppressed because it is too large Load Diff

168
src/mzscheme/src/future.h
View File

@ -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;
void *alloc_retval;
unsigned long alloc_retval;
int alloc_retval_counter;
void *prim_func;
int prim_protocol;
Scheme_Object *arg_s0;
Scheme_Object **arg_S0;
Scheme_Bucket *arg_b0;
int arg_i0;
long arg_l0;
size_t arg_z0;
Scheme_Native_Closure_Data *arg_n0;
Scheme_Object *arg_s1;
Scheme_Object **arg_S1;
int arg_i1;
long arg_l1;
Scheme_Object *arg_s2;
Scheme_Object **arg_S2;
int arg_i2;
Scheme_Object *retval_s;
void *retval_p; /* use only with conservative GC */
MZ_MARK_STACK_TYPE retval_m;
int no_retval;
Scheme_Object **multiple_array;
int multiple_count;
Scheme_Object *tail_rator;
Scheme_Object **tail_rands;
int num_tail_rands;
Scheme_Object *retval;
struct future *prev;
struct future *next;
struct future *next_waiting_atomic;
struct future_t *prev;
struct future_t *next;
int waiting_atomic;
struct future_t *next_waiting_atomic;
} future_t;
#ifdef UNIT_TEST
//If unit testing, expose internal functions and vars to
//the test suite
extern future_t *g_future_queue;
extern int g_next_futureid;
extern pthread_t g_rt_threadid;
extern void *worker_thread_future_loop(void *arg);
extern void *invoke_rtcall(future_t *future);
extern future_t *enqueue_future(void);
extern future_t *get_pending_future(void);
extern future_t *get_my_future(void);
extern future_t *get_future_by_threadid(pthread_t threadid);
extern future_t *get_future(int futureid);
extern future_t *get_last_future(void);
extern void clear_futures(void);
#endif
//Primitive instrumentation stuff
#ifdef INSTRUMENT_PRIMITIVES
extern int g_print_prims;
extern void print_ms_and_us(void);
#define LOG_PRIM_START(p) \
if (g_print_prims) \
{ \
printf("%p ", p); \
print_ms_and_us(); \
printf("\n"); \
}
#define LOG_PRIM_END(p)
/*
#define LOG_PRIM_END(p) \
if (g_print_prims) \
{ \
print_ms_and_us(); \
printf("\n"); \
}
*/
#define LOG_PRIM_W_NAME(name) \
if (g_print_prims) \
{ \
printf("%s ", name); \
print_ms_and_us(); \
printf("\n"); \
}
#else
#define LOG_PRIM_START(p)
#define LOG_PRIM_END(p)
#define LOG_PRIM_W_NAME(name)
#endif
//Signature flags for primitive invocations
//Here the convention is SIG_[arg1type]_[arg2type]..._[return type]
#define SIG_VOID_VOID_3ARGS 1 //void -> void, copy 3 args from runstack
#define SIG_ALLOC_VOID_PVOID 2 //void -> void*
#define SIG_OBJ_INT_POBJ_OBJ 3 //Scheme_Object* -> int -> Scheme_Object** -> Scheme_Object*
#define SIG_INT_OBJARR_OBJ 4 //int -> Scheme_Object*[] -> Scheme_Object
#define SIG_INT_POBJ_OBJ_OBJ 17 //int -> Scheme_Object** -> Scheme_Object* -> Scheme_Object*
#define SIG_PVOID_PVOID_PVOID 18 //void* -> void* -> void*
# include "jit_ts_protos.h"
extern Scheme_Object *scheme_ts_scheme_force_value_same_mark(Scheme_Object *v);
//Helper macros for argument marshaling
#ifdef FUTURES_ENABLED
@ -171,20 +120,8 @@ extern void print_ms_and_us(void);
/*GDB_BREAK;*/ \
}
extern int rtcall_void_void_3args(void (*f)());
extern int rtcall_alloc_void_pvoid(void (*f)(), void **retval);
extern int rtcall_obj_int_pobj_obj(
Scheme_Object* (*f)(Scheme_Object*, int, Scheme_Object**),
Scheme_Object *a,
int b,
Scheme_Object **c,
Scheme_Object **retval);
extern int rtcall_int_pobj_obj(
Scheme_Object* (*f)(int, Scheme_Object**),
int argc,
Scheme_Object **argv,
Scheme_Object **retval);
extern void scheme_rtcall_void_void_3args(const char *who, int src_type, prim_void_void_3args_t f);
extern unsigned long scheme_rtcall_alloc_void_pvoid(const char *who, int src_type, prim_alloc_void_pvoid_t f);
#else
@ -241,6 +178,9 @@ extern int rtcall_int_pobj_obj(
#define LOG_RTCALL_ENV_ENV_VOID(a,b)
#endif
extern void *scheme_on_demand_jit_code;
extern void scheme_on_demand_generate_lambda(Scheme_Native_Closure *nc, int argc, Scheme_Object **argv);
void scheme_future_block_until_gc();
void scheme_future_continue_after_gc();
void scheme_check_future_work();

178
src/mzscheme/src/gen-jit-ts.ss Normal file
View File

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

501
src/mzscheme/src/jit.c
View File

File diff suppressed because it is too large Load Diff

138
src/mzscheme/src/jit_ts.c Normal file
View File

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

180
src/mzscheme/src/jit_ts_def.c Normal file
View File

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

498
src/mzscheme/src/jit_ts_future_glue.c Normal file
View File

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

60
src/mzscheme/src/jit_ts_protos.h Normal file
View File

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

220
src/mzscheme/src/jit_ts_runtime_glue.c Normal file
View File

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

4
src/mzscheme/src/lightning/i386/core.h
View File

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

2
src/mzscheme/src/lightning/ppc/core.h
View File

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

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

@ -5413,6 +5413,8 @@ static int native_unclosed_proc_plus_case_FIXUP(void *p) {
#ifdef MARKS_FOR_FUTURE_C
#ifdef FUTURES_ENABLED
static int future_SIZE(void *p) {
return
gcBYTES_TO_WORDS(sizeof(future_t));
@ -5420,13 +5422,20 @@ static int future_SIZE(void *p) {
static int future_MARK(void *p) {
future_t *f = (future_t *)p;
gcMARK(f->runstack);
gcMARK(f->runstack_start);
gcMARK(f->orig_lambda);
gcMARK(f->prim_data.p);
gcMARK(f->prim_data.argv);
gcMARK(f->prim_data.retval);
gcMARK(f->arg_s0);
gcMARK(f->arg_S0);
gcMARK(f->arg_b0);
gcMARK(f->arg_n0);
gcMARK(f->arg_s1);
gcMARK(f->arg_S1);
gcMARK(f->arg_s2);
gcMARK(f->arg_S2);
gcMARK(f->retval_s);
gcMARK(f->retval);
gcMARK(f->multiple_array);
gcMARK(f->tail_rator);
gcMARK(f->tail_rands);
gcMARK(f->prev);
gcMARK(f->next);
gcMARK(f->next_waiting_atomic);
@ -5436,13 +5445,20 @@ static int future_MARK(void *p) {
static int future_FIXUP(void *p) {
future_t *f = (future_t *)p;
gcFIXUP(f->runstack);
gcFIXUP(f->runstack_start);
gcFIXUP(f->orig_lambda);
gcFIXUP(f->prim_data.p);
gcFIXUP(f->prim_data.argv);
gcFIXUP(f->prim_data.retval);
gcFIXUP(f->arg_s0);
gcFIXUP(f->arg_S0);
gcFIXUP(f->arg_b0);
gcFIXUP(f->arg_n0);
gcFIXUP(f->arg_s1);
gcFIXUP(f->arg_S1);
gcFIXUP(f->arg_s2);
gcFIXUP(f->arg_S2);
gcFIXUP(f->retval_s);
gcFIXUP(f->retval);
gcFIXUP(f->multiple_array);
gcFIXUP(f->tail_rator);
gcFIXUP(f->tail_rands);
gcFIXUP(f->prev);
gcFIXUP(f->next);
gcFIXUP(f->next_waiting_atomic);
@ -5454,6 +5470,39 @@ static int future_FIXUP(void *p) {
#define future_IS_CONST_SIZE 1
#else
static int sequential_future_SIZE(void *p) {
return
gcBYTES_TO_WORDS(sizeof(future_t));
}
static int sequential_future_MARK(void *p) {
future_t *f = (future_t *)p;
gcMARK(f->orig_lambda);
gcMARK(f->running_sema);
gcMARK(f->retval);
gcMARK(f->multiple_array);
return
gcBYTES_TO_WORDS(sizeof(future_t));
}
static int sequential_future_FIXUP(void *p) {
future_t *f = (future_t *)p;
gcFIXUP(f->orig_lambda);
gcFIXUP(f->running_sema);
gcFIXUP(f->retval);
gcFIXUP(f->multiple_array);
return
gcBYTES_TO_WORDS(sizeof(future_t));
}
#define sequential_future_IS_ATOMIC 0
#define sequential_future_IS_CONST_SIZE 1
#endif
#endif /* FUTURE */
/**********************************************************************/

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

@ -2220,16 +2220,25 @@ END jit;
START future;
#ifdef FUTURES_ENABLED
future {
mark:
future_t *f = (future_t *)p;
gcMARK(f->runstack);
gcMARK(f->runstack_start);
gcMARK(f->orig_lambda);
gcMARK(f->prim_data.p);
gcMARK(f->prim_data.argv);
gcMARK(f->prim_data.retval);
gcMARK(f->arg_s0);
gcMARK(f->arg_S0);
gcMARK(f->arg_b0);
gcMARK(f->arg_n0);
gcMARK(f->arg_s1);
gcMARK(f->arg_S1);
gcMARK(f->arg_s2);
gcMARK(f->arg_S2);
gcMARK(f->retval_s);
gcMARK(f->retval);
gcMARK(f->multiple_array);
gcMARK(f->tail_rator);
gcMARK(f->tail_rands);
gcMARK(f->prev);
gcMARK(f->next);
gcMARK(f->next_waiting_atomic);
@ -2237,6 +2246,21 @@ future {
gcBYTES_TO_WORDS(sizeof(future_t));
}
#else
sequential_future {
mark:
future_t *f = (future_t *)p;
gcMARK(f->orig_lambda);
gcMARK(f->running_sema);
gcMARK(f->retval);
gcMARK(f->multiple_array);
size:
gcBYTES_TO_WORDS(sizeof(future_t));
}
#endif
END future;
/**********************************************************************/

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

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

9
src/mzscheme/src/numcomp.c
View File

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

120
src/mzscheme/src/port.c
View File

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

9
src/mzscheme/src/print.c
View File

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

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

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

88
src/mzscheme/src/salloc.c
View File

@ -157,20 +157,11 @@ int scheme_main_setup(int no_auto_statics, Scheme_Env_Main _main, int argc, char
return scheme_main_stack_setup(no_auto_statics, call_with_basic, &d);
}
int scheme_main_stack_setup(int no_auto_statics, Scheme_Nested_Main _main, void *data)
static int do_main_stack_setup(int no_auto_statics, Scheme_Nested_Main _main, void *data)
{
void *stack_start;
int volatile return_code;
#ifdef IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS
if (pthread_key_create(&scheme_thread_local_key, NULL)) {
fprintf(stderr, "pthread key create failed");
abort();
}
#endif
scheme_init_os_thread();
#ifdef USE_THREAD_LOCAL
scheme_vars = scheme_get_thread_local_variables();
#endif
@ -187,6 +178,57 @@ int scheme_main_stack_setup(int no_auto_statics, Scheme_Nested_Main _main, void
return return_code;
}
int scheme_main_stack_setup(int no_auto_statics, Scheme_Nested_Main _main, void *data) XFORM_SKIP_PROC
{
#ifdef IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS
# ifdef INLINE_GETSPECIFIC_ASSEMBLY_CODE
/* Our [highly questionable] strategy for inlining pthread_getspecific() is taken from
the Go implementation (see "http://golang.org/src/libcgo/darwin_386.c").
In brief, we assume that thread-local variables are going to be
accessed via the gs segment register at offset 0x48 (i386) or 0x60 (x86_64),
and we also hardwire the therad-local key 0x108. Here we have to try to get
that particular key and double-check that it worked. */
pthread_key_t unwanted[16];
int num_unwanted = 0;
# endif
while (1) {
if (pthread_key_create(&scheme_thread_local_key, NULL)) {
fprintf(stderr, "pthread key create failed\n");
abort();
}
# ifdef INLINE_GETSPECIFIC_ASSEMBLY_CODE
if (scheme_thread_local_key == 0x108)
break;
else {
if (num_unwanted == 16) {
fprintf(stderr, "pthread key create never produced 0x108 for inline hack\n");
abort();
}
unwanted[num_unwanted++] = scheme_thread_local_key;
}
# else
break;
# endif
}
# ifdef INLINE_GETSPECIFIC_ASSEMBLY_CODE
pthread_setspecific(scheme_thread_local_key, (void *)0xaced);
if (scheme_get_thread_local_variables() != (Thread_Local_Variables *)0xaced) {
fprintf(stderr, "pthread getspecific inline hack failed\n");
abort();
}
while (num_unwanted--) {
pthread_key_delete(unwanted[num_unwanted]);
}
# endif
#endif
scheme_init_os_thread();
return do_main_stack_setup(no_auto_statics, _main, data);
}
void scheme_set_stack_bounds(void *base, void *deepest, int no_auto_statics)
{
scheme_set_stack_base(base, no_auto_statics);
@ -233,24 +275,13 @@ extern void GC_attach_current_thread_exceptions_to_handler();
# endif
#endif
#ifdef MZ_XFORM
START_XFORM_SKIP;
#endif
void scheme_init_os_thread()
void scheme_init_os_thread() XFORM_SKIP_PROC
{
#ifdef IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS
Thread_Local_Variables *vars;
vars = (Thread_Local_Variables *)malloc(sizeof(Thread_Local_Variables));
memset(vars, 0, sizeof(Thread_Local_Variables));
pthread_setspecific(scheme_thread_local_key, vars);
# ifdef OS_X
/* A hack that smehow avoids a problem with calling vm_allocate()
later. There must be some deeper bug that I have't found, yet. */
if (1) {
void *r;
vm_allocate(mach_task_self(), (vm_address_t*)&r, 4096, TRUE);
}
# endif
#endif
#ifdef OS_X
# ifdef MZ_PRECISE_GC
@ -258,9 +289,6 @@ void scheme_init_os_thread()
# endif
#endif
}
#ifdef MZ_XFORM
END_XFORM_SKIP;
#endif
/************************************************************************/
/* memory utils */
@ -535,11 +563,7 @@ void *scheme_malloc_uncollectable(size_t size_in_bytes)
}
#endif
#ifdef MZ_XFORM
START_XFORM_SKIP;
#endif
void scheme_register_static(void *ptr, long size)
void scheme_register_static(void *ptr, long size) XFORM_SKIP_PROC
{
#if defined(MZ_PRECISE_GC) || defined(USE_SENORA_GC)
/* Always register for precise and Senora GC: */
@ -553,10 +577,6 @@ void scheme_register_static(void *ptr, long size)
#endif
}
#ifdef MZ_XFORM
END_XFORM_SKIP;
#endif
#ifdef USE_TAGGED_ALLOCATION
struct GC_Set *tagged, *real_tagged, *tagged_atomic, *tagged_eternal, *tagged_uncollectable, *stacks, *envunbox;

2
src/mzscheme/src/schnapp.inc
View File

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

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

@ -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,

5
src/mzscheme/src/setjmpup.c
View File

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

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

@ -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>
static char *mzGETENV(char *s)
{
int sz, got;
char *res;
/***********************************************************************/
/* Environment Variables */
/***********************************************************************/
sz = GetEnvironmentVariable(s, NULL, 0);
if (!sz)
return NULL;
res = scheme_malloc_atomic(sz);
got = GetEnvironmentVariable(s, res, sz);
if (got < sz)
res[got] = 0;
return res;
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
static char* clone_str_with_gc(const char* buffer) {
int length;
char *newbuffer;
length = strlen(buffer);
newbuffer = scheme_malloc_atomic(length+1);
memcpy(newbuffer, buffer, length+1);
return newbuffer;
}
static int mzPUTENV(char *var, char *val, char *together)
{
return !SetEnvironmentVariable(var, val);
}
#else
# define mzGETENV getenv
# define mzPUTENV(var, val, s) MSC_IZE(putenv)(s)
#endif
static void create_putenv_str_table_if_needed() {
if (!putenv_str_table) {
putenv_str_table = scheme_make_hash_table(SCHEME_hash_string);
}
}
#ifndef DOS_FILE_SYSTEM
static void putenv_str_table_put_name(Scheme_Object *name, Scheme_Object *value) {
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
void *original_gc;
Scheme_Object *name_copy;
original_gc = GC_switch_to_master_gc();
name_copy = (Scheme_Object *) clone_str_with_gc((Scheme_Object *) name);
create_putenv_str_table_if_needed();
scheme_hash_set(putenv_str_table, name_copy, value);
GC_switch_back_from_master(original_gc);
#else
create_putenv_str_table_if_needed();
scheme_hash_set(putenv_str_table, name, value);
#endif
}
#endif
#ifndef GETENV_FUNCTION
static void putenv_str_table_put_name_value(Scheme_Object *name, Scheme_Object *value) {
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
void *original_gc;
Scheme_Object *name_copy;
Scheme_Object *value_copy;
original_gc = GC_switch_to_master_gc();
name_copy = (Scheme_Object *) clone_str_with_gc((Scheme_Object *) name);
value_copy = (Scheme_Object *) clone_str_with_gc((Scheme_Object *) value);
create_putenv_str_table_if_needed();
scheme_hash_set(putenv_str_table, name_copy, value_copy);
GC_switch_back_from_master(original_gc);
#else
create_putenv_str_table_if_needed();
scheme_hash_set(putenv_str_table, name, value);
#endif
}
#endif
#if !defined(GETENV_FUNCTION) || defined(MZ_PRECISE_GC)
static Scheme_Object *putenv_str_table_get(Scheme_Object *name) {
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
void *original_gc;
Scheme_Object *value;
original_gc = GC_switch_to_master_gc();
create_putenv_str_table_if_needed();
value = scheme_hash_get(putenv_str_table, name);
GC_switch_back_from_master(original_gc);
return value;
#else
create_putenv_str_table_if_needed();
return scheme_hash_get(putenv_str_table, name);
#endif
}
#endif
static Scheme_Object *sch_bool_getenv(const char* name);
void
scheme_init_getenv(void)
{
@ -2017,126 +2068,164 @@ scheme_init_getenv(void)
scheme_current_thread->error_buf = &newbuf;
if (!scheme_setjmp(newbuf)) {
while (1) {
Scheme_Object *v = scheme_read(p);
if (SCHEME_EOFP(v))
break;
Scheme_Object *v = scheme_read(p);
if (SCHEME_EOFP(v))
break;
if (SCHEME_PAIRP(v) && SCHEME_PAIRP(SCHEME_CDR(v))
&& SCHEME_NULLP(SCHEME_CDR(SCHEME_CDR(v)))) {
Scheme_Object *key = SCHEME_CAR(v);
Scheme_Object *val = SCHEME_CADR(v);
if (SCHEME_STRINGP(key) && SCHEME_STRINGP(val)) {
Scheme_Object *a[2];
a[0] = key;
a[1] = val;
sch_putenv(2, a);
v = NULL;
}
}
if (SCHEME_PAIRP(v) && SCHEME_PAIRP(SCHEME_CDR(v))
&& SCHEME_NULLP(SCHEME_CDR(SCHEME_CDR(v)))) {
Scheme_Object *key = SCHEME_CAR(v);
Scheme_Object *val = SCHEME_CADR(v);
if (SCHEME_STRINGP(key) && SCHEME_STRINGP(val)) {
Scheme_Object *a[2];
a[0] = key;
a[1] = val;
sch_putenv(2, a);
v = NULL;
}
}
if (v)
scheme_signal_error("bad environment specification: %V", v);
if (v)
scheme_signal_error("bad environment specification: %V", v);
}
}
scheme_current_thread->error_buf = savebuf;
scheme_close_input_port(p);
if (scheme_hash_get(putenv_str_table, (Scheme_Object *)"PLTNOMZJIT")) {
scheme_set_startup_use_jit(0);
}
}
#else
if (mzGETENV("PLTNOMZJIT")) {
scheme_set_startup_use_jit(0);
}
#endif
if (sch_bool_getenv("PLTNOMZJIT")) {
scheme_set_startup_use_jit(0);
}
}
#ifdef DOS_FILE_SYSTEM
# include <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])
|| scheme_any_string_has_null(argv[0]))
if (!SCHEME_CHAR_STRINGP(argv[0]) || scheme_any_string_has_null(argv[0]))
scheme_wrong_type("getenv", CHAR_STRING_W_NO_NULLS, 0, argc, argv);
bs = scheme_char_string_to_byte_string_locale(argv[0]);
name = SCHEME_BYTE_STR_VAL(bs);
#ifdef GETENV_FUNCTION
s = mzGETENV(SCHEME_BYTE_STR_VAL(bs));
# ifdef DOS_FILE_SYSTEM
value = dos_win_getenv(name);
# else
value = getenv(name);
# endif
#else
if (putenv_str_table) {
s = (char *)scheme_hash_get(putenv_str_table, (Scheme_Object *)SCHEME_BYTE_STR_VAL(argv[0]));
/* If found, skip over the `=' in the table: */
if (s)
s += SCHEME_BYTE_STRTAG_VAL(bs) + 1;
} else
s = NULL;
#endif
if (s)
return scheme_make_locale_string(s);
return scheme_false;
}
static Scheme_Object *sch_putenv(int argc, Scheme_Object *argv[])
{
char *s, *var, *val;
long varlen, vallen;
Scheme_Object *bs;
if (!SCHEME_CHAR_STRINGP(argv[0])
|| scheme_any_string_has_null(argv[0]))
scheme_wrong_type("putenv", CHAR_STRING_W_NO_NULLS, 0, argc, argv);
if (!SCHEME_CHAR_STRINGP(argv[1])
|| scheme_any_string_has_null(argv[1]))
scheme_wrong_type("putenv", CHAR_STRING_W_NO_NULLS, 1, argc, argv);
bs = scheme_char_string_to_byte_string_locale(argv[0]);
var = SCHEME_BYTE_STR_VAL(bs);
bs = scheme_char_string_to_byte_string_locale(argv[1]);
val = SCHEME_BYTE_STR_VAL(bs);
varlen = strlen(var);
vallen = strlen(val);
s = (char *)scheme_malloc_atomic(varlen + vallen + 2);
memcpy(s, var, varlen);
memcpy(s + varlen + 1, val, vallen + 1);
s[varlen] = '=';
#ifdef MZ_PRECISE_GC
{
/* Can't put moveable string into array. */
char *ss;
ss = s;
s = malloc(varlen + vallen + 2);
memcpy(s, ss, varlen + vallen + 2);
/* Free old, if in table: */
if (putenv_str_table) {
ss = (char *)scheme_hash_get(putenv_str_table, (Scheme_Object *)var);
if (ss)
free(ss);
}
Scheme_Object *hash_value;
hash_value = putenv_str_table_get(name);
return hash_value ? hash_value : scheme_false;
}
#endif
if (!putenv_str_table)
putenv_str_table = scheme_make_hash_table(SCHEME_hash_string);
return value ? scheme_make_locale_string(value) : scheme_false;
}
scheme_hash_set(putenv_str_table, (Scheme_Object *)var, (Scheme_Object *)s);
static int sch_unix_putenv(const char *var, const char *val, const long varlen, const long vallen) {
char *buffer;
long total_length;
total_length = varlen + vallen + 2;
#ifdef MZ_PRECISE_GC
/* Can't put moveable string into array. */
buffer = malloc(total_length);
#else
buffer = (char *)scheme_malloc_atomic(total_length);
#endif
memcpy(buffer, var, varlen);
buffer[varlen] = '=';
memcpy(buffer + varlen + 1, val, vallen + 1);
#ifdef MZ_PRECISE_GC
{
/* Free old, if in table: */
char *oldbuffer;
oldbuffer = (char *)putenv_str_table_get((Scheme_Object *)var);
if (oldbuffer)
free(oldbuffer);
}
#endif
/* if precise the buffer needs to be remembered so it can be freed */
/* if not precise the buffer needs to be rooted so it doesn't get collected prematurely */
putenv_str_table_put_name((Scheme_Object *)var, (Scheme_Object *)buffer);
return putenv(buffer);
}
static Scheme_Object *sch_putenv(int argc, Scheme_Object *argv[])
{
Scheme_Object *varbs;
Scheme_Object *valbs;
char *var;
char *val;
int rc = 0;
if (!SCHEME_CHAR_STRINGP(argv[0]) || scheme_any_string_has_null(argv[0]))
scheme_wrong_type("putenv", CHAR_STRING_W_NO_NULLS, 0, argc, argv);
if (!SCHEME_CHAR_STRINGP(argv[1]) || scheme_any_string_has_null(argv[1]))
scheme_wrong_type("putenv", CHAR_STRING_W_NO_NULLS, 1, argc, argv);
varbs = scheme_char_string_to_byte_string_locale(argv[0]);
var = SCHEME_BYTE_STR_VAL(varbs);
valbs = scheme_char_string_to_byte_string_locale(argv[1]);
val = SCHEME_BYTE_STR_VAL(valbs);
#ifdef GETENV_FUNCTION
return mzPUTENV(var, val, s) ? scheme_false : scheme_true;
# ifdef DOS_FILE_SYSTEM
rc = !SetEnvironmentVariable(var, val);
# else
rc = sch_unix_putenv(var, val, SCHEME_BYTE_STRLEN_VAL(varbs), SCHEME_BYTE_STRLEN_VAL(valbs));
# endif
#else
return scheme_true;
putenv_str_table_put_name_value(argv[0], argv[1]);
#endif
return rc ? scheme_false : scheme_true;
}
/***********************************************************************/
/* End Environment Variables */
/***********************************************************************/
static void machine_details(char *s);
static Scheme_Object *system_type(int argc, Scheme_Object *argv[])

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

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

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

@ -1550,14 +1550,11 @@ Scheme_Thread *scheme_do_close_managed(Scheme_Custodian *m, Scheme_Exit_Closer_F
return kill_self;
}
#ifdef MZ_XFORM
START_XFORM_SKIP;
#endif
typedef void (*Scheme_For_Each_Func)(Scheme_Object *);
static void for_each_managed(Scheme_Type type, Scheme_For_Each_Func cf)
/* This function must not allocate. */
XFORM_SKIP_PROC
/* This function must not allocate. */
{
Scheme_Custodian *m;
int i;
@ -1600,10 +1597,6 @@ static void for_each_managed(Scheme_Type type, Scheme_For_Each_Func cf)
}
}
#ifdef MZ_XFORM
END_XFORM_SKIP;
#endif
void scheme_close_managed(Scheme_Custodian *m)
/* The trick is that we may need to kill the thread
that is running us. If so, delay it to the very
@ -2436,11 +2429,8 @@ void *scheme_tls_get(int pos)
return p->user_tls[pos];
}
#ifdef MZ_XFORM
START_XFORM_SKIP;
#endif
Scheme_Object **scheme_alloc_runstack(long len)
XFORM_SKIP_PROC
{
#ifdef MZ_PRECISE_GC
long sz;
@ -2458,6 +2448,7 @@ Scheme_Object **scheme_alloc_runstack(long len)
}
void scheme_set_runstack_limits(Scheme_Object **rs, long len, long start, long end)
XFORM_SKIP_PROC
/* With 3m, we can tell the GC not to scan the unused parts, and we
can have the fixup function zero out the unused parts; that avoids
writing and scanning pages that could be skipped for a minor
@ -2474,10 +2465,6 @@ void scheme_set_runstack_limits(Scheme_Object **rs, long len, long start, long e
#endif
}
#ifdef MZ_XFORM
END_XFORM_SKIP;
#endif
/*========================================================================*/
/* thread creation and swapping */
/*========================================================================*/
@ -6842,11 +6829,8 @@ static Scheme_Object *current_thread_initial_stack_size(int argc, Scheme_Object
/* namespaces */
/*========================================================================*/
#ifdef MZ_XFORM
START_XFORM_SKIP;
#endif
Scheme_Env *scheme_get_env(Scheme_Config *c)
XFORM_SKIP_PROC
{
Scheme_Object *o;
@ -6857,10 +6841,6 @@ Scheme_Env *scheme_get_env(Scheme_Config *c)
return (Scheme_Env *)o;
}
#ifdef MZ_XFORM
END_XFORM_SKIP;
#endif
void scheme_add_namespace_option(Scheme_Object *key, void (*f)(Scheme_Env *))
{
Scheme_NSO *old = namespace_options;
@ -7428,7 +7408,8 @@ static void done_with_GC()
#ifdef MZ_PRECISE_GC
static void inform_GC(int major_gc, long pre_used, long post_used)
{
if (scheme_main_logger) {
Scheme_Logger *logger = scheme_get_main_logger();
if (logger) {
/* Don't use scheme_log(), because it wants to allocate a buffer
based on the max value-print width, and we may not be at a
point where parameters are available. */
@ -7442,10 +7423,7 @@ static void inform_GC(int major_gc, long pre_used, long post_used)
end_this_gc_time - start_this_gc_time);
buflen = strlen(buf);
scheme_log_message(scheme_main_logger,
SCHEME_LOG_DEBUG,
buf, buflen,
NULL);
scheme_log_message(logger, SCHEME_LOG_DEBUG, buf, buflen, NULL);
}
}