Memory ricing to make deploy tests pass on Mac OS X/PowerPC
parent
09ecec270a
commit
3d790d8ac8
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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*
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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> ;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue