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

Merge branch 'master' of pltgit:plt

Browse Source
This commit is contained in:
Stephen Bloch 2011-04-28 21:58:21 -04:00
commit 8fb0f8840d
47 changed files with 742 additions and 414 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/framework/private/main.rkt
View File

@ -221,11 +221,13 @@
'(struct '(struct
local local
define-type struct: define-struct: define-struct/exec:
define:
define-type define-predicate
match-define)) match-define))
(for-each (λ (x) (for-each (λ (x)
(hash-set! hash-table x 'begin)) (hash-set! hash-table x 'begin))
'(case-lambda '(case-lambda case-lambda: pcase-lambda:
match-lambda match-lambda* match-lambda match-lambda*
cond cond
delay delay
@ -250,11 +252,20 @@
let/cc let/ec letcc catch let/cc let/ec letcc catch
let-syntax letrec-syntax fluid-let-syntax letrec-syntaxes+values let-syntax letrec-syntax fluid-let-syntax letrec-syntaxes+values
let: letrec: let*:
let-values: letrec-values: let*-values:
let/cc: let/ec:
lambda: λ:
plambda: opt-lambda: popt-lambda:
for for/list for/hash for/hasheq for/and for/or for for/list for/hash for/hasheq for/and for/or
for/lists for/first for/last for/fold for/lists for/first for/last for/fold
for* for*/list for*/hash for*/hasheq for*/and for*/or for* for*/list for*/hash for*/hasheq for*/and for*/or
for*/lists for*/first for*/last for*/fold for*/lists for*/first for*/last for*/fold
for: for/list: for/or: for/lists: for/fold:
for*: for*/lists: for*/fold: do:
kernel-syntax-case kernel-syntax-case
syntax-case syntax-case* syntax-rules syntax-id-rules syntax-case syntax-case* syntax-rules syntax-id-rules
let-signature fluid-let let-signature fluid-let

6
collects/redex/examples/stlc.rkt
View File

@ -154,10 +154,16 @@
(test-equal (term (tc x)) (term #f)) (test-equal (term (tc x)) (term #f))
(test-equal (term (tc x (x num) (x (-> num num)))) (term num)) (test-equal (term (tc x (x num) (x (-> num num)))) (term num))
(test-equal (term (tc ((λ ((x num)) x) 1))) (term num)) (test-equal (term (tc ((λ ((x num)) x) 1))) (term num))
(test-equal (term (tc ((λ ((x num)) x) 1 2))) (term #f))
(test-equal (term (tc ((λ ((f (-> num num)) (x num)) (f x)) (λ ((x num)) x) 1))) (term num)) (test-equal (term (tc ((λ ((f (-> num num)) (x num)) (f x)) (λ ((x num)) x) 1))) (term num))
(test-equal (term (tc (+ (+ 1 2) 3))) (term num)) (test-equal (term (tc (+ (+ 1 2) 3))) (term num))
(test-equal (term (tc (if0 1 (λ ((x num)) x) 3))) (term #f)) (test-equal (term (tc (if0 1 (λ ((x num)) x) 3))) (term #f))
(test-equal (term (tc (if0 1 2 3))) (term num)) (test-equal (term (tc (if0 1 2 3))) (term num))
(test-equal (term (tc (λ ((x num)) (x)))) (term #f)) (test-equal (term (tc (λ ((x num)) (x)))) (term #f))
(test-equal (term (tc (1 2)))
(term #f))
(test-equal (term (tc (λ ((x num)) (1 2))))
(term #f))
(test-results) (test-results)

2
collects/scribblings/reference/futures.scrbl
View File

@ -23,7 +23,7 @@ The @racket[future] and @racket[touch] functions from
by the hardware and operating system. In contrast to @racket[thread], by the hardware and operating system. In contrast to @racket[thread],
which provides concurrency for arbitrary computations without which provides concurrency for arbitrary computations without
parallelism, @racket[future] provides parallelism for limited parallelism, @racket[future] provides parallelism for limited
computations. A future executes its work in parallel (assuming that computations. A @deftech{future} executes its work in parallel (assuming that
support for parallelism is available) until it detects an attempt to support for parallelism is available) until it detects an attempt to
perform an operation that is too complex for the system to run safely in perform an operation that is too complex for the system to run safely in
parallel. Similarly, work in a future is suspended if it depends in some parallel. Similarly, work in a future is suspended if it depends in some

25
collects/stepper/break.rkt
View File

@ -1,25 +0,0 @@
(module break mzscheme
(require mzlib/contract)
(provide current-breakpoint-handler)
(define (default-current-breakpoint-handler)
(error 'default-current-breakpoint-handler
"The current-breakpoint-handler parameter has not yet been set in this thread."))
(define current-breakpoint-handler
(make-parameter
default-current-breakpoint-handler
(lambda (new-handler)
(if (and (procedure? new-handler)
(procedure-arity-includes? new-handler 0))
new-handler
(error 'current-breakpoint-handler
"Bad value for current-breakpoint-handler: ~e"
new-handler)))))
(provide/contract [break (-> any)])
(define (break)
((current-breakpoint-handler))))

14
collects/stepper/info.rkt
View File

@ -1,15 +1,11 @@
#lang setup/infotab #lang setup/infotab
(define tools '(("stepper+xml-tool.ss") (define drracket-tools '(("stepper+xml-tool.ss")))
;; ("debugger-tool.ss")
))
(define tool-names (list "The Stepper" (define drracket-tool-names (list "The Stepper"))
;; "The Debugger"
))
(define tool-icons (list '("foot-up.png" "icons") (define drracket-tool-icons (list '("foot-up.png" "icons")))
;; #f
))
(define compile-omit-paths '("debugger-tool.ss")) (define compile-omit-paths '("debugger-tool.ss"))
(define scribblings '(("scribblings/stepper.scrbl")))

24
collects/stepper/view-controller.rkt → collects/stepper/private/view-controller.rkt
View File

@ -6,21 +6,21 @@
(require racket/class (require racket/class
racket/match racket/match
racket/list racket/list
drscheme/tool drracket/tool
mred mred
string-constants string-constants
racket/async-channel racket/async-channel
(prefix-in model: "private/model.ss") (prefix-in model: "model.ss")
(prefix-in x: "private/mred-extensions.ss") (prefix-in x: "mred-extensions.ss")
"private/shared.ss" "shared.ss"
"private/model-settings.ss" "model-settings.ss"
"xml-sig.ss") "xml-sig.ss")
(import drscheme:tool^ xml^ stepper-frame^) (import drracket:tool^ xml^ stepper-frame^)
(export view-controller^) (export view-controller^)
(define drscheme-eventspace (current-eventspace)) (define drracket-eventspace (current-eventspace))
(define (definitions-text->settings definitions-text) (define (definitions-text->settings definitions-text)
(send definitions-text get-next-settings)) (send definitions-text get-next-settings))
@ -28,12 +28,12 @@
;; the stored representation of a step ;; the stored representation of a step
(define-struct step (text kind posns) #:transparent) (define-struct step (text kind posns) #:transparent)
(define (go drscheme-frame program-expander selection-start selection-end) (define (go drracket-tab program-expander selection-start selection-end)
;; get the language-level: ;; get the language-level:
(define language-settings (definitions-text->settings (send drscheme-frame get-definitions-text))) (define language-settings (definitions-text->settings (send drracket-tab get-defs)))
(define language-level (drscheme:language-configuration:language-settings-language language-settings)) (define language-level (drracket:language-configuration:language-settings-language language-settings))
(define simple-settings (drscheme:language-configuration:language-settings-settings language-settings)) (define simple-settings (drracket:language-configuration:language-settings-settings language-settings))
;; VALUE CONVERSION CODE: ;; VALUE CONVERSION CODE:
@ -211,7 +211,7 @@
;; GUI ELEMENTS: ;; GUI ELEMENTS:
(define s-frame (define s-frame
(make-object stepper-frame% drscheme-frame)) (make-object stepper-frame% drracket-tab))
(define button-panel (define button-panel
(make-object horizontal-panel% (send s-frame get-area-container))) (make-object horizontal-panel% (send s-frame get-area-container)))
(define (add-button name fun) (define (add-button name fun)

0
collects/stepper/xml-sig.rkt → collects/stepper/private/xml-sig.rkt
View File

177
collects/stepper/scribblings/stepper.scrbl Normal file
View File

@ -0,0 +1,177 @@
#lang scribble/doc
@(require scribble/manual)
@title{The Stepper}
@section{What is the Stepper?}
DrRacket includes an "algebraic stepper," a tool which proceeds
through the evaluation of a set of definitions and expressions,
one step at a time. This evaluation shows the user how DrRacket
evaluates expressions and definitions, and can help in debugging
programs. Currently, the Stepper is available in the "Beginning
Student" and "Intermediate Student" language levels.
@section{How do I use the Stepper?}
The Stepper operates on the contents of the frontmost DrRacket
window. A click on the "Step" button brings up the stepper
window. The stepper window has two panes, arranged as follows:
@verbatim{
------------------
| | |
| before -> after|
| | |
------------------
}
The first, "before," box, shows the current expression. The
region highlighted in green is known as the "redex". You may
pronounce this word in any way you want. It is short for
"reducible expression," and it is the expression which is the
next to be simplified.
The second, "after," box shows the result of the reduction. The
region highlighted in purple is the new expression which is
substituted for the green one as a result of the reduction. For
most reductions, the only difference between the left- and right-hand
sides should be the contents of the green and purple boxes.
Please note that the stepper only steps through the expressions
in the definitions window, and does not allow the user to enter
additional expressions. So, for instance, a definitions buffer
which contains only procedure definitions will not result in
any reductions.
@section{How Does the Stepper work?}
In order to discover all of the steps that occur during the evaluation
of your code, the Stepper rewrites (or "instruments") your code.
The inserted code uses a mechanism called "continuation marks" to
store information about the program's execution as it is running,
and makes calls to the Stepper before, after and during the evaluation
of each expression, indicating the current shape of the program.
What does this instrumented code look like? For the curious, here's the
expanded version of @racket[(define (f x) (+ 3 x))] in the beginner
language [*]:
@racketblock[
(module #%htdp (lib "lang/htdp-beginner.ss")
(#%plain-module-begin
(define-syntaxes (f)
(#%app make-first-order-function
(quote procedure)
(quote 1)
(quote-syntax f)
(quote-syntax #%app)))
(define-values (test~object) (#%app namespace-variable-value (quote test~object)))
(begin
(define-values (f)
(with-continuation-mark "#<debug-key-struct>"
(#%plain-lambda () (#%plain-app "#<procedure:...rivate/marks.rkt:70:2>"))
(#%plain-app
call-with-values
(#%plain-lambda ()
(with-continuation-mark "#<debug-key-struct>"
(#%plain-lambda () (#%plain-app
"#<procedure:...rivate/marks.rkt:70:2>"
(#%plain-lambda () beginner:+)))
(#%plain-app
"#<procedure:closure-storing-proc>"
(#%plain-lambda (x)
(begin
(let-values (((arg0-1643 arg1-1644 arg2-1645)
(#%plain-app
values
"#<*unevaluated-struct*>"
"#<*unevaluated-struct*>"
"#<*unevaluated-struct*>")))
(with-continuation-mark "#<debug-key-struct>"
(#%plain-lambda ()
(#%plain-app
"#<procedure:...rivate/marks.rkt:70:2>"
(#%plain-lambda () beginner:+)
(#%plain-lambda () x)
(#%plain-lambda () arg0-1643)
(#%plain-lambda () arg1-1644)
(#%plain-lambda () arg2-1645)))
(begin
(#%plain-app "#<procedure:result-exp-break>")
(begin
(set! arg0-1643
(with-continuation-mark "#<debug-key-struct>"
(#%plain-lambda ()
(#%plain-app
"#<procedure:...rivate/marks.rkt:70:2>"))
beginner:+))
(set! arg1-1644
(with-continuation-mark "#<debug-key-struct>"
(#%plain-lambda ()
(#%plain-app
"#<procedure:...rivate/marks.rkt:70:2>"))
(quote 3)))
(set! arg2-1645
(with-continuation-mark "#<debug-key-struct>"
(#%plain-lambda ()
(#%plain-app
"#<procedure:...rivate/marks.rkt:70:2>")) x))
(begin
(#%plain-app "#<procedure:normal-break>")
(with-continuation-mark "#<debug-key-struct>"
(#%plain-lambda ()
(#%plain-app
"#<procedure:...rivate/marks.rkt:70:2>"
(#%plain-lambda () arg0-1643)
(#%plain-lambda () arg1-1644)
(#%plain-lambda () arg2-1645)))
(if (#%plain-app
"#<procedure:annotated-proc?>"
arg0-1643)
(#%plain-app
arg0-1643
arg1-1644
arg2-1645)
(#%plain-app
call-with-values
(#%plain-lambda ()
(#%plain-app arg0-1643 arg1-1644 arg2-1645))
(#%plain-lambda args
(#%plain-app
"#<procedure:result-value-break>"
args)
(#%plain-app
"#<procedure:apply>"
values
args))))))))))))
(#%plain-lambda ()
(#%plain-app
"#<procedure:...rivate/marks.rkt:70:2>"
(#%plain-lambda () beginner:+))) #f)))
(#%plain-lambda args
(#%plain-app "#<procedure:apply>" values args)))))
(#%plain-app "#<procedure:exp-finished-break>"
(#%plain-app
list
(#%plain-app
list
"#<procedure:...ate/annotate.rkt:1256:93>"
#f
(#%plain-lambda () (#%plain-app list f))))))))
(let-values (((done-already?) (quote #f)))
(#%app dynamic-wind void
(lambda () (#%app dynamic-require (quote (quote #%htdp)) (quote #f)))
(lambda () (if done-already?
(#%app void)
(let-values ()
(set! done-already? (quote #t))
(#%app test*)
(#%app current-namespace
(#%app module->namespace
(quote (quote #%htdp)))))))))]
[*] : In order to allow things like @verbatim{#<procedure:apply>} in scribble, I've taken the cheap solution of wrapping them in quotes. These are not actually strings, they're opaque 3D syntax elements.

28
collects/stepper/stepper+xml-tool.rkt
View File

@ -1,25 +1,19 @@
(module stepper+xml-tool mzscheme #lang racket
(require mzlib/unit
drscheme/tool
"stepper-tool.ss"
"xml-tool.ss"
"view-controller.ss"
"private/shared.ss")
(provide tool@) (require drracket/tool
"stepper-tool.rkt"
"xml-tool.rkt"
"private/view-controller.rkt")
;; the xml and stepper tools are combined, so that the stepper can create XML (provide tool@)
;; snips. note that both of these tools provide 'void' for phase1 and phase2
;; (which together make up the tool-exports^), so we can provide either one
;; of these for the compound unit. Doesn't matter.
;; NNNURRRG! This is not true any more. But that should be okay, because the ;; the xml and stepper tools are combined, so that the stepper can create XML
;; stepper-tool phase1 is the non-void one. -- JBC, 2006-09-28 ;; snips.
(define tool@ (define tool@
(compound-unit/infer (compound-unit/infer
(import drscheme:tool^) (import drracket:tool^)
(export STEPPER-TOOL) (export STEPPER-TOOL)
(link xml-tool@ (link xml-tool@
view-controller@ view-controller@
[((STEPPER-TOOL : drscheme:tool-exports^)) stepper-tool@])))) [((STEPPER-TOOL : drracket:tool-exports^)) stepper-tool@])))

244
collects/stepper/stepper-tool.rkt
View File

@ -1,27 +1,26 @@
#lang racket/unit #lang racket/unit
(require scheme/class (require racket/class
drscheme/tool drracket/tool
mred mred
mzlib/pconvert
string-constants
(prefix-in frame: framework) (prefix-in frame: framework)
mrlib/switchable-button mrlib/switchable-button
(file "private/my-macros.ss") mzlib/pconvert
(prefix-in x: "private/mred-extensions.ss") racket/pretty
"private/shared.ss" string-constants
lang/stepper-language-interface lang/stepper-language-interface
scheme/pretty (prefix-in x: "private/mred-extensions.rkt")
"xml-sig.ss" "private/shared.rkt"
"private/xml-sig.rkt"
"drracket-button.ss") ;; get the stepper-button-callback private-member-name "drracket-button.ss") ;; get the stepper-button-callback private-member-name
(import drscheme:tool^ xml^ view-controller^) (import drracket:tool^ xml^ view-controller^)
(export drscheme:tool-exports^ stepper-frame^) (export drracket:tool-exports^ stepper-frame^)
;; tool magic here: ;; tool magic here:
(define (phase1) (define (phase1)
;; experiment with extending the language... parameter-like fields for stepper parameters ;; experiment with extending the language... parameter-like fields for stepper parameters
(drscheme:language:extend-language-interface (drracket:language:extend-language-interface
stepper-language<%> stepper-language<%>
(lambda (superclass) (lambda (superclass)
(class* superclass (stepper-language<%>) (class* superclass (stepper-language<%>)
@ -67,7 +66,7 @@
(send definitions-text get-next-settings)) (send definitions-text get-next-settings))
(define (settings->language-level settings) (define (settings->language-level settings)
(drscheme:language-configuration:language-settings-language settings)) (drracket:language-configuration:language-settings-language settings))
(define (stepper-works-for? language-level) (define (stepper-works-for? language-level)
(or (send language-level stepper:supported?) (or (send language-level stepper:supported?)
@ -76,10 +75,10 @@
;; the stepper's frame: ;; the stepper's frame:
(define stepper-frame% (define stepper-frame%
(class (drscheme:frame:basics-mixin (class (drracket:frame:basics-mixin
(frame:frame:standard-menus-mixin frame:frame:basic%)) (frame:frame:standard-menus-mixin frame:frame:basic%))
(init-field drscheme-frame) (init-field drracket-tab)
;; PRINTING-PROC ;; PRINTING-PROC
;; I frankly don't think that printing (i.e., to a printer) works ;; I frankly don't think that printing (i.e., to a printer) works
@ -114,7 +113,7 @@
(define/augment (on-close) (define/augment (on-close)
(when custodian (when custodian
(custodian-shutdown-all custodian)) (custodian-shutdown-all custodian))
(send drscheme-frame on-stepper-close) (send drracket-tab on-stepper-close)
(inner (void) on-close)) (inner (void) on-close))
;; WARNING BOXES: ;; WARNING BOXES:
@ -153,20 +152,91 @@
[height stepper-initial-height]))) [height stepper-initial-height])))
;; stepper-unit-frame<%> : the interface that the extended drscheme frame ;; stepper-unit-frame<%> : the interface that the extended drracket frame
;; fulfils ;; fulfils
(define stepper-unit-frame<%> (define stepper-tab<%>
(interface () (interface ()
get-stepper-frame get-stepper-frame
on-stepper-close)) on-stepper-close))
;; stepper-unit-frame-mixin : the mixin that is applied to the drscheme ;; stepper-unit-frame-mixin : the mixin that is applied to the drracket
;; frame to interact with a possible stepper window ;; frame to interact with a possible stepper window. Specifically, this
;; mixin needs to manage the creation and visibility of the stepper button.
(define (stepper-unit-frame-mixin super%) (define (stepper-unit-frame-mixin super%)
(class* super% (stepper-unit-frame<%>) (class* super% ()
(inherit get-button-panel register-toolbar-button get-current-tab get-tabs)
(inherit get-button-panel register-toolbar-button get-interactions-text get-definitions-text) (super-new)
;; STEPPER BUTTON
(define/public (get-stepper-button) stepper-button)
(define stepper-button-parent-panel
(new horizontal-panel%
[parent (get-button-panel)]
[stretchable-width #f]
[stretchable-height #f]))
(define stepper-button
(new switchable-button%
[parent stepper-button-parent-panel]
[label (string-constant stepper-button-label)]
[bitmap x:foot-img/horizontal]
[alternate-bitmap x:foot-img/vertical]
[callback (lambda (dont-care) (send (get-current-tab)
stepper-button-callback))]))
(register-toolbar-button stepper-button)
(define (stepper-button-show)
(unless (send stepper-button is-shown?)
(send (send stepper-button get-parent)
add-child stepper-button)))
(define (stepper-button-hide)
(when (send stepper-button is-shown?)
(send (send stepper-button get-parent)
delete-child stepper-button)))
;; when the window closes, notify all of the stepper frames.
(define/augment (on-close)
(for ([tab (in-list (get-tabs))])
(define possible-stepper-frame (send tab get-stepper-frame))
(when possible-stepper-frame
(send possible-stepper-frame original-program-gone)))
(inner (void) on-close))
;; when we change tabs, show or hide the stepper button.
(define/augment (on-tab-change old new)
(show/hide-stepper-button)
(inner (void) on-tab-change old new))
;; add the stepper button to the button panel:
(send (get-button-panel) change-children
(lambda (x)
(cons stepper-button-parent-panel
(remq stepper-button-parent-panel x))))
;; show or hide the stepper button depending
;; on the language level
(define/public (show/hide-stepper-button)
(cond [(send (get-current-tab) current-lang-supports-stepper?)
(stepper-button-show)]
[else
(stepper-button-hide)]))
;; hide stepper button if it's not supported for the initial language:
(show/hide-stepper-button)))
;; stepper-tab-mixin : the mixin that is applied to drracket tabs, to
;; interact with a possible stepper window.
(define (stepper-tab-mixin super%)
(class* super% (stepper-tab<%>)
(inherit get-ints get-defs get-frame)
;; a reference to a possible stepper frame.
(define stepper-frame #f) (define stepper-frame #f)
(define/public (on-stepper-close) (define/public (on-stepper-close)
(set! stepper-frame #f)) (set! stepper-frame #f))
@ -178,14 +248,14 @@
;; definitions window one at a time and calls 'iter' on each one ;; definitions window one at a time and calls 'iter' on each one
(define (program-expander init iter) (define (program-expander init iter)
(let* ([lang-settings (let* ([lang-settings
(send (get-definitions-text) get-next-settings)] (send (get-defs) get-next-settings)]
[lang (drscheme:language-configuration:language-settings-language lang-settings)] [lang (drracket:language-configuration:language-settings-language lang-settings)]
[settings (drscheme:language-configuration:language-settings-settings lang-settings)]) [settings (drracket:language-configuration:language-settings-settings lang-settings)])
(drscheme:eval:expand-program (drracket:eval:expand-program
(drscheme:language:make-text/pos (drracket:language:make-text/pos
(get-definitions-text) (get-defs)
0 0
(send (get-definitions-text) last-position)) (send (get-defs) last-position))
lang-settings lang-settings
#f #f
(lambda () (lambda ()
@ -203,108 +273,75 @@
void ; kill void ; kill
iter))) iter)))
;; STEPPER BUTTON
(define/public (get-stepper-button) stepper-button) ;; called from drracket-button.rkt, installed via the #lang htdp/bsl (& co) reader into drracket
(define stepper-button-parent-panel
(new horizontal-panel%
[parent (get-button-panel)]
[stretchable-width #f]
[stretchable-height #f]))
;; called from drracket-button.rkt, installed via the #lang htdp/bsl (& co) reader into drscheme
(define/public (stepper-button-callback) (define/public (stepper-button-callback)
(if stepper-frame (cond
(send stepper-frame show #t) [stepper-frame (send stepper-frame show #t)]
[else (create-new-stepper)]))
;; open a new stepper window, start it running
(define (create-new-stepper)
(let* ([language-level (let* ([language-level
(extract-language-level (get-definitions-text))] (extract-language-level (get-defs))]
[language-level-name (language-level->name language-level)]) [language-level-name (language-level->name language-level)])
(if (or (stepper-works-for? language-level) (if (or (stepper-works-for? language-level)
(is-a? language-level drscheme:module-language:module-language<%>)) (is-a? language-level drracket:module-language:module-language<%>))
(set! stepper-frame (set! stepper-frame
(go this (go this
program-expander program-expander
(+ 1 (send (get-definitions-text) get-start-position)) (+ 1 (send (get-defs) get-start-position))
(+ 1 (send (get-definitions-text) get-end-position)))) (+ 1 (send (get-defs) get-end-position))))
(message-box (message-box
(string-constant stepper-name) (string-constant stepper-name)
(format (string-constant stepper-language-level-message) (format (string-constant stepper-language-level-message)
language-level-name)))))) language-level-name)))))
(define stepper-button (define/override (enable-evaluation)
(new switchable-button% (super enable-evaluation)
[parent stepper-button-parent-panel] (send (send (get-frame) get-stepper-button) enable #t))
[label (string-constant stepper-button-label)]
[bitmap x:foot-img/horizontal]
[alternate-bitmap x:foot-img/vertical]
[callback (lambda (dont-care) (stepper-button-callback))]))
(register-toolbar-button stepper-button) (define/override (disable-evaluation)
(super enable-evaluation)
(send (send (get-frame) get-stepper-button) enable #f))
(define/augment (enable-evaluation) (define/public (current-lang-supports-stepper?)
(send stepper-button enable #t) (stepper-works-for? (extract-language-level (get-defs))))
(inner (void) enable-evaluation))
(define/augment (disable-evaluation) (define/public (notify-stepper-frame-of-change)
(send stepper-button enable #f) (when stepper-frame
(inner (void) disable-evaluation)) (send stepper-frame original-program-changed)))
(define/augment (on-close) (define/augment (on-close)
(when stepper-frame (when stepper-frame
(send stepper-frame original-program-gone)) (send stepper-frame original-program-gone))
(inner (void) on-close)) (inner (void) on-close))
(define/augment (on-tab-change old new) ))
(check-current-language-for-stepper)
(inner (void) on-tab-change old new))
(define/public (check-current-language-for-stepper)
(if (stepper-works-for?
(extract-language-level (get-definitions-text)))
(unless (send stepper-button is-shown?)
(send (send stepper-button get-parent)
add-child stepper-button))
(when (send stepper-button is-shown?)
(send (send stepper-button get-parent)
delete-child stepper-button))))
;; add the stepper button to the button panel:
(send (get-button-panel) change-children
(lx (cons stepper-button-parent-panel
(remq stepper-button-parent-panel _))))
;; hide stepper button if it's not supported for the initial language:
(check-current-language-for-stepper)))
;; stepper-definitions-text-mixin : a mixin for the definitions text that ;; stepper-definitions-text-mixin : a mixin for the definitions text that
;; alerts thet stepper when the definitions text is altered or destroyed ;; alerts thet stepper when the definitions text is altered or destroyed
(define (stepper-definitions-text-mixin %) (define (stepper-definitions-text-mixin %)
(class % (class %
(inherit get-top-level-window) (inherit get-tab get-top-level-window)
(define/private (notify-stepper-frame-of-change)
(let ([win (get-top-level-window)])
;; should only be #f when win is #f
(when (is-a? win stepper-unit-frame<%>)
(let ([stepper-window (send win get-stepper-frame)])
(when stepper-window
(send stepper-window original-program-changed))))))
(define/augment (on-insert x y) (define/augment (on-insert x y)
(unless metadata-changing-now? (unless metadata-changing-now?
(notify-stepper-frame-of-change)) (send (get-tab) notify-stepper-frame-of-change))
(inner (void) on-insert x y)) (inner (void) on-insert x y))
(define/augment (on-delete x y) (define/augment (on-delete x y)
(unless metadata-changing-now? (unless metadata-changing-now?
(notify-stepper-frame-of-change)) (send (get-tab) notify-stepper-frame-of-change))
(inner (void) on-delete x y)) (inner (void) on-delete x y))
(define/augment (after-set-next-settings s) (define/augment (after-set-next-settings s)
(let ([tlw (get-top-level-window)]) (let ([tlw (get-top-level-window)])
(when tlw (when tlw
(send tlw check-current-language-for-stepper))) (send tlw show/hide-stepper-button)))
(inner (void) after-set-next-settings s)) (inner (void) after-set-next-settings s))
(define metadata-changing-now? #f) (define metadata-changing-now? #f)
@ -321,28 +358,29 @@
(super-new))) (super-new)))
;; apply the mixins dynamically to the drscheme unit frame and ;; apply the mixins dynamically to the drracket unit frame and
;; definitions text: ;; definitions text:
(drscheme:get/extend:extend-unit-frame stepper-unit-frame-mixin) (drracket:get/extend:extend-unit-frame stepper-unit-frame-mixin)
(drscheme:get/extend:extend-definitions-text stepper-definitions-text-mixin) (drracket:get/extend:extend-definitions-text stepper-definitions-text-mixin)
(drracket:get/extend:extend-tab stepper-tab-mixin)
;; COPIED FROM drscheme/private/language.ss ;; COPIED FROM drracket/private/language.ss
;; simple-module-based-language-convert-value : TST STYLE boolean -> TST ;; simple-module-based-language-convert-value : TST STYLE boolean -> TST
(define (simple-module-based-language-convert-value value settings) (define (simple-module-based-language-convert-value value settings)
(case (drscheme:language:simple-settings-printing-style settings) (case (drracket:language:simple-settings-printing-style settings)
[(print) value] [(print) value]
[(write trad-write) value] [(write trad-write) value]
[(constructor) [(constructor)
(parameterize (parameterize
([constructor-style-printing #t] ([constructor-style-printing #t]
[show-sharing (drscheme:language:simple-settings-show-sharing settings)] [show-sharing (drracket:language:simple-settings-show-sharing settings)]
[current-print-convert-hook [current-print-convert-hook
(leave-snips-alone-hook (current-print-convert-hook))]) (leave-snips-alone-hook (current-print-convert-hook))])
(stepper-print-convert value))] (stepper-print-convert value))]
[(quasiquote) [(quasiquote)
(parameterize (parameterize
([constructor-style-printing #f] ([constructor-style-printing #f]
[show-sharing (drscheme:language:simple-settings-show-sharing settings)] [show-sharing (drracket:language:simple-settings-show-sharing settings)]
[current-print-convert-hook [current-print-convert-hook
(leave-snips-alone-hook (current-print-convert-hook))]) (leave-snips-alone-hook (current-print-convert-hook))])
(stepper-print-convert value))] (stepper-print-convert value))]
@ -381,19 +419,19 @@
[(is-a? exp snip%) [(is-a? exp snip%)
(send exp copy)] (send exp copy)]
#; #;
[((drscheme:rep:use-number-snip) exp) [((drracket:rep:use-number-snip) exp)
(let ([number-snip-type (let ([number-snip-type
(drscheme:language:simple-settings-fraction-style (drracket:language:simple-settings-fraction-style
simple-settings)]) simple-settings)])
(cond (cond
[(eq? number-snip-type 'repeating-decimal) [(eq? number-snip-type 'repeating-decimal)
(drscheme:number-snip:make-repeating-decimal-snip exp #f)] (drracket:number-snip:make-repeating-decimal-snip exp #f)]
[(eq? number-snip-type 'repeating-decimal-e) [(eq? number-snip-type 'repeating-decimal-e)
(drscheme:number-snip:make-repeating-decimal-snip exp #t)] (drracket:number-snip:make-repeating-decimal-snip exp #t)]
[(eq? number-snip-type 'mixed-fraction) [(eq? number-snip-type 'mixed-fraction)
(drscheme:number-snip:make-fraction-snip exp #f)] (drracket:number-snip:make-fraction-snip exp #f)]
[(eq? number-snip-type 'mixed-fraction-e) [(eq? number-snip-type 'mixed-fraction-e)
(drscheme:number-snip:make-fraction-snip exp #t)] (drracket:number-snip:make-fraction-snip exp #t)]
[else [else
(error 'which-number-snip (error 'which-number-snip
"expected either 'repeating-decimal, 'repeating-decimal-e, 'mixed-fraction, or 'mixed-fraction-e got : ~e" "expected either 'repeating-decimal, 'repeating-decimal-e, 'mixed-fraction, or 'mixed-fraction-e got : ~e"

4
collects/stepper/tests/test-docs-complete.rkt
View File

@ -1,6 +1,2 @@
#lang racket/base #lang racket/base
(require tests/utils/docs-complete) (require tests/utils/docs-complete)
(check-docs (quote stepper/xml-sig))
(check-docs (quote stepper/view-controller))
(check-docs (quote stepper/drracket-button))
(check-docs (quote stepper/break))

41
collects/stepper/xml-tool.rkt
View File

@ -1,14 +1,11 @@
#lang racket
(module xml-tool mzscheme (require "private/xml-snip-helpers.rkt"
(require "private/xml-snip-helpers.rkt"
"private/find-tag.rkt" "private/find-tag.rkt"
"xml-sig.ss" "private/xml-sig.ss"
mzlib/unit
mzlib/contract
mzlib/class
mred mred
framework framework
drscheme/tool drracket/tool
xml/xml xml/xml
string-constants) string-constants)
@ -16,12 +13,14 @@
(define orig (current-output-port)) (define orig (current-output-port))
(define-unit xml-tool@ (define-unit xml-tool@
(import drscheme:tool^) (import drracket:tool^)
(export xml^) (export xml^)
(define (phase1) (void))
(define (phase2) (void))
(preferences:set-default 'drscheme:xml-eliminate-whitespace #t boolean?) ;; these were necessary when this was a stand-alone tool:
#;(define (phase1) (void))
#;(define (phase2) (void))
(preferences:set-default 'drracket:xml-eliminate-whitespace #t boolean?)
(define xml-box-color "forest green") (define xml-box-color "forest green")
(define scheme-splice-box-color "blue") (define scheme-splice-box-color "blue")
@ -74,7 +73,7 @@
(define/private (set-eliminate-whitespace-in-empty-tags? new) (define/private (set-eliminate-whitespace-in-empty-tags? new)
(unless (eq? eliminate-whitespace-in-empty-tags? new) (unless (eq? eliminate-whitespace-in-empty-tags? new)
(set! eliminate-whitespace-in-empty-tags? new) (set! eliminate-whitespace-in-empty-tags? new)
(preferences:set 'drscheme:xml-eliminate-whitespace new) (preferences:set 'drracket:xml-eliminate-whitespace new)
(reset-min-sizes) (reset-min-sizes)
(let ([admin (get-admin)]) (let ([admin (get-admin)])
(when admin (when admin
@ -109,7 +108,7 @@
(define/override (make-snip stream-in) (define/override (make-snip stream-in)
(instantiate xml-snip% () (instantiate xml-snip% ()
[eliminate-whitespace-in-empty-tags? [eliminate-whitespace-in-empty-tags?
(preferences:get 'drscheme:xml-eliminate-whitespace)])) (preferences:get 'drracket:xml-eliminate-whitespace)]))
(super-instantiate ()))) (super-instantiate ())))
;; this snipclass is for old, saved files (no snip has it set) ;; this snipclass is for old, saved files (no snip has it set)
@ -196,7 +195,7 @@
(define (get-scheme-box-text%) (define (get-scheme-box-text%)
(unless scheme-box-text% (unless scheme-box-text%
(set! scheme-box-text% (set! scheme-box-text%
(class ((drscheme:unit:get-program-editor-mixin) (class ((drracket:unit:get-program-editor-mixin)
(add-file-keymap-mixin (add-file-keymap-mixin
scheme:text%)) scheme:text%))
(inherit copy-self-to) (inherit copy-self-to)
@ -306,7 +305,7 @@
(let ([xml-text% #f]) (let ([xml-text% #f])
(lambda () (lambda ()
(unless xml-text% (unless xml-text%
(set! xml-text% (class ((drscheme:unit:get-program-editor-mixin) (set! xml-text% (class ((drracket:unit:get-program-editor-mixin)
(xml-text-mixin (xml-text-mixin
plain-text%)) plain-text%))
(inherit copy-self-to) (inherit copy-self-to)
@ -375,8 +374,8 @@
(lambda () (lambda ()
(instantiate xml-snip% () (instantiate xml-snip% ()
[eliminate-whitespace-in-empty-tags? [eliminate-whitespace-in-empty-tags?
(preferences:get 'drscheme:xml-eliminate-whitespace)])))))) (preferences:get 'drracket:xml-eliminate-whitespace)]))))))
(register-capability-menu-item 'drscheme:special:xml-menus (get-insert-menu)) (register-capability-menu-item 'drracket:special:xml-menus (get-insert-menu))
(instantiate menu:can-restore-menu-item% () (instantiate menu:can-restore-menu-item% ()
(label (string-constant xml-tool-insert-scheme-box)) (label (string-constant xml-tool-insert-scheme-box))
(parent menu) (parent menu)
@ -385,7 +384,7 @@
(lambda (menu evt) (lambda (menu evt)
(insert-snip (insert-snip
(lambda () (instantiate scheme-snip% () (splice? #f))))))) (lambda () (instantiate scheme-snip% () (splice? #f)))))))
(register-capability-menu-item 'drscheme:special:xml-menus (get-insert-menu)) (register-capability-menu-item 'drracket:special:xml-menus (get-insert-menu))
(instantiate menu:can-restore-menu-item% () (instantiate menu:can-restore-menu-item% ()
(label (string-constant xml-tool-insert-scheme-splice-box)) (label (string-constant xml-tool-insert-scheme-splice-box))
(parent menu) (parent menu)
@ -394,10 +393,10 @@
(lambda (menu evt) (lambda (menu evt)
(insert-snip (insert-snip
(lambda () (instantiate scheme-snip% () (splice? #t))))))) (lambda () (instantiate scheme-snip% () (splice? #t)))))))
(register-capability-menu-item 'drscheme:special:xml-menus (get-insert-menu))) (register-capability-menu-item 'drracket:special:xml-menus (get-insert-menu)))
(frame:reorder-menus this))) (frame:reorder-menus this)))
(drscheme:language:register-capability 'drscheme:special:xml-menus (flat-contract boolean?) #t) (drracket:language:register-capability 'drracket:special:xml-menus (flat-contract boolean?) #t)
(drscheme:get/extend:extend-unit-frame xml-box-frame-extension))) (drracket:get/extend:extend-unit-frame xml-box-frame-extension))

4
collects/tests/racket/benchmarks/common/auto.rkt
View File

@ -300,7 +300,7 @@ exec racket -qu "$0" ${1+"$@"}
#f #f
(if (caddr m) ; if the GC doesn't kick in, chicken doesn't print anything for GC time (if (caddr m) ; if the GC doesn't kick in, chicken doesn't print anything for GC time
(* 1000 (string->number (format "#e~a" (cadddr m)))) (* 1000 (string->number (format "#e~a" (cadddr m))))
#f)))) 0))))
(define (extract-time-times bm str) (define (extract-time-times bm str)
(let ([m (regexp-match #rx#"real[ \t]+([0-9m.]+)s.*user[ \t]+([0-9m.]+)s.sys[ \t]+([0-9m.]+)s." str)] (let ([m (regexp-match #rx#"real[ \t]+([0-9m.]+)s.*user[ \t]+([0-9m.]+)s.sys[ \t]+([0-9m.]+)s." str)]
@ -441,7 +441,7 @@ exec racket -qu "$0" ${1+"$@"}
run-exe run-exe
extract-chicken-times extract-chicken-times
clean-up-bin clean-up-bin
(append '(scheme2 takr2) (append '(takr2)
racket-specific-progs)) racket-specific-progs))
(make-impl 'bigloo (make-impl 'bigloo
void void

3
collects/tests/racket/benchmarks/common/tabulate.rkt
View File

@ -99,7 +99,8 @@ exec racket -qu "$0" ${1+"$@"}
#f)]) #f)])
(if a (if a
;; compute cpu, real and gc average time for the nothing benchmark ;; compute cpu, real and gc average time for the nothing benchmark
(let ([nothing-runs (map car a)]) (let ([nothing-runs (map (lambda (x) (map (lambda (y) (or y 0)) x))
(map car a))])
(map (lambda (x) (exact->inexact (/ x (length nothing-runs)))) (map (lambda (x) (exact->inexact (/ x (length nothing-runs))))
(foldl (lambda (x y) (map + x y)) (foldl (lambda (x y) (map + x y))
'(0 0 0) '(0 0 0)

2
collects/tests/typed-scheme/run
View File

@ -1,2 +0,0 @@
#!/bin/sh
gracket -e '(begin (require "main.ss") (go tests))'

40
collects/tests/typed-scheme/succeed/set.rkt Normal file
View File

@ -0,0 +1,40 @@
#lang typed/racket
(define s (set 0 1 2 3))
(define q (seteq 0 1 2 3))
(define v (seteqv 0 1 2 3))
(define s0 (ann (set) (Setof Byte)))
(set-empty? s)
(set-empty? q)
(set-empty? v)
(set-empty? s0)
(set-count s)
(set-count q)
(set-count v)
(set-count s0)
(set-member? s 0)
(set-member? q 0)
(set-member? v 0)
(set-member? s0 0)
(set-add s 4)
(set-add q 4)
(set-add v 4)
(set-add s0 4)
(set-remove s 4)
(set-remove q 4)
(set-remove v 4)
(set-remove s0 4)
(subset? s s0)
(set-map v add1)
(set-for-each s0 display)
(set-equal? s)
(set-eqv? v)
(set-eq? q)
(set? s0)

2
collects/typed-scheme/infer/infer-unit.rkt
View File

@ -497,6 +497,8 @@
(cset-meet (cg e e*) (cg e* e))] (cset-meet (cg e e*) (cg e* e))]
[((Ephemeron: e) (Ephemeron: e*)) [((Ephemeron: e) (Ephemeron: e*))
(cg e e*)] (cg e e*)]
[((Set: a) (Set: a*))
(cg a a*)]
;; we assume all HTs are mutable at the moment ;; we assume all HTs are mutable at the moment
[((Hashtable: s1 s2) (Hashtable: t1 t2)) [((Hashtable: s1 s2) (Hashtable: t1 t2))
;; for mutable hash tables, both are invariant ;; for mutable hash tables, both are invariant

20
collects/typed-scheme/private/base-env.rkt
View File

@ -18,6 +18,7 @@
racket/function racket/function
racket/mpair racket/mpair
racket/base racket/base
racket/set
(only-in string-constants/private/only-once maybe-print-message) (only-in string-constants/private/only-once maybe-print-message)
(only-in mzscheme make-namespace) (only-in mzscheme make-namespace)
(only-in racket/match/runtime match:error matchable? match-equality-test)) (only-in racket/match/runtime match:error matchable? match-equality-test))
@ -599,6 +600,25 @@
[hash-iterate-value (-poly (a b) [hash-iterate-value (-poly (a b)
((-HT a b) -Integer . -> . b))] ((-HT a b) -Integer . -> . b))]
;Set operations
[set (-poly (e) (->* (list) e (-set e)))]
[seteqv (-poly (e) (->* (list) e (-set e)))]
[seteq (-poly (e) (->* (list) e (-set e)))]
[set-empty? (-poly (e) (-> (-set e) B))]
[set-count (-poly (e) (-> (-set e) -Index))]
[set-member? (-poly (e) (-> (-set e) e B))]
[set-add (-poly (e) (-> (-set e) e (-set e)))]
[set-remove (-poly (e) (-> (-set e) e (-set e)))]
[subset? (-poly (e) (-> (-set e) (-set e) B))]
[set-map (-poly (e b) (-> (-set e) (-> e b) (-lst b)))]
[set-for-each (-poly (e b) (-> (-set e) (-> e b) -Void))]
[set? (make-pred-ty (-poly (e) (-set e)))]
[set-equal? (-poly (e) (-> (-set e) B))]
[set-eqv? (-poly (e) (-> (-set e) B))]
[set-eq? (-poly (e) (-> (-set e) B))]
[bytes (->* (list) -Integer -Bytes)] [bytes (->* (list) -Integer -Bytes)]
[bytes? (make-pred-ty -Bytes)] [bytes? (make-pred-ty -Bytes)]
[make-bytes (cl-> [(-Integer -Integer) -Bytes] [make-bytes (cl-> [(-Integer -Integer) -Bytes]

1
collects/typed-scheme/private/base-types.rkt
View File

@ -112,6 +112,7 @@
[Boxof (-poly (a) (make-Box a))] [Boxof (-poly (a) (make-Box a))]
[Channelof (-poly (a) (make-Channel a))] [Channelof (-poly (a) (make-Channel a))]
[Ephemeronof (-poly (a) (make-Ephemeron a))] [Ephemeronof (-poly (a) (make-Ephemeron a))]
[Setof (-poly (e) (make-Set e))]
[Continuation-Mark-Set -Cont-Mark-Set] [Continuation-Mark-Set -Cont-Mark-Set]
[False (-val #f)] [False (-val #f)]
[True (-val #t)] [True (-val #t)]

2
collects/typed-scheme/private/prims.rkt
View File

@ -19,7 +19,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
|# |#
(provide (all-defined-out) (provide (except-out (all-defined-out) dtsi* let-internal: define-for-variants define-for*-variants)
: :
(rename-out [define-typed-struct define-struct:] (rename-out [define-typed-struct define-struct:]
[lambda: λ:] [lambda: λ:]

4
collects/typed-scheme/rep/type-rep.rkt
View File

@ -135,6 +135,10 @@
[#:key 'ephemeron]) [#:key 'ephemeron])
;; elem is a Type
(dt Set ([elem Type/c]) [#:key 'set])
;; name is a Symbol (not a Name) ;; name is a Symbol (not a Name)
;; contract is used when generating contracts from types ;; contract is used when generating contracts from types
;; predicate is used to check (at compile-time) whether a value belongs ;; predicate is used to check (at compile-time) whether a value belongs

138
collects/typed-scheme/scribblings/ts-reference.scrbl
View File

@ -78,16 +78,24 @@ default in Racket.
@defidform[Void] @defidform[Void]
@defidform[Input-Port] @defidform[Input-Port]
@defidform[Output-Port] @defidform[Output-Port]
@defidform[Port]
@defidform[Path] @defidform[Path]
@defidform[Path-String] @defidform[Path-String]
@defidform[Regexp] @defidform[Regexp]
@defidform[PRegexp] @defidform[PRegexp]
@defidform[Byte-Regexp]
@defidform[Byte-PRegexp]
@defidform[Bytes] @defidform[Bytes]
@defidform[Namespace] @defidform[Namespace]
@defidform[Null] @defidform[Null]
@defidform[EOF] @defidform[EOF]
@defidform[Continuation-Mark-Set] @defidform[Continuation-Mark-Set]
@defidform[Char] @defidform[Char]
@defidform[Undefined]
@defidform[Module-Path]
@defidform[Module-Path-Index]
@defidform[Compiled-Module-Expression]
@defidform[Resolved-Module-Path]
@defidform[Thread])]{ @defidform[Thread])]{
These types represent primitive Racket data. These types represent primitive Racket data.
@ -110,11 +118,12 @@ These types represent primitive Racket data.
@subsection{Singleton Types} @subsection{Singleton Types}
Some kinds of data are given singleton types by default. In Some kinds of data are given singleton types by default. In
particular, @rtech{symbols} and @rtech{keywords} have types which particular, @rtech{booleans}, @rtech{symbols}, and @rtech{keywords} have types which
consist only of the particular symbol or keyword. These types are consist only of the particular boolean, symbol, or keyword. These types are
subtypes of @racket[Symbol] and @racket[Keyword], respectively. subtypes of @racket[Boolean], @racket[Symbol] and @racket[Keyword], respectively.
@ex[ @ex[
#t
'#:foo '#:foo
'bar 'bar
] ]
@ -124,7 +133,7 @@ subtypes of @racket[Symbol] and @racket[Keyword], respectively.
The following base types are parameteric in their type arguments. The following base types are parameteric in their type arguments.
@defform[(Pair s t)]{is the @rtech{pair} containing @racket[s] as the @racket[car] @defform[(Pairof s t)]{is the @rtech{pair} containing @racket[s] as the @racket[car]
and @racket[t] as the @racket[cdr]} and @racket[t] as the @racket[cdr]}
@ex[ @ex[
@ -140,12 +149,16 @@ The following base types are parameteric in their type arguments.
one element for each of the @racket[t]s, plus a sequence of elements one element for each of the @racket[t]s, plus a sequence of elements
corresponding to @racket[trest], where @racket[bound] corresponding to @racket[trest], where @racket[bound]
must be an identifier denoting a type variable bound with @racket[...].} must be an identifier denoting a type variable bound with @racket[...].}
@defform[(List* t t1 ... s)]{is equivalent to @racket[(Pairof t (List* t1 ... s))].}
@ex[ @ex[
(list 'a 'b 'c) (list 'a 'b 'c)
(map symbol->string (list 'a 'b 'c)) (map symbol->string (list 'a 'b 'c))
] ]
@defform[(MListof t)]{Homogenous @rtech{mutable lists} of @racket[t].}
@defform[(MPairof t u)]{@rtech{Mutable pairs} of @racket[t] and @racket[u].}
@defform[(Boxof t)]{A @rtech{box} of @racket[t]} @defform[(Boxof t)]{A @rtech{box} of @racket[t]}
@ex[(box "hello world")] @ex[(box "hello world")]
@ -153,6 +166,7 @@ corresponding to @racket[trest], where @racket[bound]
@defform[(Vectorof t)]{Homogenous @rtech{vectors} of @racket[t]} @defform[(Vectorof t)]{Homogenous @rtech{vectors} of @racket[t]}
@defform[(Vector t ...)]{is the type of the list with one element, in order, @defform[(Vector t ...)]{is the type of the list with one element, in order,
for each type provided to the @racket[Vector] type constructor.} for each type provided to the @racket[Vector] type constructor.}
@defidform[FlVector]{An @rtech{flvector}.}
@ex[(vector 1 2 3) @ex[(vector 1 2 3)
#(a b c)] #(a b c)]
@ -163,6 +177,10 @@ corresponding to @racket[trest], where @racket[bound]
@ex[#hash((a . 1) (b . 2))] @ex[#hash((a . 1) (b . 2))]
} }
@defform[(Setof t)]{is the type of a @rtech{set} of @racket[t].
@ex[(set 0 1 2 3)]
}
@defform[(Channelof t)]{A @rtech{channel} on which only @racket[t]s can be sent. @defform[(Channelof t)]{A @rtech{channel} on which only @racket[t]s can be sent.
@ex[ @ex[
(ann (make-channel) (Channelof Symbol)) (ann (make-channel) (Channelof Symbol))
@ -179,6 +197,11 @@ corresponding to @racket[trest], where @racket[bound]
@defform[(Promise t)]{A @rtech{promise} of @racket[t]. @defform[(Promise t)]{A @rtech{promise} of @racket[t].
@ex[(delay 3)]} @ex[(delay 3)]}
@defform[(Futureof t)]{A @rtech{future} which produce a value of type @racket[t] when touched.}
@defform[(Sequenceof t ...)]{A @rtech{sequence} that produces values of the
types @racket[_t ...] on each iteration.}
@subsection{Syntax Objects} @subsection{Syntax Objects}
The following types represent @rtech{syntax object}s and their content. The following types represent @rtech{syntax object}s and their content.
@ -213,6 +236,8 @@ of type @racket[Syntax-E].}
@racket[Datum] produces a value of type @racket[Syntax]. Equivalent to @racket[Datum] produces a value of type @racket[Syntax]. Equivalent to
@racket[(Sexpof Syntax)].} @racket[(Sexpof Syntax)].}
@defform[(Ephemeronof t)]{An @rtech{ephemeron} whose value is of type @racket[t].}
@subsection{Other Type Constructors} @subsection{Other Type Constructors}
@defform*[#:id -> #:literals (* ...) @defform*[#:id -> #:literals (* ...)
@ -233,12 +258,16 @@ of type @racket[Syntax-E].}
(λ: ([x : Number] . [y : String *]) (length y)) (λ: ([x : Number] . [y : String *]) (length y))
ormap ormap
string?]} string?]}
@defidform[Procedure]{is the supertype of all function types.}
@defform[(U t ...)]{is the union of the types @racket[t ...]. @defform[(U t ...)]{is the union of the types @racket[t ...].
@ex[(λ: ([x : Real])(if (> 0 x) "yes" 'no))]} @ex[(λ: ([x : Real])(if (> 0 x) "yes" 'no))]}
@defform[(case-lambda fun-ty ...)]{is a function that behaves like all of @defform[(case-> fun-ty ...)]{is a function that behaves like all of
the @racket[fun-ty]s, considered in order from first to last. The @racket[fun-ty]s must all be function the @racket[fun-ty]s, considered in order from first to last. The @racket[fun-ty]s must all be function
types constructed with @racket[->]. types constructed with @racket[->].
@ex[(: add-map : (case-lambda @ex[(: add-map : (case->
[(Listof Integer) -> (Listof Integer)] [(Listof Integer) -> (Listof Integer)]
[(Listof Integer) (Listof Integer) -> (Listof Integer)]))] [(Listof Integer) (Listof Integer) -> (Listof Integer)]))]
For the definition of @racket[add-map] look into @racket[case-lambda:].} For the definition of @racket[add-map] look into @racket[case-lambda:].}
@ -255,7 +284,7 @@ of type @racket[Syntax-E].}
0 0
(add1 (list-lenght (cdr lst)))))]} (add1 (list-lenght (cdr lst)))))]}
@defform[(values t ...)]{is the type of a sequence of multiple values, with @defform[(Values t ...)]{is the type of a sequence of multiple values, with
types @racket[t ...]. This can only appear as the return type of a types @racket[t ...]. This can only appear as the return type of a
function. function.
@ex[(values 1 2 3)]} @ex[(values 1 2 3)]}
@ -269,11 +298,16 @@ recursive type in the body @racket[t]
(define-type (List A) (Rec List (Pair A (U List Null))))]} (define-type (List A) (Rec List (Pair A (U List Null))))]}
@(define-syntax-rule (defalias id1 id2)
@defidform[id1]{An alias for @racket[id2].})
@defalias[→ ->]
@defalias[∀ All]
@subsection{Other Types} @subsection{Other Types}
@defform[(Option t)]{Either @racket[t] or @racket[#f]} @defform[(Option t)]{Either @racket[t] or @racket[#f]}
@defform[(Opaque t)]{A type constructed using @racket[require-opaque-type].}
@section[#:tag "special-forms"]{Special Form Reference} @section[#:tag "special-forms"]{Special Form Reference}
Typed Racket provides a variety of special forms above and beyond Typed Racket provides a variety of special forms above and beyond
@ -389,15 +423,25 @@ variants.
@deftogether[[ @deftogether[[
@defform[(for/list: : u (for:-clause ...) expr ...+)] @defform[(for/list: : u (for:-clause ...) expr ...+)]
@;@defform[(for/hash: : u (for:-clause ...) expr ...+)] @; the ones that are commented out don't currently work @defform[(for/hash: : u (for:-clause ...) expr ...+)]
@;@defform[(for/hasheq: : u (for:-clause ...) expr ...+)] @defform[(for/hasheq: : u (for:-clause ...) expr ...+)]
@;@defform[(for/hasheqv: : u (for:-clause ...) expr ...+)] @defform[(for/hasheqv: : u (for:-clause ...) expr ...+)]
@;@defform[(for/vector: : u (for:-clause ...) expr ...+)] @defform[(for/vector: : u (for:-clause ...) expr ...+)]
@;@defform[(for/flvector: : u (for:-clause ...) expr ...+)] @defform[(for/flvector: : u (for:-clause ...) expr ...+)]
@;@defform[(for/and: : u (for:-clause ...) expr ...+)] @defform[(for/and: : u (for:-clause ...) expr ...+)]
@defform[(for/or: : u (for:-clause ...) expr ...+)] @defform[(for/or: : u (for:-clause ...) expr ...+)]
@;@defform[(for/first: : u (for:-clause ...) expr ...+)] @defform[(for/first: : u (for:-clause ...) expr ...+)]
@;@defform[(for/last: : u (for:-clause ...) expr ...+)] @defform[(for/last: : u (for:-clause ...) expr ...+)]
@defform[(for*/list: : u (for:-clause ...) expr ...+)]
@defform[(for*/hash: : u (for:-clause ...) expr ...+)]
@defform[(for*/hasheq: : u (for:-clause ...) expr ...+)]
@defform[(for*/hasheqv: : u (for:-clause ...) expr ...+)]
@defform[(for*/vector: : u (for:-clause ...) expr ...+)]
@defform[(for*/flvector: : u (for:-clause ...) expr ...+)]
@defform[(for*/and: : u (for:-clause ...) expr ...+)]
@defform[(for*/or: : u (for:-clause ...) expr ...+)]
@defform[(for*/first: : u (for:-clause ...) expr ...+)]
@defform[(for*/last: : u (for:-clause ...) expr ...+)]
]]{ ]]{
These behave like their non-annotated counterparts, with the exception These behave like their non-annotated counterparts, with the exception
that @racket[#:when] clauses can only appear as the last that @racket[#:when] clauses can only appear as the last
@ -521,14 +565,13 @@ can be used anywhere a definition form may be used.
@defform[(provide: [v t] ...)]{This declares that the @racket[v]s have @defform[(provide: [v t] ...)]{This declares that the @racket[v]s have
the types @racket[t], and also provides all of the @racket[v]s.} the types @racket[t], and also provides all of the @racket[v]s.}
@litchar{#{v : t}} This declares that the variable @racket[v] has type @defform/none[@litchar|{ #{v : t} }|]{ This declares that the variable @racket[v] has type
@racket[t]. This is legal only for binding occurrences of @racket[_v]. @racket[t]. This is legal only for binding occurrences of @racket[_v].}
@defform[(ann e t)]{Ensure that @racket[e] has type @racket[t], or @defform[(ann e t)]{Ensure that @racket[e] has type @racket[t], or
some subtype. The entire expression has type @racket[t]. some subtype. The entire expression has type @racket[t].
This is legal only in expression contexts.} This is legal only in expression contexts. The syntax @litchar{#{e :: t}} may
also be used.}
@litchar{#{e :: t}} This is identical to @racket[(ann e t)].
@defform[(inst e t ...)]{Instantiate the type of @racket[e] with types @defform[(inst e t ...)]{Instantiate the type of @racket[e] with types
@racket[t ...]. @racket[e] must have a polymorphic type with the @racket[t ...]. @racket[e] must have a polymorphic type with the
@ -540,9 +583,10 @@ contexts.
(define (fold-list lst) (define (fold-list lst)
(foldl (inst cons A A) null lst)) (foldl (inst cons A A) null lst))
(fold-list (list "1" "2" "3" "4"))]} (fold-list (list "1" "2" "3" "4"))]
@litchar|{#{e @ t ...}}| This is identical to @racket[(inst e t ...)]. The syntax @litchar|{#{e @ t ...}}| may also be used.
}
@subsection{Require} @subsection{Require}
@ -599,12 +643,12 @@ enforce the specified types. If this contract fails, the module
Some types, notably polymorphic types constructed with @racket[All], Some types, notably polymorphic types constructed with @racket[All],
cannot be converted to contracts and raise a static error when used in cannot be converted to contracts and raise a static error when used in
a @racket[require/typed] form. Here is an example of using a @racket[require/typed] form. Here is an example of using
@racket[case-lambda] in @racket[require/typed]. @racket[case->] in @racket[require/typed].
@(racketblock @(racketblock
(require/typed racket/base (require/typed racket/base
[file-or-directory-modify-seconds [file-or-directory-modify-seconds
(case-lambda (case->
[String -> Exact-Nonnegative-Integer] [String -> Exact-Nonnegative-Integer]
[String (Option Exact-Nonnegative-Integer) [String (Option Exact-Nonnegative-Integer)
-> ->
@ -613,8 +657,8 @@ a @racket[require/typed] form. Here is an example of using
-> ->
Any])])) Any])]))
@racket[file-or-directory-modify-seconds] has some arguments which are optional. @racket[file-or-directory-modify-seconds] has some arguments which are optional,
So we need to use @racket[case-lambda].} so we need to use @racket[case->].}
@section{Libraries Provided With Typed Racket} @section{Libraries Provided With Typed Racket}
@ -745,7 +789,7 @@ have the types ascribed to them; these types are converted to contracts and chec
(define (fun x) x) (define (fun x) x)
(define val 17)) (define val 17))
(fun val)] (fun val)]}
@section{Optimization in Typed Racket} @section{Optimization in Typed Racket}
@ -772,14 +816,44 @@ The following forms are provided by Typed Racket for backwards
compatibility. compatibility.
@defidform[define-type-alias]{Equivalent to @racket[define-type].} @defidform[define-type-alias]{Equivalent to @racket[define-type].}
@defidform[define-typed-struct]{Equivalent to @racket[define-struct:]}
@defidform[require/opaque-type]{Similar to using the @racket[opaque] @defidform[require/opaque-type]{Similar to using the @racket[opaque]
keyword with @racket[require/typed].} keyword with @racket[require/typed].}
@defidform[require-typed-struct]{Similar to using the @racket[struct] @defidform[require-typed-struct]{Similar to using the @racket[struct]
keyword with @racket[require/typed].} keyword with @racket[require/typed].}
@defidform[pdefine:]{Defines a polymorphic function.}
@defform[(pred t)]{Equivalent to @racket[(Any -> Boolean : t)].}
@(defmodulelang* (typed-scheme) @defalias[Un U]
@defalias[mu Rec]
@defalias[Tuple List]
@defalias[Parameter Parameterof]
@defalias[Pair Pairof]
@section{Compatibility Languages}
@(defmodulelang* (typed/scheme typed/scheme/base typed-scheme)
#:use-sources (typed-scheme/typed-scheme #:use-sources (typed-scheme/typed-scheme
typed-scheme/private/prims)) typed-scheme/private/prims typed-scheme/private/base-types))
Equivalent to the @racketmod[typed/racket/base] language. Typed versions of the @racketmod[scheme] and @racketmod[scheme/base]
languages. The @racketmod[typed-scheme] language is equivalent to the
@racketmod[typed/scheme/base] language.
}
@section{Experimental Features}
These features are currently experimental and subject to change.
@defform[(Class args ...)]{A type constructor for typing classes created using @racketmodname[racket/class].}
@defform[(Instance c)]{A type constructor for typing objects created using @racketmodname[racket/class].}
@defform[(:type t)]{Prints the type @racket[_t].}
@defform[(declare-refinement id)]{Declares @racket[id] to be usable in
refinement types.}
@defform[(Refinement id)]{Includes values that have been tested with the
predicate @racket[id], which must have been specified with
@racket[declare-refinement].}
@defform[(define-typed-struct/exec forms ...)]{Defines an executable structure.}

1
collects/typed-scheme/types/abbrev.rkt
View File

@ -29,6 +29,7 @@
(define -Param make-Param) (define -Param make-Param)
(define -box make-Box) (define -box make-Box)
(define -channel make-Channel) (define -channel make-Channel)
(define -set make-Set)
(define -vec make-Vector) (define -vec make-Vector)
(define -future make-Future) (define -future make-Future)
(define (-seq . args) (make-Sequence args)) (define (-seq . args) (make-Sequence args))

1
collects/typed-scheme/types/printer.rkt
View File

@ -172,6 +172,7 @@
[(Future: e) (fp "(Futureof ~a)" e)] [(Future: e) (fp "(Futureof ~a)" e)]
[(Channel: e) (fp "(Channelof ~a)" e)] [(Channel: e) (fp "(Channelof ~a)" e)]
[(Ephemeron: e) (fp "(Ephemeronof ~a)" e)] [(Ephemeron: e) (fp "(Ephemeronof ~a)" e)]
[(Set: e) (fp "(Setof ~a)" e)]
[(Union: elems) (fp "~a" (cons 'U elems))] [(Union: elems) (fp "~a" (cons 'U elems))]
[(Pair: l r) (fp "(Pairof ~a ~a)" l r)] [(Pair: l r) (fp "(Pairof ~a ~a)" l r)]
[(ListDots: dty dbound) [(ListDots: dty dbound)

1
collects/typed-scheme/types/subtype.rkt
View File

@ -361,6 +361,7 @@
[((Ephemeron: s) (Ephemeron: t)) [((Ephemeron: s) (Ephemeron: t))
(subtype* A0 s t)] (subtype* A0 s t)]
[((Box: _) (BoxTop:)) A0] [((Box: _) (BoxTop:)) A0]
[((Set: t) (Set: t*)) (subtype* A0 t t*)]
[((Channel: _) (ChannelTop:)) A0] [((Channel: _) (ChannelTop:)) A0]
[((Vector: _) (VectorTop:)) A0] [((Vector: _) (VectorTop:)) A0]
[((HeterogenousVector: _) (VectorTop:)) A0] [((HeterogenousVector: _) (VectorTop:)) A0]

18
collects/typed/racket/base.rkt
View File

@ -1,18 +1,18 @@
#lang s-exp typed-scheme/minimal #lang s-exp typed-scheme/minimal
(providing (libs (except racket/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct for for*))
(basics #%module-begin #%top-interaction lambda #%app))
(providing (libs (except racket/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct for for*)
(except typed-scheme/private/prims)
(except typed-scheme/private/base-types)
(except typed-scheme/private/base-types-extra))
(basics #%module-begin
#%top-interaction
lambda
#%app))
(require typed-scheme/private/extra-procs (require typed-scheme/private/extra-procs
typed-scheme/private/prims
typed-scheme/private/base-types
typed-scheme/private/base-types-extra
(for-syntax typed-scheme/private/base-types-extra)) (for-syntax typed-scheme/private/base-types-extra))
(provide (rename-out [with-handlers: with-handlers] (provide (rename-out [with-handlers: with-handlers]
[define-type-alias define-type]) [define-type-alias define-type])
(except-out (all-from-out typed-scheme/private/prims)
with-handlers: for/annotation for*/annotation)
(all-from-out typed-scheme/private/base-types)
(all-from-out typed-scheme/private/base-types-extra)
assert defined? with-type for for* assert defined? with-type for for*
(for-syntax (all-from-out typed-scheme/private/base-types-extra))) (for-syntax (all-from-out typed-scheme/private/base-types-extra)))

18
collects/typed/scheme/base.rkt
View File

@ -1,18 +1,18 @@
#lang s-exp typed-scheme/minimal #lang s-exp typed-scheme/minimal
(providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct for for*))
(basics #%module-begin #%top-interaction lambda #%app))
(providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct for for*)
(except typed-scheme/private/prims)
(except typed-scheme/private/base-types)
(except typed-scheme/private/base-types-extra))
(basics #%module-begin
#%top-interaction
lambda
#%app))
(require typed-scheme/private/extra-procs (require typed-scheme/private/extra-procs
typed-scheme/private/prims
typed-scheme/private/base-types
typed-scheme/private/base-types-extra
(for-syntax typed-scheme/private/base-types-extra)) (for-syntax typed-scheme/private/base-types-extra))
(provide (rename-out [with-handlers: with-handlers] (provide (rename-out [with-handlers: with-handlers]
[define-type-alias define-type]) [define-type-alias define-type])
(except-out (all-from-out typed-scheme/private/prims)
with-handlers: for/annotation for*/annotation)
(all-from-out typed-scheme/private/base-types)
(all-from-out typed-scheme/private/base-types-extra)
assert defined? with-type for for* assert defined? with-type for for*
(for-syntax (all-from-out typed-scheme/private/base-types-extra))) (for-syntax (all-from-out typed-scheme/private/base-types-extra)))

3
collects/typed/tests/test-docs-complete.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base #lang racket/base
(require tests/utils/docs-complete) (require tests/utils/docs-complete)
(check-docs (quote typed/scheme)) (check-docs (quote typed/scheme))
(check-docs (quote typed/rackunit)) (check-docs (quote typed/scheme/base))
(check-docs (quote typed/racket)) (check-docs (quote typed/racket))
(check-docs (quote typed/racket/base))

21
src/racket/gc2/alloc_cache.c
View File

@ -1,6 +1,6 @@
/* /*
Provides: Provides:
static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t len, int dirty) static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t len, int dirty, int originated_here)
static ssize_t void alloc_cache_flush_freed_pages(AllocCacheBlock *blockfree) static ssize_t void alloc_cache_flush_freed_pages(AllocCacheBlock *blockfree)
static void *alloc_cache_alloc_page(AllocCacheBlock *blockfree, size_t len, size_t alignment, int dirty_ok, ssize_t *size_diff) static void *alloc_cache_alloc_page(AllocCacheBlock *blockfree, size_t len, size_t alignment, int dirty_ok, ssize_t *size_diff)
Requires (defined earlier): Requires (defined earlier):
@ -112,7 +112,7 @@ inline static void *alloc_cache_find_pages(AllocCacheBlock *blockfree, size_t le
return NULL; return NULL;
} }
static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t len, int dirty) static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t len, int dirty, int originated_here)
{ {
int i; int i;
@ -124,14 +124,14 @@ static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t
blockfree[i].len += len; blockfree[i].len += len;
if (dirty) if (dirty)
blockfree[i].zeroed = 0; blockfree[i].zeroed = 0;
return 0; return (originated_here ? 0 : len);
} }
if (p + len == blockfree[i].start) { if (p + len == blockfree[i].start) {
blockfree[i].start = p; blockfree[i].start = p;
blockfree[i].len += len; blockfree[i].len += len;
if (dirty) if (dirty)
blockfree[i].zeroed = 0; blockfree[i].zeroed = 0;
return 0; return (originated_here ? 0 : len);
} }
} }
@ -141,7 +141,7 @@ static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t
blockfree[i].len = len; blockfree[i].len = len;
blockfree[i].age = 0; blockfree[i].age = 0;
blockfree[i].zeroed = !dirty; blockfree[i].zeroed = !dirty;
return 0; return (originated_here ? 0 : len);
} }
} }
@ -149,7 +149,7 @@ static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t
alloc_cache_collapse_pages(blockfree); alloc_cache_collapse_pages(blockfree);
os_free_pages(p, len); os_free_pages(p, len);
return -len; return (originated_here ? -len : 0);
} }
static ssize_t alloc_cache_flush_freed_pages(AllocCacheBlock *blockfree) static ssize_t alloc_cache_flush_freed_pages(AllocCacheBlock *blockfree)
@ -207,7 +207,7 @@ static void *alloc_cache_alloc_page(AllocCacheBlock *blockfree, size_t len, siz
r = alloc_cache_find_pages(blockfree, len, alignment, dirty_ok); r = alloc_cache_find_pages(blockfree, len, alignment, dirty_ok);
if(!r) { if(!r) {
/* attempt to allocate from OS */ /* attempt to allocate from OS */
size_t extra = alignment + CACHE_SEED_PAGES * APAGE_SIZE; size_t extra = (alignment ? (alignment + CACHE_SEED_PAGES * APAGE_SIZE) : 0);
r = os_alloc_pages(len + extra); r = os_alloc_pages(len + extra);
if(r == (void *)-1) { return NULL; } if(r == (void *)-1) { return NULL; }
@ -226,14 +226,15 @@ static void *alloc_cache_alloc_page(AllocCacheBlock *blockfree, size_t len, siz
/* Instead of actually unmapping, put it in the cache, and there's /* Instead of actually unmapping, put it in the cache, and there's
a good chance we can use it next time: */ a good chance we can use it next time: */
(*size_diff) += extra; (*size_diff) += extra;
(*size_diff) += alloc_cache_free_page(blockfree, real_r + len, extra, 1); (*size_diff) += alloc_cache_free_page(blockfree, real_r + len, extra, 1, 1);
} else {
os_free_pages(real_r + len, extra - pre_extra);
} }
else { os_free_pages(real_r + len, extra - pre_extra); }
} }
r = real_r; r = real_r;
} }
(*size_diff) += extra; (*size_diff) += len;
} }
return r; return r;

9
src/racket/gc2/block_cache.c
View File

@ -12,7 +12,7 @@ static void os_protect_pages(void *p, size_t len, int writable);
struct block_desc; struct block_desc;
static AllocCacheBlock *alloc_cache_create(); static AllocCacheBlock *alloc_cache_create();
static ssize_t alloc_cache_free(AllocCacheBlock *); static ssize_t alloc_cache_free(AllocCacheBlock *);
static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t len, int dirty); static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t len, int dirty, int originated_here);
static ssize_t alloc_cache_flush_freed_pages(AllocCacheBlock *blockfree); static ssize_t alloc_cache_flush_freed_pages(AllocCacheBlock *blockfree);
static void *alloc_cache_alloc_page(AllocCacheBlock *blockfree, size_t len, size_t alignment, int dirty_ok, ssize_t *size_diff); static void *alloc_cache_alloc_page(AllocCacheBlock *blockfree, size_t len, size_t alignment, int dirty_ok, ssize_t *size_diff);
@ -222,7 +222,8 @@ static int find_addr_in_bd(GCList *head, void *p, char* msg) {
} }
#endif #endif
static ssize_t block_cache_free_page(BlockCache* bc, void *p, size_t len, int type, int expect_mprotect, void **src_block) { static ssize_t block_cache_free_page(BlockCache* bc, void *p, size_t len, int type, int expect_mprotect, void **src_block,
int originated_here) {
switch(type) { switch(type) {
case MMU_SMALL_GEN1: case MMU_SMALL_GEN1:
{ {
@ -252,7 +253,7 @@ static ssize_t block_cache_free_page(BlockCache* bc, void *p, size_t len, int ty
printf("FREE PAGE %i %p %p-%p %03i %03i %04i %04i : %03i %03i %03i %03i %09i\n", expect_mprotect, bg, p, p + APAGE_SIZE, afu, afr, nafu, nafr, afub, afrb, nafub, nafrb, mmu_memory_allocated(bc->mmu)); printf("FREE PAGE %i %p %p-%p %03i %03i %04i %04i : %03i %03i %03i %03i %09i\n", expect_mprotect, bg, p, p + APAGE_SIZE, afu, afr, nafu, nafr, afub, afrb, nafub, nafrb, mmu_memory_allocated(bc->mmu));
} }
#endif #endif
return 0; return (originated_here ? 0 : len);
} }
break; break;
default: default:
@ -263,7 +264,7 @@ static ssize_t block_cache_free_page(BlockCache* bc, void *p, size_t len, int ty
find_addr_in_bd(&bc->non_atomic.free, p, "non_atomic freeblock"))); find_addr_in_bd(&bc->non_atomic.free, p, "non_atomic freeblock")));
assert(*src_block == (char*)~0x0); assert(*src_block == (char*)~0x0);
#endif #endif
return alloc_cache_free_page(bc->bigBlockCache, p, len, MMU_DIRTY); return alloc_cache_free_page(bc->bigBlockCache, p, len, MMU_DIRTY, originated_here);
break; break;
} }
} }

30
src/racket/gc2/newgc.c
View File

@ -378,17 +378,18 @@ static void *malloc_pages(NewGC *gc, size_t len, size_t alignment, int dirty, in
static void free_pages(NewGC *gc, void *p, size_t len, int type, int expect_mprotect, void **src_block) static void free_pages(NewGC *gc, void *p, size_t len, int type, int expect_mprotect, void **src_block)
{ {
gc->used_pages -= size_to_apage_count(len); gc->used_pages -= size_to_apage_count(len);
mmu_free_page(gc->mmu, p, len, type, expect_mprotect, src_block); mmu_free_page(gc->mmu, p, len, type, expect_mprotect, src_block, 1);
} }
static void free_orphaned_page(NewGC *gc, mpage *tmp) { static void free_orphaned_page(NewGC *gc, mpage *tmp) {
/* free_pages decrements gc->used_pages which is incorrect, since this is an orphaned page /* free_pages decrements gc->used_pages which is incorrect, since this is an orphaned page,
* so we use mmu_free_page directly */ * so we use mmu_free_page directly */
mmu_free_page(gc->mmu, tmp->addr, round_to_apage_size(tmp->size), mmu_free_page(gc->mmu, tmp->addr, round_to_apage_size(tmp->size),
page_mmu_type(tmp), page_mmu_type(tmp),
page_mmu_protectable(tmp), page_mmu_protectable(tmp),
&tmp->mmu_src_block); &tmp->mmu_src_block,
0); /* don't adjust count, since we're failing to adopt it */
free_mpage(tmp); free_mpage(tmp);
} }
@ -899,15 +900,13 @@ static void *allocate_big(const size_t request_size_bytes, int type)
gc->gen0.big_pages = bpage; gc->gen0.big_pages = bpage;
/* orphan this page from the current GC */
/* this page is going to be sent to a different place, don't account for it here */
/* message memory pages shouldn't go into the page_map, they are getting sent to another place */
if (gc->saved_allocator) { if (gc->saved_allocator) {
/* MESSAGE ALLOCATION: orphan this page from the current GC; this
page is going to be sent to a different place, so don't account
for it here, and don't put it in the page_map */
orphan_page_accounting(gc, allocate_size); orphan_page_accounting(gc, allocate_size);
} } else
else {
pagemap_add(gc->page_maps, bpage); pagemap_add(gc->page_maps, bpage);
}
{ {
void * objptr = BIG_PAGE_TO_OBJECT(bpage); void * objptr = BIG_PAGE_TO_OBJECT(bpage);
@ -942,7 +941,11 @@ inline static mpage *create_new_medium_page(NewGC *gc, const int sz, const int p
gc->med_pages[pos] = page; gc->med_pages[pos] = page;
gc->med_freelist_pages[pos] = page; gc->med_freelist_pages[pos] = page;
if (gc->saved_allocator) /* see MESSAGE ALLOCATION above */
orphan_page_accounting(gc, APAGE_SIZE);
else
pagemap_add(gc->page_maps, page); pagemap_add(gc->page_maps, page);
return page; return page;
} }
@ -1049,15 +1052,10 @@ inline static mpage *gen0_create_new_nursery_mpage(NewGC *gc, const size_t page_
page->size = PREFIX_SIZE; page->size = PREFIX_SIZE;
GEN0_ALLOC_SIZE(page) = page_size; GEN0_ALLOC_SIZE(page) = page_size;
/* orphan this page from the current GC */ if (gc->saved_allocator) /* see MESSAGE ALLOCATION above */
/* this page is going to be sent to a different place, don't account for it here */
/* message memory pages shouldn't go into the page_map, they are getting sent to another place */
if (gc->saved_allocator) {
orphan_page_accounting(gc, page_size); orphan_page_accounting(gc, page_size);
} else
else {
pagemap_add_with_size(gc->page_maps, page, page_size); pagemap_add_with_size(gc->page_maps, page, page_size);
}
GCVERBOSEPAGE(gc, "NEW gen0", page); GCVERBOSEPAGE(gc, "NEW gen0", page);

2
src/racket/gc2/sighand.c
View File

@ -125,7 +125,7 @@ void fault_handler(int sn, struct siginfo *si, void *ctx)
/* ========== FreeBSD/NetBSD/OpenBSD signal handler ========== */ /* ========== FreeBSD/NetBSD/OpenBSD signal handler ========== */
/* As of 2007/06/29, this is a guess for NetBSD! */ /* As of 2007/06/29, this is a guess for NetBSD! */
#if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__) #if defined(__FreeBSD__) || defined(__FreeBSD_kernel__) || defined(__NetBSD__) || defined(__OpenBSD__)
# include <signal.h> # include <signal.h>
# include <sys/param.h> # include <sys/param.h>
void fault_handler(int sn, siginfo_t *si, void *ctx) void fault_handler(int sn, siginfo_t *si, void *ctx)

10
src/racket/gc2/vm.c
View File

@ -135,22 +135,26 @@ static void *mmu_alloc_page(MMU* mmu, size_t len, size_t alignment, int dirty, i
return alloc_cache_alloc_page(alloc_cache, len, alignment, dirty, &mmu->memory_allocated); return alloc_cache_alloc_page(alloc_cache, len, alignment, dirty, &mmu->memory_allocated);
} }
#else #else
mmu->memory_allocated += len;
return os_alloc_pages(mmu, len, alignment, dirty); return os_alloc_pages(mmu, len, alignment, dirty);
#endif #endif
} }
static void mmu_free_page(MMU* mmu, void *p, size_t len, int type, int expect_mprotect, void **src_block) { static void mmu_free_page(MMU* mmu, void *p, size_t len, int type, int expect_mprotect, void **src_block,
int originated_here) {
mmu_assert_os_page_aligned(mmu, (size_t)p); mmu_assert_os_page_aligned(mmu, (size_t)p);
mmu_assert_os_page_aligned(mmu, len); mmu_assert_os_page_aligned(mmu, len);
#ifdef USE_BLOCK_CACHE #ifdef USE_BLOCK_CACHE
mmu->memory_allocated += block_cache_free_page(mmu->block_cache, p, len, type, expect_mprotect, src_block); mmu->memory_allocated += block_cache_free_page(mmu->block_cache, p, len, type, expect_mprotect, src_block,
originated_here);
#elif !( defined(_WIN32) || defined(OSKIT) ) #elif !( defined(_WIN32) || defined(OSKIT) )
//len = mmu_round_up_to_os_page_size(mmu, len); //len = mmu_round_up_to_os_page_size(mmu, len);
{ {
AllocCacheBlock *alloc_cache = mmu->alloc_caches[!!expect_mprotect]; AllocCacheBlock *alloc_cache = mmu->alloc_caches[!!expect_mprotect];
mmu->memory_allocated += alloc_cache_free_page(alloc_cache, p, len, MMU_DIRTY); mmu->memory_allocated += alloc_cache_free_page(alloc_cache, p, len, MMU_DIRTY, originated_here);
} }
#else #else
if (originated_here) mmu->memory_allocated -= len;
os_free_pages(mmu, p, len); os_free_pages(mmu, p, len);
#endif #endif
} }

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

@ -185,6 +185,7 @@ EXPORTS
scheme_eval_compiled_sized_string_with_magic scheme_eval_compiled_sized_string_with_magic
scheme_detach_multple_array scheme_detach_multple_array
scheme_malloc_code scheme_malloc_code
scheme_malloc_permanent_code
scheme_free_code scheme_free_code
scheme_malloc_gcable_code scheme_malloc_gcable_code
scheme_malloc_eternal scheme_malloc_eternal

1
src/racket/include/mzwin3m.def
View File

@ -194,6 +194,7 @@ EXPORTS
GC_malloc_atomic_allow_interior GC_malloc_atomic_allow_interior
GC_malloc_tagged_allow_interior GC_malloc_tagged_allow_interior
scheme_malloc_code scheme_malloc_code
scheme_malloc_permanent_code
scheme_free_code scheme_free_code
scheme_malloc_gcable_code scheme_malloc_gcable_code
scheme_malloc_eternal scheme_malloc_eternal

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

@ -197,6 +197,7 @@ GC_malloc_atomic
GC_malloc_stubborn GC_malloc_stubborn
GC_malloc_uncollectable GC_malloc_uncollectable
scheme_malloc_code scheme_malloc_code
scheme_malloc_permanent_code
scheme_free_code scheme_free_code
scheme_malloc_gcable_code scheme_malloc_gcable_code
scheme_malloc_eternal scheme_malloc_eternal

1
src/racket/include/racket3m.exp
View File

@ -202,6 +202,7 @@ GC_malloc_allow_interior
GC_malloc_atomic_allow_interior GC_malloc_atomic_allow_interior
GC_malloc_tagged_allow_interior GC_malloc_tagged_allow_interior
scheme_malloc_code scheme_malloc_code
scheme_malloc_permanent_code
scheme_free_code scheme_free_code
scheme_malloc_gcable_code scheme_malloc_gcable_code
scheme_malloc_eternal scheme_malloc_eternal

2
src/racket/src/jitstate.c
View File

@ -136,7 +136,7 @@ void *scheme_generate_one(mz_jit_state *old_jitter,
buffer = scheme_malloc_gcable_code(size); buffer = scheme_malloc_gcable_code(size);
#endif #endif
} else { } else {
buffer = scheme_malloc_code(size); buffer = scheme_malloc_permanent_code(size);
} }
RECORD_CODE_SIZE(size); RECORD_CODE_SIZE(size);
} else if (old_jitter) { } else if (old_jitter) {

8
src/racket/src/number.c
View File

@ -187,13 +187,13 @@ READ_ONLY Scheme_Object *scheme_single_inf_object, *scheme_single_minus_inf_obje
#ifdef FREEBSD_CONTROL_387 #ifdef FREEBSD_CONTROL_387
#include <machine/floatingpoint.h> # include <ieeefp.h>
#endif #endif
#ifdef LINUX_CONTROL_387 #ifdef LINUX_CONTROL_387
#include <fpu_control.h> # include <fpu_control.h>
#endif #endif
#ifdef ALPHA_CONTROL_FP #ifdef ALPHA_CONTROL_FP
#include <machine/fpu.h> # include <machine/fpu.h>
#endif #endif
#ifdef ASM_DBLPREC_CONTROL_87 #ifdef ASM_DBLPREC_CONTROL_87
@ -243,7 +243,7 @@ scheme_init_number (Scheme_Env *env)
MZ_SIGSET(SIGFPE, SIG_IGN); MZ_SIGSET(SIGFPE, SIG_IGN);
#endif #endif
#ifdef FREEBSD_CONTROL_387 #ifdef FREEBSD_CONTROL_387
fpsetmask(0); (void)fpsetmask(0);
#endif #endif
#ifdef LINUX_CONTROL_387 #ifdef LINUX_CONTROL_387
__setfpucw(_FPU_EXTENDED + _FPU_RC_NEAREST + 0x3F); __setfpucw(_FPU_EXTENDED + _FPU_RC_NEAREST + 0x3F);

11
src/racket/src/places.c
View File

@ -1054,7 +1054,7 @@ Scheme_Object *scheme_places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Tab
} }
} }
nprefab_key = scheme_places_deep_copy_worker(stype->prefab_key, ht, copy); nprefab_key = scheme_places_deep_copy_worker(SCHEME_CDR(stype->prefab_key), ht, copy);
if (copy) { if (copy) {
new_so = scheme_make_serialized_struct_instance(nprefab_key, size); new_so = scheme_make_serialized_struct_instance(nprefab_key, size);
@ -1080,13 +1080,16 @@ Scheme_Object *scheme_places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Tab
Scheme_Serialized_Structure *st = (Scheme_Serialized_Structure*)so; Scheme_Serialized_Structure *st = (Scheme_Serialized_Structure*)so;
Scheme_Struct_Type *stype; Scheme_Struct_Type *stype;
Scheme_Structure *nst; Scheme_Structure *nst;
Scheme_Object *key;
intptr_t size; intptr_t size;
int i = 0; int i = 0;
size = st->num_slots; size = st->num_slots;
stype = scheme_lookup_prefab_type(SCHEME_CDR(st->prefab_key), size);
key = scheme_places_deep_copy_worker(st->prefab_key, ht, copy);
if (copy) { if (copy) {
stype = scheme_lookup_prefab_type(key, size);
new_so = scheme_make_blank_prefab_struct_instance(stype); new_so = scheme_make_blank_prefab_struct_instance(stype);
nst = (Scheme_Structure*)new_so; nst = (Scheme_Structure*)new_so;
} else } else
@ -1384,11 +1387,13 @@ Scheme_Object *scheme_places_deserialize_worker(Scheme_Object *so)
Scheme_Serialized_Structure *st = (Scheme_Serialized_Structure*)so; Scheme_Serialized_Structure *st = (Scheme_Serialized_Structure*)so;
Scheme_Struct_Type *stype; Scheme_Struct_Type *stype;
Scheme_Structure *nst; Scheme_Structure *nst;
Scheme_Object *key;
intptr_t size; intptr_t size;
int i = 0; int i = 0;
size = st->num_slots; size = st->num_slots;
stype = scheme_lookup_prefab_type(SCHEME_CDR(st->prefab_key), size); key = scheme_places_deserialize_worker(st->prefab_key);
stype = scheme_lookup_prefab_type(key, size);
nst = (Scheme_Structure*) scheme_make_blank_prefab_struct_instance(stype); nst = (Scheme_Structure*) scheme_make_blank_prefab_struct_instance(stype);
for (i = 0; i <size ; i++) { for (i = 0; i <size ; i++) {
Scheme_Object *tmp; Scheme_Object *tmp;

47
src/racket/src/salloc.c
View File

@ -839,6 +839,12 @@ struct free_list_entry {
THREAD_LOCAL_DECL(static struct free_list_entry *free_list;) THREAD_LOCAL_DECL(static struct free_list_entry *free_list;)
THREAD_LOCAL_DECL(static int free_list_bucket_count;) THREAD_LOCAL_DECL(static int free_list_bucket_count;)
#ifdef MZ_USE_PLACES
static mzrt_mutex *permanent_code_mutex = NULL;
static void *permanent_code_page = NULL;
static intptr_t available_code_page_amount = 0;
#endif
static intptr_t get_page_size() static intptr_t get_page_size()
{ {
# ifdef PAGESIZE # ifdef PAGESIZE
@ -1095,6 +1101,47 @@ void *scheme_malloc_code(intptr_t size)
#endif #endif
} }
void *scheme_malloc_permanent_code(intptr_t size)
/* allocate code that will never be freed and that can be used
in multiple places */
{
#if defined(MZ_USE_PLACES) && (defined(MZ_JIT_USE_MPROTECT) || defined(MZ_JIT_USE_WINDOWS_VIRTUAL_ALLOC))
void *p;
intptr_t page_size;
if (!permanent_code_mutex) {
/* This function will be called at least once before any other place
is created, so it's ok to create the mutex here. */
mzrt_mutex_create(&permanent_code_mutex);
}
/* 16-byte alignment: */
if (size & 0xF) size += 16 - (size & 0xF);
mzrt_mutex_lock(permanent_code_mutex);
if (available_code_page_amount < size) {
page_size = get_page_size();
page_size *= 4;
while (page_size < size) page_size *= 2;
permanent_code_page = malloc_page(page_size);
available_code_page_amount = page_size;
}
p = permanent_code_page;
permanent_code_page = ((char *)permanent_code_page) + size;
available_code_page_amount -= size;
mzrt_mutex_unlock(permanent_code_mutex);
return p;
#else
return scheme_malloc_code(size);
#endif
}
void scheme_free_code(void *p) void scheme_free_code(void *p)
{ {
#if defined(MZ_JIT_USE_MPROTECT) || defined(MZ_JIT_USE_WINDOWS_VIRTUAL_ALLOC) #if defined(MZ_JIT_USE_MPROTECT) || defined(MZ_JIT_USE_WINDOWS_VIRTUAL_ALLOC)

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

@ -399,6 +399,7 @@ MZ_EXTERN void *GC_malloc_uncollectable(size_t size_in_bytes);
#endif #endif
MZ_EXTERN void *scheme_malloc_code(intptr_t size); MZ_EXTERN void *scheme_malloc_code(intptr_t size);
MZ_EXTERN void *scheme_malloc_permanent_code(intptr_t size);
MZ_EXTERN void scheme_free_code(void *p); MZ_EXTERN void scheme_free_code(void *p);
#ifndef MZ_PRECISE_GC #ifndef MZ_PRECISE_GC
MZ_EXTERN void *scheme_malloc_gcable_code(intptr_t size); MZ_EXTERN void *scheme_malloc_gcable_code(intptr_t size);

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

@ -308,6 +308,7 @@ void *(*GC_malloc_uncollectable)(size_t size_in_bytes);
# endif # endif
#endif #endif
void *(*scheme_malloc_code)(intptr_t size); void *(*scheme_malloc_code)(intptr_t size);
void *(*scheme_malloc_permanent_code)(intptr_t size);
void (*scheme_free_code)(void *p); void (*scheme_free_code)(void *p);
#ifndef MZ_PRECISE_GC #ifndef MZ_PRECISE_GC
void *(*scheme_malloc_gcable_code)(intptr_t size); void *(*scheme_malloc_gcable_code)(intptr_t size);

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

@ -219,6 +219,7 @@
# endif # endif
#endif #endif
scheme_extension_table->scheme_malloc_code = scheme_malloc_code; scheme_extension_table->scheme_malloc_code = scheme_malloc_code;
scheme_extension_table->scheme_malloc_permanent_code = scheme_malloc_permanent_code;
scheme_extension_table->scheme_free_code = scheme_free_code; scheme_extension_table->scheme_free_code = scheme_free_code;
#ifndef MZ_PRECISE_GC #ifndef MZ_PRECISE_GC
scheme_extension_table->scheme_malloc_gcable_code = scheme_malloc_gcable_code; scheme_extension_table->scheme_malloc_gcable_code = scheme_malloc_gcable_code;

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

@ -219,6 +219,7 @@
# endif # endif
#endif #endif
#define scheme_malloc_code (scheme_extension_table->scheme_malloc_code) #define scheme_malloc_code (scheme_extension_table->scheme_malloc_code)
#define scheme_malloc_permanent_code (scheme_extension_table->scheme_malloc_permanent_code)
#define scheme_free_code (scheme_extension_table->scheme_free_code) #define scheme_free_code (scheme_extension_table->scheme_free_code)
#ifndef MZ_PRECISE_GC #ifndef MZ_PRECISE_GC
#define scheme_malloc_gcable_code (scheme_extension_table->scheme_malloc_gcable_code) #define scheme_malloc_gcable_code (scheme_extension_table->scheme_malloc_gcable_code)

80
src/racket/src/struct.c
View File

@ -120,9 +120,6 @@ static Scheme_Object *struct_to_vector(int argc, Scheme_Object *argv[]);
static Scheme_Object *prefab_struct_key(int argc, Scheme_Object *argv[]); static Scheme_Object *prefab_struct_key(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_prefab_struct(int argc, Scheme_Object *argv[]); static Scheme_Object *make_prefab_struct(int argc, Scheme_Object *argv[]);
static Scheme_Object *prefab_key_struct_type(int argc, Scheme_Object *argv[]); static Scheme_Object *prefab_key_struct_type(int argc, Scheme_Object *argv[]);
#ifdef MZ_USE_PLACES
static Scheme_Object *convert_prefab_key_to_external_form(Scheme_Object *key);
#endif
static Scheme_Object *struct_setter_p(int argc, Scheme_Object *argv[]); static Scheme_Object *struct_setter_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *struct_getter_p(int argc, Scheme_Object *argv[]); static Scheme_Object *struct_getter_p(int argc, Scheme_Object *argv[]);
@ -2801,13 +2798,7 @@ Scheme_Object *scheme_prefab_struct_key(Scheme_Object *so)
s = (Scheme_Structure *)SCHEME_CHAPERONE_VAL((Scheme_Object *)s); s = (Scheme_Structure *)SCHEME_CHAPERONE_VAL((Scheme_Object *)s);
if (SCHEME_STRUCTP(((Scheme_Object *)s)) && s->stype->prefab_key) { if (SCHEME_STRUCTP(((Scheme_Object *)s)) && s->stype->prefab_key) {
Scheme_Object *prefab_key; return SCHEME_CDR(s->stype->prefab_key);
prefab_key = SCHEME_CDR(s->stype->prefab_key);
#ifdef MZ_USE_PLACES
return convert_prefab_key_to_external_form(prefab_key);
#else
return prefab_key;
#endif
} }
return scheme_false; return scheme_false;
@ -3966,8 +3957,6 @@ Scheme_Struct_Type *scheme_make_prefab_struct_type_raw(Scheme_Object *base,
struct_type->num_islots = num_fields + (parent_type ? parent_type->num_islots : 0); struct_type->num_islots = num_fields + (parent_type ? parent_type->num_islots : 0);
struct_type->name_pos = depth; struct_type->name_pos = depth;
struct_type->inspector = scheme_false; struct_type->inspector = scheme_false;
//Scheme_Object *accessor *mutator;
//Scheme_Object *prefab_key;
struct_type->uninit_val = uninit_val; struct_type->uninit_val = uninit_val;
struct_type->props = NULL; struct_type->props = NULL;
struct_type->num_props = 0; struct_type->num_props = 0;
@ -3988,14 +3977,7 @@ static Scheme_Struct_Type *scheme_make_prefab_struct_type(Scheme_Object *base,
Scheme_Object *uninit_val, Scheme_Object *uninit_val,
char *immutable_array) char *immutable_array)
{ {
#ifdef MZ_USE_PLACES return scheme_make_prefab_struct_type_raw(base,
/*
return scheme_make_prefab_struct_type_in_master
*/
#else
#endif
return scheme_make_prefab_struct_type_raw
(base,
parent, parent,
num_fields, num_fields,
num_uninit_fields, num_uninit_fields,
@ -4638,19 +4620,7 @@ static Scheme_Object *make_prefab_key(Scheme_Struct_Type *type)
if (!SCHEME_NULLP(stack)) if (!SCHEME_NULLP(stack))
key = scheme_make_pair(scheme_make_integer(icnt), key); key = scheme_make_pair(scheme_make_integer(icnt), key);
/*symbols aren't equal? across places now*/
#if defined(MZ_USE_PLACES)
if (SCHEME_SYMBOLP(type->name)) {
Scheme_Object *newname;
newname = scheme_make_sized_offset_byte_string((char *)type->name, SCHEME_SYMSTR_OFFSET(type->name), SCHEME_SYM_LEN(type->name), 1);
key = scheme_make_pair(newname, key);
}
else {
scheme_arg_mismatch("make_prefab_key", "unknown type of struct name", type->name);
}
#else
key = scheme_make_pair(type->name, key); key = scheme_make_pair(type->name, key);
#endif
if (SCHEME_PAIRP(stack)) { if (SCHEME_PAIRP(stack)) {
type = (Scheme_Struct_Type *)SCHEME_CAR(stack); type = (Scheme_Struct_Type *)SCHEME_CAR(stack);
@ -4703,29 +4673,6 @@ static char *mutability_data_to_immutability_data(int icnt, Scheme_Object *mutab
return immutable_array; return immutable_array;
} }
#ifdef MZ_USE_PLACES
static Scheme_Object *convert_prefab_key_to_external_form(Scheme_Object *key)
{
Scheme_Object *l;
Scheme_Object *nl;
if (SCHEME_SYMBOLP(key)) return key;
if (SCHEME_BYTE_STRINGP(key))
return scheme_intern_exact_symbol(SCHEME_BYTE_STR_VAL(key), SCHEME_BYTE_STRLEN_VAL(key));
nl = scheme_null;
for (l = key; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
Scheme_Object *a;
a = SCHEME_CAR(l);
if (SCHEME_BYTE_STRINGP(a))
a = scheme_intern_exact_symbol(SCHEME_BYTE_STR_VAL(a), SCHEME_BYTE_STRLEN_VAL(a));
nl = scheme_make_pair(a, nl);
}
return scheme_reverse(nl);
}
#endif
Scheme_Struct_Type *scheme_lookup_prefab_type(Scheme_Object *key, int field_count) Scheme_Struct_Type *scheme_lookup_prefab_type(Scheme_Object *key, int field_count)
{ {
Scheme_Struct_Type *parent = NULL; Scheme_Struct_Type *parent = NULL;
@ -4733,19 +4680,8 @@ Scheme_Struct_Type *scheme_lookup_prefab_type(Scheme_Object *key, int field_coun
int ucnt, icnt; int ucnt, icnt;
char *immutable_array = NULL; char *immutable_array = NULL;
/*symbols aren't equal? across places now*/
#if defined(MZ_USE_PLACES)
if (SCHEME_SYMBOLP(key)) {
Scheme_Object *newname;
newname = scheme_make_sized_offset_byte_string((char*)key, SCHEME_SYMSTR_OFFSET(key), SCHEME_SYM_LEN(key), 1);
key = scheme_make_pair(newname, scheme_null);
}
if (SCHEME_BYTE_STRINGP(key))
key = scheme_make_pair(key, scheme_null);
#else
if (SCHEME_SYMBOLP(key)) if (SCHEME_SYMBOLP(key))
key = scheme_make_pair(key, scheme_null); key = scheme_make_pair(key, scheme_null);
#endif
if (scheme_proper_list_length(key) < 0) if (scheme_proper_list_length(key) < 0)
return NULL; return NULL;
@ -4819,21 +4755,9 @@ Scheme_Struct_Type *scheme_lookup_prefab_type(Scheme_Object *key, int field_coun
a = SCHEME_CAR(key); a = SCHEME_CAR(key);
key = SCHEME_CDR(key); key = SCHEME_CDR(key);
/*symbols aren't equal? across places now*/
#if defined(MZ_USE_PLACES)
if (SCHEME_SYMBOLP(a)) {
name = a;
}
else if (SCHEME_BYTE_STRINGP(a))
name = scheme_intern_exact_symbol(SCHEME_BYTE_STR_VAL(a), SCHEME_BYTE_STRLEN_VAL(a));
else
return NULL;
#else
if (!SCHEME_SYMBOLP(a)) if (!SCHEME_SYMBOLP(a))
return NULL; return NULL;
name = a; name = a;
#endif
immutable_array = mutability_data_to_immutability_data(icnt + ucnt, mutables); immutable_array = mutability_data_to_immutability_data(icnt + ucnt, mutables);

8
src/racket/src/thread.c
View File

@ -122,6 +122,7 @@ static void check_ready_break();
THREAD_LOCAL_DECL(extern int scheme_num_read_syntax_objects); THREAD_LOCAL_DECL(extern int scheme_num_read_syntax_objects);
THREAD_LOCAL_DECL(extern intptr_t scheme_hash_request_count); THREAD_LOCAL_DECL(extern intptr_t scheme_hash_request_count);
THREAD_LOCAL_DECL(extern intptr_t scheme_hash_iteration_count); THREAD_LOCAL_DECL(extern intptr_t scheme_hash_iteration_count);
THREAD_LOCAL_DECL(extern intptr_t scheme_code_page_total);
#ifdef MZ_USE_JIT #ifdef MZ_USE_JIT
extern int scheme_jit_malloced; extern int scheme_jit_malloced;
#else #else
@ -7624,6 +7625,8 @@ static char *gc_num(char *nums, int v)
} }
i++; i++;
v /= 1024; /* bytes => kbytes */
sprintf(nums+i, "%d", v); sprintf(nums+i, "%d", v);
for (len = 0; nums[i+len]; len++) { } for (len = 0; nums[i+len]; len++) { }
clen = len + ((len + ((nums[i] == '-') ? -2 : -1)) / 3); clen = len + ((len + ((nums[i] == '-') ? -2 : -1)) / 3);
@ -7667,13 +7670,14 @@ static void inform_GC(int master_gc, int major_gc,
delta = pre_used - post_used; delta = pre_used - post_used;
admin_delta = (pre_admin - post_admin) - delta; admin_delta = (pre_admin - post_admin) - delta;
sprintf(buf, sprintf(buf,
"GC [" PLACE_ID_FORMAT "%s] at %s(+%s) bytes;" "GC [" PLACE_ID_FORMAT "%s] at %sK(+%sK)[+%sK];"
" %s(%s%s) collected in %" PRIdPTR " msec", " freed %sK(%s%sK) in %" PRIdPTR " msec",
#ifdef MZ_USE_PLACES #ifdef MZ_USE_PLACES
scheme_current_place_id, scheme_current_place_id,
#endif #endif
(master_gc ? "MASTER" : (major_gc ? "MAJOR" : "minor")), (master_gc ? "MASTER" : (major_gc ? "MAJOR" : "minor")),
gc_num(nums, pre_used), gc_num(nums, pre_admin - pre_used), gc_num(nums, pre_used), gc_num(nums, pre_admin - pre_used),
gc_num(nums, scheme_code_page_total),
gc_num(nums, delta), ((admin_delta < 0) ? "" : "+"), gc_num(nums, admin_delta), gc_num(nums, delta), ((admin_delta < 0) ? "" : "+"), gc_num(nums, admin_delta),
(master_gc ? 0 : (end_this_gc_time - start_this_gc_time))); (master_gc ? 0 : (end_this_gc_time - start_this_gc_time)));
buflen = strlen(buf); buflen = strlen(buf);