Memory ricing to make deploy tests pass on Mac OS X/PowerPC

Slava Pestov 2008-09-19 00:26:27 -05:00
parent 09ecec270a
commit 3d790d8ac8
8 changed files with 84 additions and 40 deletions

View File

@ -3,13 +3,10 @@
USING: alien alien.c-types alien.strings alien.syntax kernel USING: alien alien.c-types alien.strings alien.syntax kernel
math sequences namespaces make assocs init accessors math sequences namespaces make assocs init accessors
continuations combinators core-foundation continuations combinators core-foundation
core-foundation.run-loop io.encodings.utf8 destructors ; core-foundation.run-loop core-foundation.run-loop.thread
io.encodings.utf8 destructors ;
IN: core-foundation.fsevents IN: core-foundation.fsevents
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! FSEventStream API, Leopard only !
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
: kFSEventStreamCreateFlagUseCFTypes 2 ; inline : kFSEventStreamCreateFlagUseCFTypes 2 ; inline
: kFSEventStreamCreateFlagWatchRoot 4 ; inline : kFSEventStreamCreateFlagWatchRoot 4 ; inline

View File

@ -35,5 +35,3 @@ FUNCTION: SInt32 CFRunLoopRunInMode (
: start-run-loop-thread ( -- ) : start-run-loop-thread ( -- )
[ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ; [ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ;
[ start-run-loop-thread ] "core-foundation.run-loop" add-init-hook

View File

@ -0,0 +1,8 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: init core-foundation.run-loop ;
IN: core-foundation.run-loop.thread
! Load this vocabulary if you need a run loop running.
[ start-run-loop-thread ] "core-foundation.run-loop.thread" add-init-hook

View File

@ -1,3 +1,5 @@
! Copyright (C) 2008 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types io io.files kernel namespaces random USING: alien.c-types io io.files kernel namespaces random
io.encodings.binary init accessors system ; io.encodings.binary init accessors system ;
IN: random.unix IN: random.unix

View File

@ -96,7 +96,7 @@ IN: stack-checker.transforms
\ boa [ \ boa [
dup tuple-class? [ dup tuple-class? [
dup inlined-dependency depends-on dup inlined-dependency depends-on
[ "boa-check" word-prop ] [ "boa-check" word-prop [ ] or ]
[ tuple-layout '[ _ <tuple-boa> ] ] [ tuple-layout '[ _ <tuple-boa> ] ]
bi append bi append
] [ drop f ] if ] [ drop f ] if

View File

@ -4,7 +4,7 @@ USING: accessors qualified io.streams.c init fry namespaces make
assocs kernel parser lexer strings.parser tools.deploy.config assocs kernel parser lexer strings.parser tools.deploy.config
vocabs sequences words words.private memory kernel.private vocabs sequences words words.private memory kernel.private
continuations io prettyprint vocabs.loader debugger system continuations io prettyprint vocabs.loader debugger system
strings sets vectors quotations byte-arrays ; strings sets vectors quotations byte-arrays sorting ;
QUALIFIED: bootstrap.stage2 QUALIFIED: bootstrap.stage2
QUALIFIED: classes QUALIFIED: classes
QUALIFIED: command-line QUALIFIED: command-line
@ -29,6 +29,7 @@ IN: tools.deploy.shaker
"cpu.x86" init-hooks get delete-at "cpu.x86" init-hooks get delete-at
"command-line" init-hooks get delete-at "command-line" init-hooks get delete-at
"libc" init-hooks get delete-at "libc" init-hooks get delete-at
"system" init-hooks get delete-at
deploy-threads? get [ deploy-threads? get [
"threads" init-hooks get delete-at "threads" init-hooks get delete-at
] unless ] unless
@ -36,7 +37,11 @@ IN: tools.deploy.shaker
"io.thread" init-hooks get delete-at "io.thread" init-hooks get delete-at
] unless ] unless
strip-io? [ strip-io? [
"io.files" init-hooks get delete-at
"io.backend" init-hooks get delete-at "io.backend" init-hooks get delete-at
] when
strip-dictionary? [
"compiler.units" init-hooks get delete-at
] when ; ] when ;
: strip-debugger ( -- ) : strip-debugger ( -- )
@ -74,17 +79,22 @@ IN: tools.deploy.shaker
: strip-word-props ( stripped-props words -- ) : strip-word-props ( stripped-props words -- )
"Stripping word properties" show "Stripping word properties" show
[ [
[ swap '[
props>> swap [
'[ drop _ member? not ] assoc-filter sift-assoc [ drop _ member? not ] assoc-filter sift-assoc
dup assoc-empty? [ drop f ] [ >alist >vector ] if >alist f like
] keep (>>props) ] change-props drop
] with each ; ] each
] [
"Remaining word properties:" print
[ props>> keys ] gather .
] bi ;
: stripped-word-props ( -- seq ) : stripped-word-props ( -- seq )
[ [
strip-dictionary? [ strip-dictionary? [
{ {
"boa-check"
"cannot-infer" "cannot-infer"
"coercer" "coercer"
"combination" "combination"
@ -92,12 +102,15 @@ IN: tools.deploy.shaker
"compiled-generic-uses" "compiled-generic-uses"
"compiled-uses" "compiled-uses"
"constraints" "constraints"
"custom-inlining"
"declared-effect" "declared-effect"
"default" "default"
"default-method" "default-method"
"default-output-classes" "default-output-classes"
"derived-from" "derived-from"
"engines" "engines"
"forgotten"
"identities"
"if-intrinsics" "if-intrinsics"
"infer" "infer"
"inferred-effect" "inferred-effect"
@ -116,9 +129,11 @@ IN: tools.deploy.shaker
"macro" "macro"
"members" "members"
"memo-quot" "memo-quot"
"mixin"
"method-class" "method-class"
"method-generic" "method-generic"
"methods" "methods"
"modular-arithmetic"
"no-compile" "no-compile"
"optimizer-hooks" "optimizer-hooks"
"outputs" "outputs"
@ -126,6 +141,7 @@ IN: tools.deploy.shaker
"predicate" "predicate"
"predicate-definition" "predicate-definition"
"predicating" "predicating"
"primitive"
"reader" "reader"
"reading" "reading"
"recursive" "recursive"
@ -230,6 +246,7 @@ IN: tools.deploy.shaker
compiled-generic-crossref compiled-generic-crossref
compiler.units:recompile-hook compiler.units:recompile-hook
compiler.units:update-tuples-hook compiler.units:update-tuples-hook
compiler.units:definition-observers
definitions:crossref definitions:crossref
interactive-vocabs interactive-vocabs
layouts:num-tags layouts:num-tags
@ -244,6 +261,7 @@ IN: tools.deploy.shaker
vocabs:dictionary vocabs:dictionary
vocabs:load-vocab-hook vocabs:load-vocab-hook
word word
parser-notes
} % } %
{ } { "math.partial-dispatch" } strip-vocab-globals % { } { "math.partial-dispatch" } strip-vocab-globals %
@ -273,7 +291,7 @@ IN: tools.deploy.shaker
"ui-error-hook" "ui.gadgets.worlds" lookup , "ui-error-hook" "ui.gadgets.worlds" lookup ,
] when ] when
"<computer>" "inference.dataflow" lookup [ , ] when* "<value>" "stack-checker.state" lookup [ , ] when*
"windows-messages" "windows.messages" lookup [ , ] when* "windows-messages" "windows.messages" lookup [ , ] when*

View File

@ -1,30 +1,50 @@
USING: cocoa cocoa.messages cocoa.application cocoa.nibs ! Copyright (C) 2007, 2008 Slava Pestov
assocs namespaces kernel words compiler.units sequences ! See http://factorcode.org/license.txt for BSD license.
ui ui.cocoa ; USING: cocoa cocoa.messages cocoa.application cocoa.nibs assocs
namespaces kernel kernel.private words compiler.units sequences
ui ui.cocoa init ;
IN: tools.deploy.shaker.cocoa
: pool ( obj -- obj' ) \ pool get [ ] cache ;
: pool-array ( obj -- obj' ) [ pool ] map pool ;
: pool-keys ( assoc -- assoc' ) [ [ pool-array ] dip ] assoc-map ;
: pool-values ( assoc -- assoc' ) [ pool-array ] assoc-map ;
IN: cocoa.application
: objc-error ( error -- ) die ;
[ [ die ] 19 setenv ] "cocoa.application" add-init-hook
"stop-after-last-window?" get "stop-after-last-window?" get
global [
stop-after-last-window? set
[ "MiniFactor.nib" load-nib ] cocoa-init-hook set-global H{ } clone \ pool [
global [
stop-after-last-window? set
! Only keeps those methods that we actually call [ "MiniFactor.nib" load-nib ] cocoa-init-hook set-global
sent-messages get super-sent-messages get assoc-union
objc-methods [ assoc-intersect ] change
sent-messages get ! Only keeps those methods that we actually call
super-sent-messages get sent-messages get super-sent-messages get assoc-union
[ keys [ objc-methods get at dup ] H{ } map>assoc ] bi@ objc-methods [ assoc-intersect pool-values ] change
super-message-senders [ assoc-intersect ] change
message-senders [ assoc-intersect ] change
sent-messages off sent-messages get
super-sent-messages off super-sent-messages get
[ keys [ objc-methods get at dup ] H{ } map>assoc ] bi@
super-message-senders [ assoc-intersect pool-keys ] change
message-senders [ assoc-intersect pool-keys ] change
alien>objc-types off sent-messages off
objc>alien-types off super-sent-messages off
! We need this for strip-stack-traces to work fully alien>objc-types off
{ message-senders super-message-senders } objc>alien-types off
[ get values compile ] each
] bind ! We need this for strip-stack-traces to work fully
{ message-senders super-message-senders }
[ get values compile ] each
] bind
] with-variable

View File

@ -125,7 +125,8 @@ ERROR: bad-superclass class ;
} cond ; } cond ;
: boa-check-quot ( class -- quot ) : boa-check-quot ( class -- quot )
all-slots [ class>> instance-check-quot ] map spread>quot ; all-slots [ class>> instance-check-quot ] map spread>quot
f like ;
: define-boa-check ( class -- ) : define-boa-check ( class -- )
dup boa-check-quot "boa-check" set-word-prop ; dup boa-check-quot "boa-check" set-word-prop ;
@ -311,7 +312,7 @@ M: tuple-class new
[ (clone) ] [ tuple-layout <tuple> ] ?if ; [ (clone) ] [ tuple-layout <tuple> ] ?if ;
M: tuple-class boa M: tuple-class boa
[ "boa-check" word-prop call ] [ "boa-check" word-prop [ call ] when* ]
[ tuple-layout ] [ tuple-layout ]
bi <tuple-boa> ; bi <tuple-boa> ;