error-continuation set-global
error set-global ; inline
+
[
! We time bootstrap
millis
"stage2: deployment mode" print
] [
"debugger" require
- "inspector" require
- "tools.errors" require
"listener" require
"none" require
] if
! See http://factorcode.org/license.txt for BSD license.
!
! Remote Channels
- USING: kernel init namespaces make assocs arrays random
+ USING: kernel init namespaces assocs arrays random
sequences channels match concurrency.messaging
concurrency.distributed threads accessors ;
IN: channels.remote
MATCH-VARS: ?from ?tag ?id ?value ;
SYMBOL: no-channel
+ TUPLE: to-message id value ;
+ TUPLE: from-message id ;
- : channel-process ( -- )
+ : channel-thread ( -- )
[
{
- { { to ?id ?value }
+ { T{ to-message f ?id ?value }
[ ?value ?id get-channel dup [ to f ] [ 2drop no-channel ] if ] }
- { { from ?id }
+ { T{ from-message f ?id }
[ ?id get-channel [ from ] [ no-channel ] if* ] }
} match-cond
] handle-synchronous ;
- PRIVATE>
-
: start-channel-node ( -- )
- "remote-channels" get-process [
- "remote-channels"
- [ channel-process t ] "Remote channels" spawn-server
- register-process
+ "remote-channels" get-remote-thread [
+ [ channel-thread t ] "Remote channels" spawn-server
+ "remote-channels" register-remote-thread
] unless ;
+ PRIVATE>
+
TUPLE: remote-channel node id ;
C: <remote-channel> remote-channel
+ <PRIVATE
+
+ : send-message ( message remote-channel -- value )
+ node>> "remote-channels" <remote-thread>
+ send-synchronous dup no-channel = [ no-channel throw ] when* ;
+
+ PRIVATE>
+
M: remote-channel to ( value remote-channel -- )
- [ [ \ to , id>> , , ] { } make ] keep
- node>> "remote-channels" <remote-process>
- send-synchronous no-channel = [ no-channel throw ] when ;
+ [ id>> swap to-message boa ] keep send-message drop ;
M: remote-channel from ( remote-channel -- value )
- [ [ \ from , id>> , ] { } make ] keep
- node>> "remote-channels" <remote-process>
- send-synchronous dup no-channel = [ no-channel throw ] when* ;
+ [ id>> from-message boa ] keep send-message ;
[
H{ } clone \ remote-channels set-global
start-channel-node
-] "channel-registry" add-init-hook
+] "channel-registry" add-startup-hook
: remember-send ( selector -- )
sent-messages (remember-send) ;
- SYNTAX: -> scan dup remember-send parsed \ send parsed ;
+ SYNTAX: -> scan dup remember-send suffix! \ send suffix! ;
SYMBOL: super-sent-messages
: remember-super-send ( selector -- )
super-sent-messages (remember-send) ;
- SYNTAX: SUPER-> scan dup remember-super-send parsed \ super-send parsed ;
+ SYNTAX: SUPER-> scan dup remember-super-send suffix! \ super-send suffix! ;
SYMBOL: frameworks
frameworks [ V{ } clone ] initialize
-[ frameworks get [ load-framework ] each ] "cocoa" add-init-hook
+[ frameworks get [ load-framework ] each ] "cocoa" add-startup-hook
SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings arrays assocs
classes.struct continuations combinators compiler compiler.alien
- stack-checker kernel math namespaces make quotations sequences
- strings words cocoa.runtime io macros memoize io.encodings.utf8
- effects libc libc.private lexer init core-foundation fry
- generalizations specialized-arrays ;
+ core-graphics.types stack-checker kernel math namespaces make
+ quotations sequences strings words cocoa.runtime cocoa.types io
+ macros memoize io.encodings.utf8 effects layouts libc
+ libc.private lexer init core-foundation fry generalizations
+ specialized-arrays ;
+ QUALIFIED-WITH: alien.c-types c
IN: cocoa.messages
SPECIALIZED-ARRAY: void*
: super-send ( receiver args... selector -- return... ) t (send) ; inline
! Runtime introspection
-SYMBOL: class-init-hooks
+SYMBOL: class-startup-hooks
-class-init-hooks [ H{ } clone ] initialize
+class-startup-hooks [ H{ } clone ] initialize
: (objc-class) ( name word -- class )
2dup execute dup [ 2nip ] [
- drop over class-init-hooks get at [ call( -- ) ] when*
+ drop over class-startup-hooks get at [ call( -- ) ] when*
2dup execute dup [ 2nip ] [
2drop "No such class: " prepend throw
] if
SYMBOL: objc>alien-types
H{
- { "c" "char" }
- { "i" "int" }
- { "s" "short" }
- { "C" "uchar" }
- { "I" "uint" }
- { "S" "ushort" }
- { "f" "float" }
- { "d" "double" }
- { "B" "bool" }
- { "v" "void" }
- { "*" "char*" }
- { "?" "unknown_type" }
- { "@" "id" }
- { "#" "Class" }
- { ":" "SEL" }
+ { "c" c:char }
+ { "i" c:int }
+ { "s" c:short }
+ { "C" c:uchar }
+ { "I" c:uint }
+ { "S" c:ushort }
+ { "f" c:float }
+ { "d" c:double }
+ { "B" c:bool }
+ { "v" c:void }
+ { "*" c:char* }
+ { "?" unknown_type }
+ { "@" id }
+ { "#" Class }
+ { ":" SEL }
}
- "ptrdiff_t" heap-size {
+ cell {
{ 4 [ H{
- { "l" "long" }
- { "q" "longlong" }
- { "L" "ulong" }
- { "Q" "ulonglong" }
+ { "l" c:long }
+ { "q" c:longlong }
+ { "L" c:ulong }
+ { "Q" c:ulonglong }
} ] }
{ 8 [ H{
- { "l" "long32" }
- { "q" "long" }
- { "L" "ulong32" }
- { "Q" "ulong" }
+ { "l" long32 }
+ { "q" long }
+ { "L" ulong32 }
+ { "Q" ulong }
} ] }
} case
assoc-union objc>alien-types set-global
+ SYMBOL: objc>struct-types
+
+ H{
+ { "_NSPoint" NSPoint }
+ { "NSPoint" NSPoint }
+ { "CGPoint" NSPoint }
+ { "_NSRect" NSRect }
+ { "NSRect" NSRect }
+ { "CGRect" NSRect }
+ { "_NSSize" NSSize }
+ { "NSSize" NSSize }
+ { "CGSize" NSSize }
+ { "_NSRange" NSRange }
+ { "NSRange" NSRange }
+ } objc>struct-types set-global
+
! The transpose of the above map
SYMBOL: alien>objc-types
objc>alien-types get [ swap ] assoc-map
! A hack...
- "ptrdiff_t" heap-size {
+ cell {
{ 4 [ H{
- { "NSPoint" "{_NSPoint=ff}" }
- { "NSRect" "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
- { "NSSize" "{_NSSize=ff}" }
- { "NSRange" "{_NSRange=II}" }
- { "NSInteger" "i" }
- { "NSUInteger" "I" }
- { "CGFloat" "f" }
+ { NSPoint "{_NSPoint=ff}" }
+ { NSRect "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
+ { NSSize "{_NSSize=ff}" }
+ { NSRange "{_NSRange=II}" }
+ { NSInteger "i" }
+ { NSUInteger "I" }
+ { CGFloat "f" }
} ] }
{ 8 [ H{
- { "NSPoint" "{CGPoint=dd}" }
- { "NSRect" "{CGRect={CGPoint=dd}{CGSize=dd}}" }
- { "NSSize" "{CGSize=dd}" }
- { "NSRange" "{_NSRange=QQ}" }
- { "NSInteger" "q" }
- { "NSUInteger" "Q" }
- { "CGFloat" "d" }
+ { NSPoint "{CGPoint=dd}" }
+ { NSRect "{CGRect={CGPoint=dd}{CGSize=dd}}" }
+ { NSSize "{CGSize=dd}" }
+ { NSRange "{_NSRange=QQ}" }
+ { NSInteger "q" }
+ { NSUInteger "Q" }
+ { CGFloat "d" }
} ] }
} case
assoc-union alien>objc-types set-global
- : internal-cocoa-type? ( c-type -- ? )
- [ "?" = ] [ first CHAR: _ = ] bi or ;
-
- : warn-c-type ( c-type -- )
- dup internal-cocoa-type?
- [ drop ] [ "Warning: no such C type: " write print ] if ;
-
: objc-struct-type ( i string -- ctype )
[ CHAR: = ] 2keep index-from swap subseq
- dup c-types get key? [ warn-c-type "void*" ] unless ;
+ objc>struct-types get at* [ drop void* ] unless ;
ERROR: no-objc-type name ;
: (parse-objc-type) ( i string -- ctype )
[ [ 1 + ] dip ] [ nth ] 2bi {
{ [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
- { [ dup CHAR: ^ = ] [ 3drop "void*" ] }
+ { [ dup CHAR: ^ = ] [ 3drop void* ] }
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }
- { [ dup CHAR: [ = ] [ 3drop "void*" ] }
+ { [ dup CHAR: [ = ] [ 3drop void* ] }
[ 2nip decode-type ]
} cond ;
: class-exists? ( string -- class ) objc_getClass >boolean ;
: define-objc-class-word ( quot name -- )
- [ class-init-hooks get set-at ]
+ [ class-startup-hooks get set-at ]
[
[ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi
(( -- class )) define-declared
{ release void* }
{ copyDescription void* } ;
- ! callback(FSEventStreamRef streamRef, void *clientCallBackInfo, size_t numEvents, void *eventPaths, const FSEventStreamEventFlags eventFlags[], const FSEventStreamEventId eventIds[]);
- TYPEDEF: void* FSEventStreamCallback
+ ! callback(
+ CALLBACK: void FSEventStreamCallback ( FSEventStreamRef streamRef, void* clientCallBackInfo, size_t numEvents, void* eventPaths, FSEventStreamEventFlags* eventFlags, FSEventStreamEventId* eventIds ) ;
CONSTANT: FSEventStreamEventIdSinceNow HEX: FFFFFFFFFFFFFFFF
[
event-stream-callbacks
[ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-global
-] "core-foundation" add-init-hook
+] "core-foundation" add-startup-hook
: add-event-source-callback ( quot -- id )
event-stream-counter <alien>
[
line new-disposable
- [let* | open-font [ font cache-font ]
- line [ string open-font font foreground>> <CTLine> |CFRelease ]
-
- rect [ line line-rect ]
- (loc) [ rect origin>> CGPoint>loc ]
- (dim) [ rect size>> CGSize>dim ]
- (ext) [ (loc) (dim) v+ ]
- loc [ (loc) [ floor ] map ]
- ext [ (loc) (dim) [ + ceiling ] 2map ]
- dim [ ext loc [ - >integer 1 max ] 2map ]
- metrics [ open-font line compute-line-metrics ] |
-
- line >>line
-
- metrics >>metrics
-
- dim [
- {
- [ font dim fill-background ]
- [ loc dim line string fill-selection-background ]
- [ loc set-text-position ]
- [ [ line ] dip CTLineDraw ]
- } cleave
- ] make-bitmap-image >>image
-
- metrics loc dim line-loc >>loc
-
- metrics metrics>dim >>dim
- ]
+ font cache-font :> open-font
+ string open-font font foreground>> <CTLine> |CFRelease :> line
+
+ line line-rect :> rect
+ rect origin>> CGPoint>loc :> (loc)
+ rect size>> CGSize>dim :> (dim)
+ (loc) (dim) v+ :> (ext)
+ (loc) [ floor ] map :> loc
+ (loc) (dim) [ + ceiling ] 2map :> ext
+ ext loc [ - >integer 1 max ] 2map :> dim
+ open-font line compute-line-metrics :> metrics
+
+ line >>line
+
+ metrics >>metrics
+
+ dim [
+ {
+ [ font dim fill-background ]
+ [ loc dim line string fill-selection-background ]
+ [ loc set-text-position ]
+ [ [ line ] dip CTLineDraw ]
+ } cleave
+ ] make-bitmap-image >>image
+
+ metrics loc dim line-loc >>loc
+
+ metrics metrics>dim >>dim
] with-destructors ;
M: line dispose* line>> CFRelease ;
: cached-line ( font string -- line )
cached-lines get [ <line> ] 2cache ;
-[ <cache-assoc> cached-lines set-global ] "core-text" add-init-hook
+[ <cache-assoc> cached-lines set-global ] "core-text" add-startup-hook
cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
cpu.x86.features cpu.x86.features.private cpu.architecture kernel
kernel.private math memory namespaces make sequences words system
- layouts combinators math.order fry locals compiler.constants
+ layouts combinators math.order math.vectors fry locals compiler.constants
byte-arrays io macros quotations compiler compiler.units init vm
compiler.cfg.registers
compiler.cfg.instructions
: incr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
- : align-stack ( n -- n' )
- os macosx? cpu x86.64? or [ 16 align ] when ;
+ : align-stack ( n -- n' ) 16 align ;
M: x86 stack-frame-size ( stack-frame -- i )
[ (stack-frame-size) ]
M: x86 %neg int-rep one-operand NEG ;
M: x86 %log2 BSR ;
+ ! A bit of logic to avoid using MOVSS/MOVSD for reg-reg moves
+ ! since this induces partial register stalls
GENERIC: copy-register* ( dst src rep -- )
+ GENERIC: copy-memory* ( dst src rep -- )
M: int-rep copy-register* drop MOV ;
M: tagged-rep copy-register* drop MOV ;
- M: float-rep copy-register* drop MOVSS ;
- M: double-rep copy-register* drop MOVSD ;
- M: float-4-rep copy-register* drop MOVUPS ;
- M: double-2-rep copy-register* drop MOVUPD ;
- M: vector-rep copy-register* drop MOVDQU ;
+ M: float-rep copy-register* drop MOVAPS ;
+ M: double-rep copy-register* drop MOVAPS ;
+ M: float-4-rep copy-register* drop MOVAPS ;
+ M: double-2-rep copy-register* drop MOVAPS ;
+ M: vector-rep copy-register* drop MOVDQA ;
+
+ M: object copy-memory* copy-register* ;
+ M: float-rep copy-memory* drop MOVSS ;
+ M: double-rep copy-memory* drop MOVSD ;
M: x86 %copy ( dst src rep -- )
2over eq? [ 3drop ] [
[ [ dup spill-slot? [ n>> spill@ ] when ] bi@ ] dip
- copy-register*
+ 2over [ register? ] both? [ copy-register* ] [ copy-memory* ] if
] if ;
M: x86 %fixnum-add ( label dst src1 src2 -- )
M: x86 %unbox-alien ( dst src -- )
alien-offset [+] MOV ;
- M:: x86 %unbox-any-c-ptr ( dst src temp -- )
+ M:: x86 %unbox-any-c-ptr ( dst src -- )
[
- { "is-byte-array" "end" "start" } [ define-label ] each
- dst 0 MOV
- temp src MOV
- ! We come back here with displaced aliens
- "start" resolve-label
+ "end" define-label
+ dst dst XOR
! Is the object f?
- temp \ f tag-number CMP
+ src \ f type-number CMP
"end" get JE
+ ! Compute tag in dst register
+ dst src MOV
+ dst tag-mask get AND
! Is the object an alien?
- temp header-offset [+] alien type-number tag-fixnum CMP
- "is-byte-array" get JNE
- ! If so, load the offset and add it to the address
- dst temp alien-offset [+] ADD
- ! Now recurse on the underlying alien
- temp temp underlying-alien-offset [+] MOV
- "start" get JMP
- "is-byte-array" resolve-label
- ! Add byte array address to address being computed
- dst temp ADD
+ dst alien type-number CMP
! Add an offset to start of byte array's data
- dst byte-array-offset ADD
+ dst src byte-array-offset [+] LEA
+ "end" get JNE
+ ! If so, load the offset and add it to the address
+ dst src alien-offset [+] MOV
"end" resolve-label
] with-scope ;
- : alien@ ( reg n -- op ) cells alien tag-number - [+] ;
-
- :: %allot-alien ( dst displacement base temp -- )
- dst 4 cells alien temp %allot
- dst 1 alien@ base MOV ! alien
- dst 2 alien@ \ f tag-number MOV ! expired
- dst 3 alien@ displacement MOV ! displacement
- ;
+ : alien@ ( reg n -- op ) cells alien type-number - [+] ;
M:: x86 %box-alien ( dst src temp -- )
[
"end" define-label
- dst \ f tag-number MOV
- src 0 CMP
+ dst \ f type-number MOV
+ src src TEST
"end" get JE
- dst src \ f tag-number temp %allot-alien
+ dst 5 cells alien temp %allot
+ dst 1 alien@ \ f type-number MOV ! base
+ dst 2 alien@ \ f type-number MOV ! expired
+ dst 3 alien@ src MOV ! displacement
+ dst 4 alien@ src MOV ! address
"end" resolve-label
] with-scope ;
- M:: x86 %box-displaced-alien ( dst displacement base displacement' base' base-class -- )
+ M:: x86 %box-displaced-alien ( dst displacement base temp base-class -- )
+ ! This is ridiculous
[
"end" define-label
- "ok" define-label
+ "not-f" define-label
+ "not-alien" define-label
+
! If displacement is zero, return the base
dst base MOV
- displacement 0 CMP
+ displacement displacement TEST
"end" get JE
- ! Quickly use displacement' before its needed for real, as allot temporary
- dst 4 cells alien displacement' %allot
- ! If base is already a displaced alien, unpack it
- base' base MOV
- displacement' displacement MOV
- base \ f tag-number CMP
- "ok" get JE
- base header-offset [+] alien type-number tag-fixnum CMP
- "ok" get JNE
- ! displacement += base.displacement
- displacement' base 3 alien@ ADD
- ! base = base.base
- base' base 1 alien@ MOV
- "ok" resolve-label
- dst 1 alien@ base' MOV ! alien
- dst 2 alien@ \ f tag-number MOV ! expired
- dst 3 alien@ displacement' MOV ! displacement
+
+ ! Displacement is non-zero, we're going to be allocating a new
+ ! object
+ dst 5 cells alien temp %allot
+
+ ! Set expired to f
+ dst 2 alien@ \ f type-number MOV
+
+ ! Is base f?
+ base \ f type-number CMP
+ "not-f" get JNE
+
+ ! Yes, it is f. Fill in new object
+ dst 1 alien@ base MOV
+ dst 3 alien@ displacement MOV
+ dst 4 alien@ displacement MOV
+
+ "end" get JMP
+
+ "not-f" resolve-label
+
+ ! Check base type
+ temp base MOV
+ temp tag-mask get AND
+
+ ! Is base an alien?
+ temp alien type-number CMP
+ "not-alien" get JNE
+
+ ! Yes, it is an alien. Set new alien's base to base.base
+ temp base 1 alien@ MOV
+ dst 1 alien@ temp MOV
+
+ ! Compute displacement
+ temp base 3 alien@ MOV
+ temp displacement ADD
+ dst 3 alien@ temp MOV
+
+ ! Compute address
+ temp base 4 alien@ MOV
+ temp displacement ADD
+ dst 4 alien@ temp MOV
+
+ ! We are done
+ "end" get JMP
+
+ ! Is base a byte array? It has to be, by now...
+ "not-alien" resolve-label
+
+ dst 1 alien@ base MOV
+ dst 3 alien@ displacement MOV
+ temp base MOV
+ temp byte-array-offset ADD
+ temp displacement ADD
+ dst 4 alien@ temp MOV
+
"end" resolve-label
] with-scope ;
M: x86.32 has-small-reg?
{
- { 8 [ have-byte-regs memq? ] }
+ { 8 [ have-byte-regs member-eq? ] }
{ 16 [ drop t ] }
{ 32 [ drop t ] }
} case ;
: small-reg-that-isn't ( exclude -- reg' )
[ have-byte-regs ] dip
[ native-version-of ] map
- '[ _ memq? not ] find nip ;
+ '[ _ member-eq? not ] find nip ;
: with-save/restore ( reg quot -- )
[ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
M: x86 %set-alien-double [ [+] ] dip MOVSD ;
M: x86 %set-alien-vector [ [+] ] 2dip %copy ;
- : shift-count? ( reg -- ? ) { ECX RCX } memq? ;
+ : shift-count? ( reg -- ? ) { ECX RCX } member-eq? ;
:: emit-shift ( dst src quot -- )
src shift-count? [
[ drop "nursery" %vm-field-ptr ] [ swap [] MOV ] 2bi ;
: inc-allot-ptr ( nursery-ptr n -- )
- [ [] ] dip 8 align ADD ;
+ [ [] ] dip data-alignment get align ADD ;
: store-header ( temp class -- )
- [ [] ] [ type-number tag-fixnum ] bi* MOV ;
+ [ [] ] [ type-number tag-header ] bi* MOV ;
: store-tagged ( dst tag -- )
- tag-number OR ;
+ type-number OR ;
M:: x86 %allot ( dst size class nursery-ptr -- )
nursery-ptr dst load-allot-ptr
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
:: %boolean ( dst temp word -- )
- dst \ f tag-number MOV
+ dst \ f type-number MOV
temp 0 MOV \ t rc-absolute-cell rel-immediate
dst temp word execute ; inline
M: x86 %max-float double-rep two-operand MAXSD ;
M: x86 %sqrt SQRTSD ;
- M: x86 %single>double-float CVTSS2SD ;
- M: x86 %double>single-float CVTSD2SS ;
+ : %clear-unless-in-place ( dst src -- )
+ over = [ drop ] [ dup XORPS ] if ;
- M: x86 %integer>float CVTSI2SD ;
+ M: x86 %single>double-float [ %clear-unless-in-place ] [ CVTSS2SD ] 2bi ;
+ M: x86 %double>single-float [ %clear-unless-in-place ] [ CVTSD2SS ] 2bi ;
+
+ M: x86 %integer>float [ drop dup XORPS ] [ CVTSI2SD ] 2bi ;
M: x86 %float>integer CVTTSD2SI ;
: %cmov-float= ( dst src -- )
M: x86 %zero-vector
{
- { double-2-rep [ dup XORPD ] }
+ { double-2-rep [ dup XORPS ] }
{ float-4-rep [ dup XORPS ] }
[ drop dup PXOR ]
} case ;
M: x86 %fill-vector
{
- { double-2-rep [ dup [ XORPD ] [ CMPEQPD ] 2bi ] }
+ { double-2-rep [ dup [ XORPS ] [ CMPEQPS ] 2bi ] }
{ float-4-rep [ dup [ XORPS ] [ CMPEQPS ] 2bi ] }
[ drop dup PCMPEQB ]
} case ;
rep unsign-rep {
{ double-2-rep [
dst src1 double-2-rep %copy
- dst src2 UNPCKLPD
+ dst src2 MOVLHPS
] }
{ longlong-2-rep [
dst src1 longlong-2-rep %copy
{ sse2? { double-2-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
- : double-2-shuffle ( dst shuffle -- )
- {
- { { 0 1 } [ drop ] }
- { { 0 0 } [ dup UNPCKLPD ] }
- { { 1 1 } [ dup UNPCKHPD ] }
- [ dupd SHUFPD ]
- } case ;
-
: sse1-float-4-shuffle ( dst shuffle -- )
{
{ { 0 1 2 3 } [ drop ] }
: longlong-2-shuffle ( dst shuffle -- )
first2 [ 2 * dup 1 + ] bi@ 4array int-4-shuffle ;
+ : >float-4-shuffle ( double-2-shuffle -- float-4-shuffle )
+ [ 2 * { 0 1 } n+v ] map concat ;
+
M:: x86 %shuffle-vector-imm ( dst src shuffle rep -- )
dst src rep %copy
dst shuffle rep unsign-rep {
- { double-2-rep [ double-2-shuffle ] }
+ { double-2-rep [ >float-4-shuffle float-4-shuffle ] }
{ float-4-rep [ float-4-shuffle ] }
{ int-4-rep [ int-4-shuffle ] }
{ longlong-2-rep [ longlong-2-shuffle ] }
M: x86 %merge-vector-head
[ two-operand ] keep
unsign-rep {
- { double-2-rep [ UNPCKLPD ] }
+ { double-2-rep [ MOVLHPS ] }
{ float-4-rep [ UNPCKLPS ] }
{ longlong-2-rep [ PUNPCKLQDQ ] }
{ int-4-rep [ PUNPCKLDQ ] }
M: x86 %tail>head-vector ( dst src rep -- )
dup {
- { float-4-rep [ drop MOVHLPS ] }
- { double-2-rep [ [ %copy ] [ drop UNPCKHPD ] 3bi ] }
+ { float-4-rep [ drop UNPCKHPD ] }
+ { double-2-rep [ drop UNPCKHPD ] }
[ drop [ %copy ] [ drop PUNPCKHQDQ ] 3bi ]
} case ;
{
{ sse? { float-4-rep } }
{ sse2? { double-2-rep char-16-rep short-8-rep int-4-rep } }
- { sse4.1? { longlong-2-rep } }
+ { sse4.2? { longlong-2-rep } }
} available-reps ;
M: x86 %compare-vector-reps
{
- { [ dup { cc= cc/= } memq? ] [ drop %compare-vector-eq-reps ] }
+ { [ dup { cc= cc/= cc/<>= cc<>= } member-eq? ] [ drop %compare-vector-eq-reps ] }
[ drop %compare-vector-ord-reps ]
} cond ;
: %move-vector-mask ( dst src rep -- mask )
{
- { double-2-rep [ MOVMSKPD HEX: 3 ] }
+ { double-2-rep [ MOVMSKPS HEX: f ] }
{ float-4-rep [ MOVMSKPS HEX: f ] }
[ drop PMOVMSKB HEX: ffff ]
} case ;
M: x86 %min-vector-reps
{
{ sse? { float-4-rep } }
- { sse2? { uchar-16-rep short-8-rep double-2-rep short-8-rep uchar-16-rep } }
+ { sse2? { uchar-16-rep short-8-rep double-2-rep } }
{ sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
} available-reps ;
M: x86 %max-vector-reps
{
{ sse? { float-4-rep } }
- { sse2? { uchar-16-rep short-8-rep double-2-rep short-8-rep uchar-16-rep } }
+ { sse2? { uchar-16-rep short-8-rep double-2-rep } }
{ sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
} available-reps ;
{ sse3? { float-4-rep double-2-rep } }
} available-reps ;
- M: x86 %horizontal-shl-vector ( dst src1 src2 rep -- )
+ M: x86 %horizontal-shl-vector-imm ( dst src1 src2 rep -- )
two-operand PSLLDQ ;
- M: x86 %horizontal-shl-vector-reps
+ M: x86 %horizontal-shl-vector-imm-reps
{
{ sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
- M: x86 %horizontal-shr-vector ( dst src1 src2 rep -- )
+ M: x86 %horizontal-shr-vector-imm ( dst src1 src2 rep -- )
two-operand PSRLDQ ;
- M: x86 %horizontal-shr-vector-reps
+ M: x86 %horizontal-shr-vector-imm-reps
{
{ sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
[ two-operand ] keep
{
{ float-4-rep [ ANDPS ] }
- { double-2-rep [ ANDPD ] }
+ { double-2-rep [ ANDPS ] }
[ drop PAND ]
} case ;
[ two-operand ] keep
{
{ float-4-rep [ ANDNPS ] }
- { double-2-rep [ ANDNPD ] }
+ { double-2-rep [ ANDNPS ] }
[ drop PANDN ]
} case ;
[ two-operand ] keep
{
{ float-4-rep [ ORPS ] }
- { double-2-rep [ ORPD ] }
+ { double-2-rep [ ORPS ] }
[ drop POR ]
} case ;
[ two-operand ] keep
{
{ float-4-rep [ XORPS ] }
- { double-2-rep [ XORPD ] }
+ { double-2-rep [ XORPS ] }
[ drop PXOR ]
} case ;
{ sse2? { short-8-rep ushort-8-rep int-4-rep uint-4-rep ulonglong-2-rep } }
} available-reps ;
+ M: x86 %shl-vector-imm %shl-vector ;
+ M: x86 %shl-vector-imm-reps %shl-vector-reps ;
+ M: x86 %shr-vector-imm %shr-vector ;
+ M: x86 %shr-vector-imm-reps %shr-vector-reps ;
+
: scalar-sized-reg ( reg rep -- reg' )
rep-size 8 * n-bit-version-of ;
flush
1 exit
] when
- ] "cpu.x86" add-init-hook ;
+ ] "cpu.x86" add-startup-hook ;
: enable-sse2 ( version -- )
20 >= [
: reset-game-input ( -- )
(reset-game-input) ;
-[ reset-game-input ] "game-input" add-init-hook
+[ reset-game-input ] "game-input" add-startup-hook
PRIVATE>
get-controllers [ product-id = ] with filter ;
: find-controller-instance ( product-id instance-id -- controller/f )
get-controllers [
- tuck
[ product-id = ]
- [ instance-id = ] 2bi* and
+ [ instance-id = ] bi-curry bi* and
] with with find nip ;
TUPLE: keyboard-state keys ;
[
H{ } clone processes set-global
start-wait-thread
-] "io.launcher" add-init-hook
+] "io.launcher" add-startup-hook
: process-started ( process handle -- )
>>handle
V{ } clone swap processes get set-at
wait-flag get-global raise-flag ;
- M: process hashcode* handle>> hashcode* ;
-
: pass-environment? ( process -- ? )
dup environment>> assoc-empty? not
swap environment-mode>> +replace-environment+ eq? or ;
[ (io-error) ]
} cond ;
+ : ?bind-client ( socket -- )
+ bind-local-address get [ [ fd>> ] dip make-sockaddr/size bind io-error ] [ drop ] if* ; inline
+
M: object ((client)) ( addrspec -- fd )
- protocol-family SOCK_STREAM socket-fd dup init-client-socket ;
+ protocol-family SOCK_STREAM socket-fd
+ [ init-client-socket ] [ ?bind-client ] [ ] tri ;
! Server sockets - TCP and Unix domain
: init-server-socket ( fd -- )
CONSTANT: packet-size 65536
-[ packet-size malloc receive-buffer set-global ] "io.sockets.unix" add-init-hook
+[ packet-size malloc &free receive-buffer set-global ] "io.sockets.unix" add-startup-hook
:: do-receive ( port -- packet sockaddr )
- port addr>> empty-sockaddr/size :> len :> sockaddr
+ port addr>> empty-sockaddr/size :> ( sockaddr len )
port handle>> handle-fd ! s
receive-buffer get-global ! buf
packet-size ! nbytes
M: local empty-sockaddr drop sockaddr-un <struct> ;
M: local make-sockaddr
- path>> (normalize-path)
+ path>> absolute-path
dup length 1 + max-un-path > [ "Path too long" throw ] when
sockaddr-un <struct>
AF_UNIX >>family
[ quot-uses ] curry each ;
: seq-uses ( seq assoc -- )
- over visited get memq? [ 2drop ] [
+ over visited get member-eq? [ 2drop ] [
over visited get push
(seq-uses)
] if ;
: assoc-uses ( assoc' assoc -- )
- over visited get memq? [ 2drop ] [
+ over visited get member-eq? [ 2drop ] [
over visited get push
[ >alist ] dip (seq-uses)
] if ;
M: invalidate-crossref definitions-changed 2drop crossref global delete-at ;
-[ invalidate-crossref add-definition-observer ] "tools.crossref" add-init-hook
+[ invalidate-crossref add-definition-observer ] "tools.crossref" add-startup-hook
PRIVATE>
generic.single tools.deploy.config combinators classes
classes.builtin slots.private grouping command-line ;
QUALIFIED: bootstrap.stage2
+ QUALIFIED: compiler.crossref
QUALIFIED: compiler.errors
QUALIFIED: continuations
QUALIFIED: definitions
: add-command-line-hook ( -- )
[ (command-line) command-line set-global ] "command-line"
- init-hooks get set-at ;
+ startup-hooks get set-at ;
-: strip-init-hooks ( -- )
+: strip-startup-hooks ( -- )
"Stripping startup hooks" show
{
"alien.strings"
"environment"
"libc"
}
- [ init-hooks get delete-at ] each
+ [ startup-hooks get delete-at ] each
deploy-threads? get [
- "threads" init-hooks get delete-at
+ "threads" startup-hooks get delete-at
] unless
native-io? [
- "io.thread" init-hooks get delete-at
+ "io.thread" startup-hooks get delete-at
] unless
strip-io? [
- "io.files" init-hooks get delete-at
- "io.backend" init-hooks get delete-at
- "io.thread" init-hooks get delete-at
+ "io.files" startup-hooks get delete-at
+ "io.backend" startup-hooks get delete-at
+ "io.thread" startup-hooks get delete-at
] when
strip-dictionary? [
{
"vocabs"
"vocabs.cache"
"source-files.errors"
- } [ init-hooks get delete-at ] each
+ } [ startup-hooks get delete-at ] each
] when ;
: strip-debugger ( -- )
! otherwise do nothing
[ 2drop ]
} cond
- ] change-each ;
+ ] map! drop ;
: strip-default-method ( generic new-default -- )
[
continuations:error-continuation
continuations:error-thread
continuations:restarts
- init:init-hooks
+ init:startup-hooks
source-files:source-files
input-stream
output-stream
implementors-map
update-map
main-vocab-hook
- compiled-crossref
- compiled-generic-crossref
+ compiler.crossref:compiled-crossref
+ compiler.crossref:compiled-generic-crossref
compiler-impl
compiler.errors:compiler-errors
lexer-factory
: deploy-boot-quot ( word -- )
[
[ boot ] %
- init-hooks get values concat %
+ startup-hooks get values concat %
strip-debugger? [ , ] [
! Don't reference 'try' directly since we don't want
! to pull in the debugger and prettyprinter into every
] [ ] make
set-boot-quot ;
-: init-stripper ( -- )
+: startup-stripper ( -- )
t "quiet" set-global
f output-stream set-global ;
next-method ;
: calls-next-method? ( method -- ? )
- def>> flatten \ (call-next-method) swap memq? ;
+ def>> flatten \ (call-next-method) swap member-eq? ;
: compute-next-methods ( -- )
[ standard-generic? ] instances [
[ clear-megamorphic-cache ] each ;
: strip ( -- )
- init-stripper
+ startup-stripper
strip-libc
strip-destructors
strip-call
strip-debugger
strip-specialized-arrays
compute-next-methods
- strip-init-hooks
+ strip-startup-hooks
add-command-line-hook
strip-c-io
strip-default-methods
M:: cocoa-ui-backend (open-window) ( world -- )
world [ [ dim>> ] dip <FactorView> ]
with-world-pixel-format :> view
- world window-controls>> textured-background swap memq?
+ world window-controls>> textured-background swap member-eq?
[ view make-context-transparent ] when
view world [ world>NSRect ] [ world>styleMask ] bi <ViewWindow> :> window
view -> release
{ +name+ "FactorApplicationDelegate" }
}
- { "applicationDidUpdate:" "void" { "id" "SEL" "id" }
+ { "applicationDidUpdate:" void { id SEL id }
[ 3drop reset-run-loop ]
} ;
: install-app-delegate ( -- )
NSApp FactorApplicationDelegate install-delegate ;
-SYMBOL: cocoa-init-hook
+SYMBOL: cocoa-startup-hook
-cocoa-init-hook [
+cocoa-startup-hook [
[ "MiniFactor.nib" load-nib install-app-delegate ]
] initialize
"UI" assert.app [
[
init-clipboard
- cocoa-init-hook get call( -- )
+ cocoa-startup-hook get call( -- )
start-ui
f io-thread-running? set-global
init-thread-timer
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax cocoa cocoa.nibs cocoa.application
- cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.subclassing
- core-foundation core-foundation.strings help.topics kernel
- memory namespaces parser system ui ui.tools.browser
- ui.tools.listener ui.backend.cocoa eval locals
- vocabs.refresh ;
+ cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.runtime
+ cocoa.subclassing core-foundation core-foundation.strings
+ help.topics kernel memory namespaces parser system ui
+ ui.tools.browser ui.tools.listener ui.backend.cocoa eval
+ locals vocabs.refresh ;
+ FROM: alien.c-types => int void ;
IN: ui.backend.cocoa.tools
: finder-run-files ( alien -- )
{ +name+ "FactorWorkspaceApplicationDelegate" }
}
- { "application:openFiles:" "void" { "id" "SEL" "id" "id" }
+ { "application:openFiles:" void { id SEL id id }
[ [ 3drop ] dip finder-run-files ]
}
- { "applicationShouldHandleReopen:hasVisibleWindows:" "int" { "id" "SEL" "id" "int" }
+ { "applicationShouldHandleReopen:hasVisibleWindows:" int { id SEL id int }
[ [ 3drop ] dip 0 = [ show-listener ] when 1 ]
}
- { "factorListener:" "id" { "id" "SEL" "id" }
+ { "factorListener:" id { id SEL id }
[ 3drop show-listener f ]
}
- { "factorBrowser:" "id" { "id" "SEL" "id" }
+ { "factorBrowser:" id { id SEL id }
[ 3drop show-browser f ]
}
- { "newFactorListener:" "id" { "id" "SEL" "id" }
+ { "newFactorListener:" id { id SEL id }
[ 3drop listener-window f ]
}
- { "newFactorBrowser:" "id" { "id" "SEL" "id" }
+ { "newFactorBrowser:" id { id SEL id }
[ 3drop browser-window f ]
}
- { "runFactorFile:" "id" { "id" "SEL" "id" }
+ { "runFactorFile:" id { id SEL id }
[ 3drop menu-run-files f ]
}
- { "saveFactorImage:" "id" { "id" "SEL" "id" }
+ { "saveFactorImage:" id { id SEL id }
[ 3drop save f ]
}
- { "saveFactorImageAs:" "id" { "id" "SEL" "id" }
+ { "saveFactorImageAs:" id { id SEL id }
[ 3drop menu-save-image f ]
}
- { "refreshAll:" "id" { "id" "SEL" "id" }
+ { "refreshAll:" id { id SEL id }
[ 3drop [ refresh-all ] \ refresh-all call-listener f ]
} ;
{ +name+ "FactorServiceProvider" }
} {
"evalInListener:userData:error:"
- "void"
- { "id" "SEL" "id" "id" "id" }
+ void
+ { id SEL id id id }
[ nip [ eval-listener f ] do-service 2drop ]
} {
"evalToString:userData:error:"
- "void"
- { "id" "SEL" "id" "id" "id" }
+ void
+ { id SEL id id id }
[ nip [ eval>string ] do-service 2drop ]
} ;
install-app-delegate
"Factor.nib" load-nib
register-services
-] cocoa-init-hook set-global
+] cocoa-startup-hook set-global
: raised-window ( world -- )
windows get-global
[ [ second eq? ] with find drop ] keep
- [ nth ] [ delete-nth ] [ nip ] 2tri push ;
+ [ nth ] [ remove-nth! drop ] [ nip ] 2tri push ;
: focus-gestures ( new old -- )
drop-prefix <reversed>
[
f \ ui-running set-global
<flag> ui-notify-flag set-global
-] "ui" add-init-hook
+] "ui" add-startup-hook
: with-ui ( quot -- )
ui-running? [ call( -- ) ] [ '[ init-ui @ ] (with-ui) ] if ;
dup callbacks>> (callbacks>vtbls) >>vtbls
f >>disposed drop ;
-: (init-hook) ( -- )
+: com-startup-hook ( -- )
+live-wrappers+ get-global [ (allocate-wrapper) ] each
H{ } +wrapped-objects+ set-global ;
-[ (init-hook) ] "windows.com.wrapper" add-init-hook
+[ com-startup-hook ] "windows.com.wrapper" add-startup-hook
PRIVATE>
M: com-wrapper dispose*
[ [ free ] each f ] change-vtbls
- +live-wrappers+ get-global delete ;
+ +live-wrappers+ get-global remove! drop ;
: com-wrap ( object wrapper -- wrapped-object )
[ vtbls>> ] [ (malloc-wrapped-object) ] bi
DIOBJECTDATAFORMAT <struct-boa> ;
:: make-DIOBJECTDATAFORMAT-array ( struct array -- alien )
- [let | alien [ array length malloc-DIOBJECTDATAFORMAT-array ] |
- array [| args i |
- struct args <DIOBJECTDATAFORMAT>
- i alien set-nth
- ] each-index
- alien
- ] ;
+ array length malloc-DIOBJECTDATAFORMAT-array :> alien
+ array [| args i |
+ struct args <DIOBJECTDATAFORMAT>
+ i alien set-nth
+ ] each-index
+ alien ;
: <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien )
[ DIDATAFORMAT heap-size DIOBJECTDATAFORMAT heap-size ] 4 ndip
define-guid-constants
define-format-constants ;
-[ define-constants ] "windows.dinput.constants" add-init-hook
+[ define-constants ] "windows.dinput.constants" add-startup-hook
: uninitialize ( variable quot -- )
'[ _ when* f ] change-global ; inline
kernel.private byte-arrays arrays init ;
IN: alien
- ! Some predicate classes used by the compiler for optimization
- ! purposes
- PREDICATE: simple-alien < alien underlying>> not ;
+ PREDICATE: pinned-alien < alien underlying>> not ;
- UNION: simple-c-ptr
- simple-alien POSTPONE: f byte-array ;
-
- DEFER: pinned-c-ptr?
-
- PREDICATE: pinned-alien < alien underlying>> pinned-c-ptr? ;
-
- UNION: pinned-c-ptr
- pinned-alien POSTPONE: f ;
+ UNION: pinned-c-ptr pinned-alien POSTPONE: f ;
GENERIC: >c-ptr ( obj -- c-ptr )
M: f expired? drop t ;
: <alien> ( address -- alien )
- f <displaced-alien> { simple-c-ptr } declare ; inline
+ f <displaced-alien> { pinned-c-ptr } declare ; inline
: <bad-alien> ( -- alien )
-1 <alien> t >>expired ; inline
2drop f
] if ;
- M: simple-alien hashcode* nip dup expired>> [ drop 1234 ] [ alien-address ] if ;
+ M: pinned-alien hashcode*
+ nip dup expired>> [ drop 1234 ] [ alien-address ] if ;
ERROR: alien-callback-error ;
! cleared on startup.
SYMBOL: callbacks
-[ H{ } clone callbacks set-global ] "alien" add-init-hook
+[ H{ } clone callbacks set-global ] "alien" add-startup-hook
<PRIVATE
ERROR: invalid-c-string string ;
: check-string ( string -- )
- 0 over memq? [ invalid-c-string ] [ drop ] if ;
+ 0 over member-eq? [ invalid-c-string ] [ drop ] if ;
GENERIC# string>alien 1 ( string encoding -- byte-array )
[
8 getenv utf8 alien>string string>cpu \ cpu set-global
9 getenv utf8 alien>string string>os \ os set-global
-] "alien.strings" add-init-hook
-
+] "alien.strings" add-startup-hook
"vocab:bootstrap/syntax.factor" parse-file
- "vocab:cpu/" architecture get {
+ architecture get {
{ "x86.32" "x86/32" }
{ "winnt-x86.64" "x86/64/winnt" }
{ "unix-x86.64" "x86/64/unix" }
{ "macosx-ppc" "ppc/macosx" }
{ "arm" "arm" }
} ?at [ "Bad architecture: " prepend throw ] unless
- "/bootstrap.factor" 3append parse-file
+ "vocab:cpu/" "/bootstrap.factor" surround parse-file
"vocab:bootstrap/layouts/layouts.factor" parse-file
bootstrapping? on
+ [
+
! Create some empty vocabs where the below primitives and
! classes will go
{
"system"
"system.private"
"threads.private"
+ "tools.dispatch.private"
"tools.profiler.private"
"words"
"words.private"
"object?" "kernel" vocab-words delete-at
- ! Class of objects with object tag
- "hi-tag" "kernel.private" create
- builtins get num-tags get tail define-union-class
-
! Empty class with no instances
"null" "kernel" create
[ f { } f union-class define-class ]
{ "swapd" "kernel" (( x y z -- y x z )) }
{ "nip" "kernel" (( x y -- y )) }
{ "2nip" "kernel" (( x y z -- z )) }
- { "tuck" "kernel" (( x y -- y x y )) }
{ "over" "kernel" (( x y -- x y x )) }
{ "pick" "kernel" (( x y z -- x y z x )) }
{ "swap" "kernel" (( x y -- y x )) }
{ "minor-gc" "memory" (( -- )) }
{ "gc" "memory" (( -- )) }
{ "compact-gc" "memory" (( -- )) }
- { "gc-stats" "memory" f }
{ "(save-image)" "memory.private" (( path -- )) }
{ "(save-image-and-exit)" "memory.private" (( path -- )) }
{ "datastack" "kernel" (( -- ds )) }
{ "set-datastack" "kernel" (( ds -- )) }
{ "set-retainstack" "kernel" (( rs -- )) }
{ "set-callstack" "kernel" (( cs -- )) }
- { "exit" "system" (( n -- )) }
+ { "(exit)" "system" (( n -- )) }
- { "data-room" "memory" (( -- cards decks generations )) }
- { "code-room" "memory" (( -- code-total code-used code-free largest-free-block )) }
+ { "data-room" "memory" (( -- data-room )) }
+ { "code-room" "memory" (( -- code-room )) }
{ "micros" "system" (( -- us )) }
{ "modify-code-heap" "compiler.units" (( alist -- )) }
{ "(dlopen)" "alien.libraries" (( path -- dll )) }
{ "resize-array" "arrays" (( n array -- newarray )) }
{ "resize-string" "strings" (( n str -- newstr )) }
{ "<array>" "arrays" (( n elt -- array )) }
- { "begin-scan" "memory" (( -- )) }
- { "next-object" "memory" (( -- obj )) }
- { "end-scan" "memory" (( -- )) }
+ { "all-instances" "memory" (( -- array )) }
{ "size" "memory" (( obj -- n )) }
{ "die" "kernel" (( -- )) }
{ "(fopen)" "io.streams.c" (( path mode -- alien )) }
{ "resize-byte-array" "byte-arrays" (( n byte-array -- newbyte-array )) }
{ "dll-valid?" "alien.libraries" (( dll -- ? )) }
{ "unimplemented" "kernel.private" (( -- * )) }
- { "gc-reset" "memory" (( -- )) }
{ "jit-compile" "quotations" (( quot -- )) }
{ "load-locals" "locals.backend" (( ... n -- )) }
{ "check-datastack" "kernel.private" (( array in# out# -- ? )) }
{ "inline-cache-miss-tail" "generic.single.private" (( generic methods index cache -- )) }
{ "mega-cache-miss" "generic.single.private" (( methods index cache -- method )) }
{ "lookup-method" "generic.single.private" (( object methods -- method )) }
- { "reset-dispatch-stats" "generic.single" (( -- )) }
- { "dispatch-stats" "generic.single" (( -- stats )) }
- { "reset-inline-cache-stats" "generic.single" (( -- )) }
- { "inline-cache-stats" "generic.single" (( -- stats )) }
+ { "reset-dispatch-stats" "tools.dispatch.private" (( -- )) }
+ { "dispatch-stats" "tools.dispatch.private" (( -- stats )) }
{ "optimized?" "words" (( word -- ? )) }
{ "quot-compiled?" "quotations" (( quot -- ? )) }
{ "vm-ptr" "vm" (( -- ptr )) }
{ "strip-stack-traces" "kernel.private" (( -- )) }
{ "<callback>" "alien" (( word -- alien )) }
+ { "enable-gc-events" "memory" (( -- )) }
+ { "disable-gc-events" "memory" (( -- events )) }
+ { "(identity-hashcode)" "kernel.private" (( obj -- code )) }
+ { "compute-identity-hashcode" "kernel.private" (( obj -- )) }
} [ [ first3 ] dip swap make-primitive ] each-index
! Bump build number
"build" "kernel" create build 1 + [ ] curry (( -- n )) define-declared
+
+ ] with-compilation-unit
USING: arrays assocs continuations debugger generic hashtables
init io io.files kernel kernel.private make math memory
namespaces parser prettyprint sequences splitting system
-vectors vocabs vocabs.loader words ;
+vectors vocabs vocabs.loader words destructors ;
QUALIFIED: bootstrap.image.private
IN: bootstrap.stage1
load-help? off
{ "resource:core" } vocab-roots set
- ! Create a boot quotation for the target
+ ! Create a boot quotation for the target by collecting all top-level
+ ! forms into a quotation, surrounded by some boilerplate.
[
[
- ! Rehash hashtables, since bootstrap.image creates them
- ! using the host image's hashing algorithms. We don't
- ! use each-object here since the catch stack isn't yet
- ! set up.
- gc
- begin-scan
- [ hashtable? ] pusher [ (each-object) ] dip
- end-scan
- [ rehash ] each
+ ! Rehash hashtables first, since bootstrap.image creates
+ ! them using the host image's hashing algorithms.
+ [ hashtable? ] instances [ rehash ] each
boot
] %
"math.integers" require
"math.floats" require
"memory" require
-
+
"io.streams.c" require
"vocabs.loader" require
-
+
"syntax" require
"bootstrap.layouts" require
[
"resource:basis/bootstrap/stage2.factor"
dup exists? [
- run-file
+ [ run-file ] with-destructors
] [
"Cannot find " write write "." print
"Please move " write image write " to the same directory as the Factor sources," print
"and try again." print
- 1 exit
+ 1 (exit)
] if
] %
] [ ] make
USING: accessors arrays kernel continuations assocs namespaces
sequences words vocabs definitions hashtables init sets
math math.order classes classes.algebra classes.tuple
- classes.tuple.private generic source-files.errors ;
+ classes.tuple.private generic source-files.errors
+ kernel.private ;
IN: compiler.units
SYMBOL: old-definitions
\ redefine-error boa
{ { "Continue" t } } throw-restarts drop ;
+ <PRIVATE
+
: add-once ( key assoc -- )
2dup key? [ over redefine-error ] when conjoin ;
: (remember-definition) ( definition loc assoc -- )
[ over set-where ] dip add-once ;
+ PRIVATE>
+
: remember-definition ( definition loc -- )
new-definitions get first (remember-definition) ;
HOOK: recompile compiler-impl ( words -- alist )
+ HOOK: to-recompile compiler-impl ( -- words )
+
+ HOOK: process-forgotten-words compiler-impl ( words -- )
+
+ : compile ( words -- ) recompile modify-code-heap ;
+
! Non-optimizing compiler
- M: f recompile [ dup def>> ] { } map>assoc ;
+ M: f recompile
+ [ dup def>> ] { } map>assoc ;
+
+ M: f to-recompile
+ changed-definitions get [ drop word? ] assoc-filter
+ changed-generics get assoc-union keys ;
+
+ M: f process-forgotten-words drop ;
: without-optimizer ( quot -- )
[ f compiler-impl ] dip with-variable ; inline
! during stage1 bootstrap, it would just waste time.
SINGLETON: dummy-compiler
+ M: dummy-compiler to-recompile f ;
+
M: dummy-compiler recompile drop { } ;
+ M: dummy-compiler process-forgotten-words drop ;
+
: <definitions> ( -- pair ) { H{ } H{ } } [ clone ] map ;
SYMBOL: definition-observers
GENERIC: definitions-changed ( assoc obj -- )
[ V{ } clone definition-observers set-global ]
-"compiler.units" add-init-hook
+"compiler.units" add-startup-hook
! This goes here because vocabs cannot depend on init
[ V{ } clone vocab-observers set-global ]
-"vocabs" add-init-hook
+"vocabs" add-startup-hook
: add-definition-observer ( obj -- )
definition-observers get push ;
: remove-definition-observer ( obj -- )
- definition-observers get delq ;
+ definition-observers get remove-eq! drop ;
: notify-definition-observers ( assoc -- )
definition-observers get
[ definitions-changed ] with each ;
+ ! Incremented each time stack effects potentially changed, used
+ ! by compiler.tree.propagation.call-effect for call( and execute(
+ ! inline caching
+ : effect-counter ( -- n ) 46 getenv ; inline
+
+ GENERIC: bump-effect-counter* ( defspec -- ? )
+
+ M: object bump-effect-counter* drop f ;
+
+ <PRIVATE
+
: changed-vocabs ( assoc -- vocabs )
[ drop word? ] assoc-filter
[ drop vocabulary>> dup [ vocab ] when dup ] assoc-map ;
dup changed-definitions get update
dup dup changed-vocabs update ;
- : compile ( words -- ) recompile modify-code-heap ;
-
- : index>= ( obj1 obj2 seq -- ? )
- [ index ] curry bi@ >= ;
-
- : dependency>= ( how1 how2 -- ? )
- { called-dependency flushed-dependency inlined-dependency }
- index>= ;
-
- : strongest-dependency ( how1 how2 -- how )
- [ called-dependency or ] bi@ [ dependency>= ] most ;
-
- : weakest-dependency ( how1 how2 -- how )
- [ inlined-dependency or ] bi@ [ dependency>= not ] most ;
-
- : compiled-usage ( word -- assoc )
- compiled-crossref get at ;
-
- : (compiled-usages) ( word -- assoc )
- #! If the word is not flushable anymore, we have to recompile
- #! all words which flushable away a call (presumably when the
- #! word was still flushable). If the word is flushable, we
- #! don't have to recompile words that folded this away.
- [ compiled-usage ]
- [ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi
- [ dependency>= nip ] curry assoc-filter ;
-
- : compiled-usages ( assoc -- assocs )
- [ drop word? ] assoc-filter
- [ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ;
-
- : compiled-generic-usage ( word -- assoc )
- compiled-generic-crossref get at ;
-
- : (compiled-generic-usages) ( generic class -- assoc )
- [ compiled-generic-usage ] dip
- [
- 2dup [ valid-class? ] both?
- [ classes-intersect? ] [ 2drop f ] if nip
- ] curry assoc-filter ;
-
- : compiled-generic-usages ( assoc -- assocs )
- [ (compiled-generic-usages) ] { } assoc>map ;
-
- : words-only ( assoc -- assoc' )
- [ drop word? ] assoc-filter ;
-
- : to-recompile ( -- seq )
- changed-definitions get compiled-usages
- changed-generics get compiled-generic-usages
- append assoc-combine keys ;
-
: process-forgotten-definitions ( -- )
forgotten-definitions get keys
- [ [ word? ] filter [ delete-compiled-xref ] each ]
+ [ [ word? ] filter process-forgotten-words ]
[ [ delete-definition-errors ] each ]
bi ;
+ : bump-effect-counter? ( -- ? )
+ changed-effects get new-words get assoc-diff assoc-empty? not
+ changed-definitions get [ drop bump-effect-counter* ] assoc-any?
+ or ;
+
+ : bump-effect-counter ( -- )
+ bump-effect-counter? [ 46 getenv 0 or 1 + 46 setenv ] when ;
+
+ : notify-observers ( -- )
+ updated-definitions dup assoc-empty?
+ [ drop ] [ notify-definition-observers notify-error-observers ] if ;
+
: finish-compilation-unit ( -- )
remake-generics
to-recompile recompile
update-tuples
process-forgotten-definitions
modify-code-heap
- updated-definitions dup assoc-empty?
- [ drop ] [ notify-definition-observers notify-error-observers ] if ;
+ bump-effect-counter
+ notify-observers ;
+
+ PRIVATE>
: with-nested-compilation-unit ( quot -- )
[
H{ } clone changed-effects set
H{ } clone outdated-generics set
H{ } clone outdated-tuples set
+ H{ } clone new-words set
H{ } clone new-classes set
[ finish-compilation-unit ] [ ] cleanup
] with-scope ; inline
H{ } clone outdated-generics set
H{ } clone forgotten-definitions set
H{ } clone outdated-tuples set
+ H{ } clone new-words set
H{ } clone new-classes set
<definitions> new-definitions set
<definitions> old-definitions set
SYMBOL: disposables
-[ H{ } clone disposables set-global ] "destructors" add-init-hook
+[ H{ } clone disposables set-global ] "destructors" add-startup-hook
ERROR: already-unregistered disposable ;
PRIVATE>
TUPLE: disposable < identity-tuple
- { id integer }
{ disposed boolean }
continuation ;
- M: disposable hashcode* nip id>> ;
-
: new-disposable ( class -- disposable )
- new \ disposable counter >>id
- dup register-disposable ; inline
+ new dup register-disposable ; inline
GENERIC: dispose* ( disposable -- )
[ do-error-destructors ]
cleanup
] with-scope ; inline
+
+[
+ always-destructors get-global
+ error-destructors get-global append dispose-each
+] "destructors.global" add-shutdown-hook
M: source-file-error error-file [ error>> error-file ] [ file>> ] bi or ;
M: source-file-error error-line [ error>> error-line ] [ line#>> ] bi or ;
+ M: source-file-error compute-restarts error>> compute-restarts ;
: sort-errors ( errors -- alist )
[ [ line#>> ] sort-with ] { } assoc-map-as sort-keys ;
SYMBOL: error-observers
-[ V{ } clone error-observers set-global ] "source-files.errors" add-init-hook
+[ V{ } clone error-observers set-global ] "source-files.errors" add-startup-hook
: add-error-observer ( observer -- ) error-observers get push ;
- : remove-error-observer ( observer -- ) error-observers get delq ;
+ : remove-error-observer ( observer -- ) error-observers get remove-eq! drop ;
: notify-error-observers ( -- ) error-observers get [ errors-changed ] each ;
[
[ swap file>> = ] [ swap error-type = ]
bi-curry* bi and not
- ] 2curry filter-here
+ ] 2curry filter! drop
notify-error-observers ;
: delete-definition-errors ( definition -- )
{
factor_vm *vm;
- unordered_map<THREADHANDLE, factor_vm*> thread_vms;
+ std::map<THREADHANDLE, factor_vm*> thread_vms;
void init_globals()
{
{
p->image_path = NULL;
- /* We make a wild guess here that if we're running on ARM, we don't
- have a lot of memory. */
- #ifdef FACTOR_ARM
- p->ds_size = 8 * sizeof(cell);
- p->rs_size = 8 * sizeof(cell);
-
- p->code_size = 4;
- p->young_size = 1;
- p->aging_size = 1;
- p->tenured_size = 6;
- #else
p->ds_size = 32 * sizeof(cell);
p->rs_size = 32 * sizeof(cell);
p->code_size = 8 * sizeof(cell);
p->young_size = sizeof(cell) / 4;
p->aging_size = sizeof(cell) / 2;
- p->tenured_size = 4 * sizeof(cell);
- #endif
+ p->tenured_size = 24 * sizeof(cell);
p->max_pic_size = 3;
- p->secure_gc = false;
p->fep = false;
p->signals = true;
else if(factor_arg(arg,STRING_LITERAL("-codeheap=%d"),&p->code_size));
else if(factor_arg(arg,STRING_LITERAL("-pic=%d"),&p->max_pic_size));
else if(factor_arg(arg,STRING_LITERAL("-callbacks=%d"),&p->callback_size));
- else if(STRCMP(arg,STRING_LITERAL("-securegc")) == 0) p->secure_gc = true;
else if(STRCMP(arg,STRING_LITERAL("-fep")) == 0) p->fep = true;
else if(STRCMP(arg,STRING_LITERAL("-nosignals")) == 0) p->signals = false;
else if(STRNCMP(arg,STRING_LITERAL("-i="),3) == 0) p->image_path = arg + 3;
/* Do some initialization that we do once only */
void factor_vm::do_stage1_init()
{
- print_string("*** Stage 2 early init... ");
+ std::cout << "*** Stage 2 early init... ";
fflush(stdout);
compile_all_words();
- userenv[STAGE2_ENV] = true_object;
+ update_code_heap_words();
+ special_objects[OBJ_STAGE2] = true_object;
- print_string("done\n");
- fflush(stdout);
+ std::cout << "done\n";
}
void factor_vm::init_factor(vm_parameters *p)
init_profiler();
- userenv[CPU_ENV] = allot_alien(false_object,(cell)FACTOR_CPU_STRING);
- userenv[OS_ENV] = allot_alien(false_object,(cell)FACTOR_OS_STRING);
- userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(cell));
- userenv[EXECUTABLE_ENV] = allot_alien(false_object,(cell)p->executable_path);
- userenv[ARGS_ENV] = false_object;
- userenv[EMBEDDED_ENV] = false_object;
+ special_objects[OBJ_CPU] = allot_alien(false_object,(cell)FACTOR_CPU_STRING);
+ special_objects[OBJ_OS] = allot_alien(false_object,(cell)FACTOR_OS_STRING);
+ special_objects[OBJ_CELL_SIZE] = tag_fixnum(sizeof(cell));
+ special_objects[OBJ_EXECUTABLE] = allot_alien(false_object,(cell)p->executable_path);
+ special_objects[OBJ_ARGS] = false_object;
+ special_objects[OBJ_EMBEDDED] = false_object;
/* We can GC now */
gc_off = false;
- if(!to_boolean(userenv[STAGE2_ENV]))
+ if(!to_boolean(special_objects[OBJ_STAGE2]))
do_stage1_init();
}
}
args.trim();
- userenv[ARGS_ENV] = args.elements.value();
+ special_objects[OBJ_ARGS] = args.elements.value();
}
void factor_vm::start_factor(vm_parameters *p)
if(p->fep) factorbug();
nest_stacks(NULL);
- c_to_factor_toplevel(userenv[BOOT_ENV]);
+ c_to_factor_toplevel(special_objects[OBJ_BOOT]);
unnest_stacks();
}
+void factor_vm::stop_factor()
+{
+ nest_stacks(NULL);
+ c_to_factor_toplevel(userenv[SHUTDOWN_ENV]);
+ unnest_stacks();
+}
+
char *factor_vm::factor_eval_string(char *string)
{
- char *(*callback)(char *) = (char *(*)(char *))alien_offset(userenv[EVAL_CALLBACK_ENV]);
+ char *(*callback)(char *) = (char *(*)(char *))alien_offset(special_objects[OBJ_EVAL_CALLBACK]);
return callback(string);
}
void factor_vm::factor_yield()
{
- void (*callback)() = (void (*)())alien_offset(userenv[YIELD_CALLBACK_ENV]);
+ void (*callback)() = (void (*)())alien_offset(special_objects[OBJ_YIELD_CALLBACK]);
callback();
}
void factor_vm::factor_sleep(long us)
{
- void (*callback)(long) = (void (*)(long))alien_offset(userenv[SLEEP_CALLBACK_ENV]);
+ void (*callback)(long) = (void (*)(long))alien_offset(special_objects[OBJ_SLEEP_CALLBACK]);
callback(us);
}
{
struct growable_array;
+ struct code_root;
struct factor_vm
{
context *ctx;
/* New objects are allocated here */
- zone nursery;
+ nursery_space nursery;
/* Add this to a shifted address to compute write barrier offsets */
cell cards_offset;
cell decks_offset;
/* TAGGED user environment data; see getenv/setenv prims */
- cell userenv[USER_ENV];
+ cell special_objects[special_object_count];
/* Data stack and retain stack sizes */
cell ds_size, rs_size;
unsigned int signal_fpu_status;
stack_frame *signal_callstack_top;
- /* Zeroes out deallocated memory; set by the -securegc command line argument */
- bool secure_gc;
-
- /* A heap walk allows useful things to be done, like finding all
- references to an object for debugging purposes. */
- cell heap_scan_ptr;
-
/* GC is off during heap walking */
bool gc_off;
/* Only set if we're performing a GC */
gc_state *current_gc;
- /* Statistics */
- gc_statistics gc_stats;
+ /* If not NULL, we push GC events here */
+ std::vector<gc_event> *gc_events;
/* If a runtime function needs to call another function which potentially
- allocates memory, it must wrap any local variable references to Factor
- objects in gc_root instances */
- std::vector<cell> gc_locals;
- std::vector<cell> gc_bignums;
+ allocates memory, it must wrap any references to the data and code
+ heaps with data_root and code_root smart pointers, which register
+ themselves here. See data_roots.hpp and code_roots.hpp */
+ std::vector<data_root_range> data_roots;
+ std::vector<cell> bignum_roots;
+ std::vector<code_root *> code_roots;
/* Debugger */
bool fep_disabled;
cell bignum_neg_one;
/* Method dispatch statistics */
- cell megamorphic_cache_hits;
- cell megamorphic_cache_misses;
-
- cell cold_call_to_ic_transitions;
- cell ic_to_pic_transitions;
- cell pic_to_mega_transitions;
- /* Indexed by PIC_TAG, PIC_HI_TAG, PIC_TUPLE, PIC_HI_TAG_TUPLE */
- cell pic_counts[4];
+ dispatch_statistics dispatch_stats;
/* Number of entries in a polymorphic inline cache */
cell max_pic_size;
+ /* Incrementing object counter for identity hashing */
+ cell object_counter;
+
// contexts
void reset_datastack();
void reset_retainstack();
void primitive_set_datastack();
void primitive_set_retainstack();
void primitive_check_datastack();
+ void primitive_load_locals();
template<typename Iterator> void iterate_active_frames(Iterator &iter)
{
}
// run
- void primitive_getenv();
- void primitive_setenv();
void primitive_exit();
void primitive_micros();
void primitive_sleep();
void primitive_set_slot();
- void primitive_load_locals();
+
+ // objects
+ void primitive_special_object();
+ void primitive_set_special_object();
+ void primitive_identity_hashcode();
+ void compute_identity_hashcode(object *obj);
+ void primitive_compute_identity_hashcode();
+ cell object_size(cell tagged);
cell clone_object(cell obj_);
void primitive_clone();
+ void primitive_become();
// profiler
void init_profiler();
//data heap
void init_card_decks();
- void clear_cards(old_space *gen);
- void clear_decks(old_space *gen);
- void reset_generation(old_space *gen);
void set_data_heap(data_heap *data_);
- void init_data_heap(cell young_size, cell aging_size, cell tenured_size, bool secure_gc_);
- cell untagged_object_size(object *pointer);
- cell unaligned_object_size(object *pointer);
+ void init_data_heap(cell young_size, cell aging_size, cell tenured_size);
void primitive_size();
- cell binary_payload_start(object *pointer);
+ data_heap_room data_room();
void primitive_data_room();
void begin_scan();
void end_scan();
- void primitive_begin_scan();
- cell next_object();
- void primitive_next_object();
- void primitive_end_scan();
- template<typename Iterator> void each_object(Iterator &iterator);
+ cell instances(cell type);
+ void primitive_all_instances();
cell find_all_words();
- cell object_size(cell tagged);
+
+ template<typename Generation, typename Iterator>
+ inline void each_object(Generation *gen, Iterator &iterator)
+ {
+ cell obj = gen->first_object();
+ while(obj)
+ {
+ iterator((object *)obj);
+ obj = gen->next_object_after(obj);
+ }
+ }
+
+ template<typename Iterator> inline void each_object(Iterator &iterator)
+ {
+ gc_off = true;
+
+ each_object(data->tenured,iterator);
+ each_object(data->aging,iterator);
+ each_object(data->nursery,iterator);
+
+ gc_off = false;
+ }
/* the write barrier must be called any time we are potentially storing a
pointer from an older generation to a younger one */
*(char *)(decks_offset + ((cell)slot_ptr >> deck_bits)) = card_mark_mask;
}
+ inline void write_barrier(object *obj, cell size)
+ {
+ cell start = (cell)obj & -card_size;
+ cell end = ((cell)obj + size + card_size - 1) & -card_size;
+
+ for(cell offset = start; offset < end; offset += card_size)
+ write_barrier((cell *)offset);
+ }
+
+ // data heap checker
+ void check_data_heap();
+
// gc
+ void end_gc();
+ void start_gc_again();
void update_code_heap_for_minor_gc(std::set<code_block *> *remembered_set);
void collect_nursery();
void collect_aging();
void collect_to_tenured();
- void collect_full_impl(bool trace_contexts_p);
- void collect_growing_heap(cell requested_bytes, bool trace_contexts_p, bool compact_code_heap_p);
- void collect_full(bool trace_contexts_p, bool compact_code_heap_p);
- void record_gc_stats(generation_statistics *stats);
- void gc(gc_op op, cell requested_bytes, bool trace_contexts_p, bool compact_code_heap_p);
+ void update_code_roots_for_sweep();
+ void update_code_roots_for_compaction();
+ void collect_mark_impl(bool trace_contexts_p);
+ void collect_sweep_impl();
+ void collect_full(bool trace_contexts_p);
+ void collect_compact_impl(bool trace_contexts_p);
+ void collect_compact_code_impl(bool trace_contexts_p);
+ void collect_compact(bool trace_contexts_p);
+ void collect_growing_heap(cell requested_bytes, bool trace_contexts_p);
+ void gc(gc_op op, cell requested_bytes, bool trace_contexts_p);
void primitive_minor_gc();
void primitive_full_gc();
void primitive_compact_gc();
- void primitive_gc_stats();
- void clear_gc_stats();
- void primitive_become();
- void inline_gc(cell *gc_roots_base, cell gc_roots_size);
- object *allot_object(header header, cell size);
- void add_gc_stats(generation_statistics *stats, growable_array *result);
- void primitive_clear_gc_stats();
+ void inline_gc(cell *data_roots_base, cell data_roots_size);
+ void primitive_enable_gc_events();
+ void primitive_disable_gc_events();
+ object *allot_object(cell type, cell size);
+ object *allot_large_object(cell type, cell size);
template<typename Type> Type *allot(cell size)
{
- return (Type *)allot_object(header(Type::type_number),size);
+ return (Type *)allot_object(Type::type_number,size);
}
inline void check_data_pointer(object *pointer)
#endif
}
- inline void check_tagged_pointer(cell tagged)
- {
- #ifdef FACTOR_DEBUG
- if(!immediate_p(tagged))
- {
- object *obj = untag<object>(tagged);
- check_data_pointer(obj);
- obj->h.hi_tag();
- }
- #endif
- }
-
// generic arrays
- template<typename Array> Array *allot_array_internal(cell capacity);
+ template<typename Array> Array *allot_uninitialized_array(cell capacity);
template<typename Array> bool reallot_array_in_place_p(Array *array, cell capacity);
template<typename Array> Array *reallot_array(Array *array_, cell capacity);
void print_callstack();
void dump_cell(cell x);
void dump_memory(cell from, cell to);
- void dump_zone(const char *name, zone *z);
+ template<typename Generation> void dump_generation(const char *name, Generation *gen);
void dump_generations();
void dump_objects(cell type);
void find_data_references_step(cell *scan);
inline void set_array_nth(array *array, cell slot, cell value);
//strings
- cell string_nth(string* str, cell index);
+ cell string_nth(const string *str, cell index);
void set_string_nth_fast(string *str, cell index, cell ch);
void set_string_nth_slow(string *str_, cell index, cell ch);
void set_string_nth(string *str, cell index, cell ch);
void primitive_uninitialized_byte_array();
void primitive_resize_byte_array();
+ template<typename Type> byte_array *byte_array_from_value(Type *value);
+
//tuples
- tuple *allot_tuple(cell layout_);
void primitive_tuple();
void primitive_tuple_boa();
word *allot_word(cell name_, cell vocab_, cell hashcode_);
void primitive_word();
void primitive_word_xt();
- void update_word_xt(cell w_);
+ void update_word_xt(word *w_);
void primitive_optimized_p();
void primitive_wrapper();
void primitive_bignum_log2();
unsigned int bignum_producer(unsigned int digit);
void primitive_byte_array_to_bignum();
- cell unbox_array_size();
+ inline cell unbox_array_size();
+ cell unbox_array_size_slow();
void primitive_fixnum_to_float();
void primitive_bignum_to_float();
void primitive_str_to_float();
inline double untag_float_check(cell tagged);
inline fixnum float_to_fixnum(cell tagged);
inline double fixnum_to_float(cell tagged);
+
+ // tagged
template<typename Type> Type *untag_check(cell value);
- template<typename Type> Type *untag(cell value);
//io
void init_c_io();
void update_literal_references(code_block *compiled);
void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled);
void update_word_references(code_block *compiled);
- void update_code_block_for_full_gc(code_block *compiled);
+ void update_code_block_words_and_literals(code_block *compiled);
void check_code_address(cell address);
void relocate_code_block(code_block *compiled);
void fixup_labels(array *labels, code_block *compiled);
- code_block *allot_code_block(cell size, cell type);
- code_block *add_code_block(cell type, cell code_, cell labels_, cell owner_, cell relocation_, cell literals_);
+ code_block *allot_code_block(cell size, code_block_type type);
+ code_block *add_code_block(code_block_type type, cell code_, cell labels_, cell owner_, cell relocation_, cell literals_);
//code heap
inline void check_code_pointer(cell ptr)
bool in_code_heap_p(cell ptr);
void jit_compile_word(cell word_, cell def_, bool relocate);
void update_code_heap_words();
+ void update_code_heap_words_and_literals();
void primitive_modify_code_heap();
+ code_heap_room code_room();
void primitive_code_room();
- void forward_object_xts();
- void forward_context_xts();
- void forward_callback_xts();
- void compact_code_heap(bool trace_contexts_p);
void primitive_strip_stack_traces();
/* Apply a function to every code block */
template<typename Iterator> void iterate_code_heap(Iterator &iter)
{
- heap_block *scan = code->first_block();
-
- while(scan)
- {
- if(scan->type() != FREE_BLOCK_TYPE)
- iter((code_block *)scan);
- scan = code->next_block(scan);
- }
+ code->allocator->iterate(iter);
}
//callbacks
void primitive_callstack();
void primitive_set_callstack();
code_block *frame_code(stack_frame *frame);
- cell frame_type(stack_frame *frame);
+ code_block_type frame_type(stack_frame *frame);
cell frame_executing(stack_frame *frame);
stack_frame *frame_successor(stack_frame *frame);
cell frame_scan(stack_frame *frame);
void save_callstack_bottom(stack_frame *callstack_bottom);
template<typename Iterator> void iterate_callstack(context *ctx, Iterator &iterator);
- /* Every object has a regular representation in the runtime, which makes GC
- much simpler. Every slot of the object until binary_payload_start is a pointer
- to some other object. */
- template<typename Iterator> void do_slots(cell obj, Iterator &iter)
- {
- cell scan = obj;
- cell payload_start = binary_payload_start((object *)obj);
- cell end = obj + payload_start;
-
- scan += sizeof(cell);
-
- while(scan < end)
- {
- iter((cell *)scan);
- scan += sizeof(cell);
- }
- }
-
//alien
char *pinned_alien_offset(cell obj);
cell allot_alien(cell delegate_, cell displacement);
cell nth_superclass(tuple_layout *layout, fixnum echelon);
cell nth_hashcode(tuple_layout *layout, fixnum echelon);
cell lookup_tuple_method(cell obj, cell methods);
- cell lookup_hi_tag_method(cell obj, cell methods);
- cell lookup_hairy_method(cell obj, cell methods);
cell lookup_method(cell obj, cell methods);
void primitive_lookup_method();
cell object_class(cell obj);
cell add_inline_cache_entry(cell cache_entries_, cell klass_, cell method_);
void update_pic_transitions(cell pic_size);
void *inline_cache_miss(cell return_address);
- void primitive_reset_inline_cache_stats();
- void primitive_inline_cache_stats();
//factor
void default_parameters(vm_parameters *p);
void init_factor(vm_parameters *p);
void pass_args_to_factor(int argc, vm_char **argv);
void start_factor(vm_parameters *p);
+ void stop_factor();
void start_embedded_factor(vm_parameters *p);
void start_standalone_factor(int argc, vm_char **argv);
char *factor_eval_string(char *string);
void windows_image_path(vm_char *full_path, vm_char *temp_path, unsigned int length);
bool windows_stat(vm_char *path);
- #if defined(WINNT)
+ #if defined(WINNT)
void open_console();
LONG exception_handler(PEXCEPTION_POINTERS pe);
- // next method here:
- #endif
+ #endif
#else // UNIX
- void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap);
- void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap);
- void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap);
- stack_frame *uap_stack_pointer(void *uap);
-
+ void dispatch_signal(void *uap, void (handler)());
#endif
#ifdef __APPLE__
};
- extern unordered_map<THREADHANDLE, factor_vm *> thread_vms;
+ extern std::map<THREADHANDLE, factor_vm *> thread_vms;
}
projects / factor.git / commitdiff