vm/free_list.o \
vm/full_collector.o \
vm/gc.o \
+ vm/gc_info.o \
vm/image.o \
vm/inline_cache.o \
vm/instruction_operands.o \
vm\free_list.obj \
vm\full_collector.obj \
vm\gc.obj \
+ vm/gc_info.obj \
vm\image.obj \
vm\inline_cache.obj \
vm\instruction_operands.obj \
--- /dev/null
+USING: alien alien.c-types alien.data alien.syntax
+classes.struct kernel sequences specialized-arrays
+specialized-arrays.private tools.test compiler.units vocabs ;
+IN: alien.data.tests
+
+STRUCT: foo { a int } { b void* } { c bool } ;
+
+SPECIALIZED-ARRAY: foo
+
+[ t ] [ 0 binary-zero? ] unit-test
+[ f ] [ 1 binary-zero? ] unit-test
+[ f ] [ -1 binary-zero? ] unit-test
+[ t ] [ 0.0 binary-zero? ] unit-test
+[ f ] [ 1.0 binary-zero? ] unit-test
+[ f ] [ -0.0 binary-zero? ] unit-test
+[ t ] [ C{ 0.0 0.0 } binary-zero? ] unit-test
+[ f ] [ C{ 1.0 0.0 } binary-zero? ] unit-test
+[ f ] [ C{ -0.0 0.0 } binary-zero? ] unit-test
+[ f ] [ C{ 0.0 1.0 } binary-zero? ] unit-test
+[ f ] [ C{ 0.0 -0.0 } binary-zero? ] unit-test
+[ t ] [ f binary-zero? ] unit-test
+[ t ] [ 0 <alien> binary-zero? ] unit-test
+[ f ] [ 1 <alien> binary-zero? ] unit-test
+[ f ] [ B{ } binary-zero? ] unit-test
+[ t ] [ S{ foo f 0 f f } binary-zero? ] unit-test
+[ f ] [ S{ foo f 1 f f } binary-zero? ] unit-test
+[ f ] [ S{ foo f 0 ALIEN: 8 f } binary-zero? ] unit-test
+[ f ] [ S{ foo f 0 f t } binary-zero? ] unit-test
+[ t t f ] [
+ foo-array{
+ S{ foo f 0 f f }
+ S{ foo f 0 f f }
+ S{ foo f 1 f f }
+ } [ first binary-zero? ] [ second binary-zero? ] [ third binary-zero? ] tri
+] unit-test
+
+[ ] [
+ [
+ foo specialized-array-vocab forget-vocab
+ ] with-compilation-unit
+] unit-test
! (c)2009, 2010 Slava Pestov, Joe Groff bsd license
USING: accessors alien alien.c-types alien.arrays alien.strings
arrays byte-arrays cpu.architecture fry io io.encodings.binary
-io.files io.streams.memory kernel libc math sequences words
-macros combinators generalizations ;
+io.files io.streams.memory kernel libc math math.functions
+sequences words macros combinators generalizations ;
+QUALIFIED: math
IN: alien.data
GENERIC: require-c-array ( c-type -- )
: with-out-parameters ( c-types quot finish -- values )
[ [ drop (local-allots) ] [ swap out-parameters ] 2bi ] dip call
(cleanup-allot) ; inline
+
+GENERIC: binary-zero? ( value -- ? )
+
+M: object binary-zero? drop f ; inline
+M: f binary-zero? drop t ; inline
+M: integer binary-zero? zero? ; inline
+M: math:float binary-zero? double>bits zero? ; inline
+M: complex binary-zero? >rect [ binary-zero? ] both? ; inline
+
original-error set-global
error set-global ; inline
-
[
! We time bootstrap
nano-count
7 >>a
8 >>b
] unit-test
+
PRIVATE>
M: struct byte-length class "struct-size" word-prop ; foldable
+M: struct binary-zero? binary-object <direct-uchar-array> [ 0 = ] all? ; inline
! class definition
<PRIVATE
-GENERIC: binary-zero? ( value -- ? )
-
-M: object binary-zero? drop f ;
-M: f binary-zero? drop t ;
-M: number binary-zero? 0 = ;
-M: struct binary-zero? >c-ptr [ 0 = ] all? ;
-
: struct-needs-prototype? ( class -- ? )
struct-slots [ initial>> binary-zero? ] all? not ;
[
{
[ caller-parameters ]
- [ ##prepare-var-args alien-invoke-dlsym ##alien-invoke ]
+ [ ##prepare-var-args alien-invoke-dlsym <gc-map> ##alien-invoke ]
[ emit-stack-frame ]
[ box-return* ]
} cleave
M:: #alien-indirect emit-node ( node -- )
node [
D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src
- [ caller-parameters src ##alien-indirect ]
+ [ caller-parameters src <gc-map> ##alien-indirect ]
[ emit-stack-frame ]
[ box-return* ]
tri
GENERIC: box ( vregs reps c-type -- dst )
M: c-type box
- [ first ] [ drop ] [ [ boxer>> ] [ rep>> ] bi ] tri* ^^box ;
+ [ first ] [ drop ] [ [ boxer>> ] [ rep>> ] bi ] tri* <gc-map> ^^box ;
M: long-long-type box
- [ first2 ] [ drop ] [ boxer>> ] tri* ^^box-long-long ;
+ [ first2 ] [ drop ] [ boxer>> ] tri* <gc-map> ^^box-long-long ;
M: struct-c-type box
- '[ _ heap-size ^^allot-byte-array dup ^^unbox-byte-array ] 2dip
+ '[ _ heap-size <gc-map> ^^allot-byte-array dup ^^unbox-byte-array ] 2dip
implode-struct ;
GENERIC: box-parameter ( vregs reps c-type -- dst )
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.cfg.gc-checks compiler.cfg.representations
-compiler.cfg.save-contexts compiler.cfg.ssa.destruction
-compiler.cfg.build-stack-frame compiler.cfg.linear-scan
-compiler.cfg.scheduling ;
+USING: kernel compiler.cfg.gc-checks
+compiler.cfg.representations compiler.cfg.save-contexts
+compiler.cfg.ssa.destruction compiler.cfg.build-stack-frame
+compiler.cfg.linear-scan compiler.cfg.scheduling
+compiler.cfg.stacks.uninitialized ;
IN: compiler.cfg.finalization
: finalize-cfg ( cfg -- cfg' )
select-representations
schedule-instructions
insert-gc-checks
+ dup compute-uninitialized-sets
insert-save-contexts
destruct-ssa
linear-scan
2 \ vreg-counter set-global
-[
- V{
- T{ ##load-tagged f 3 0 }
- T{ ##replace f 3 D 0 }
- T{ ##replace f 3 R 3 }
- }
-] [ [ { D 0 R 3 } wipe-locs ] V{ } make ] unit-test
-
: gc-check? ( bb -- ? )
instructions>>
{
[
V{
- T{ ##load-tagged f 5 0 }
- T{ ##replace f 5 D 0 }
- T{ ##replace f 5 R 3 }
- T{ ##call-gc f { 0 1 2 } }
+ T{ ##call-gc f T{ gc-map } }
T{ ##branch }
}
]
[
- { D 0 R 3 } { 0 1 2 } <gc-call> instructions>>
+ <gc-call> instructions>>
] unit-test
30 \ vreg-counter set-global
[ ] [ cfg get needs-predecessors drop ] unit-test
-[ ] [ { D 1 R 2 } { 10 20 } V{ } 31337 3 get (insert-gc-check) ] unit-test
+[ ] [ V{ } 31337 3 get (insert-gc-check) ] unit-test
[ t ] [ 1 get successors>> first gc-check? ] unit-test
[
V{
- T{ ##load-tagged f 31 0 }
- T{ ##replace f 31 D 0 }
- T{ ##replace f 31 D 1 }
- T{ ##replace f 31 D 2 }
- T{ ##call-gc f { 2 } }
+ T{ ##call-gc f T{ gc-map } }
T{ ##branch }
}
] [ 2 get predecessors>> second instructions>> ] unit-test
compiler.cfg.utilities
compiler.cfg.comparisons
compiler.cfg.instructions
-compiler.cfg.predecessors
-compiler.cfg.liveness
-compiler.cfg.liveness.ssa
-compiler.cfg.stacks.uninitialized ;
+compiler.cfg.predecessors ;
IN: compiler.cfg.gc-checks
<PRIVATE
] bi*
] V{ } make >>instructions ;
-: wipe-locs ( uninitialized-locs -- )
- '[
- int-rep next-vreg-rep
- [ 0 ##load-tagged ]
- [ '[ [ _ ] dip ##replace ] each ] bi
- ] unless-empty ;
-
-: <gc-call> ( uninitialized-locs gc-roots -- bb )
- [ <basic-block> ] 2dip
- [ [ wipe-locs ] [ ##call-gc ] bi* ##branch ] V{ } make
+: <gc-call> ( -- bb )
+ <basic-block>
+ [ <gc-map> ##call-gc ##branch ] V{ } make
>>instructions t >>unlikely? ;
:: insert-guard ( body check bb -- )
check predecessors>> [ bb check update-successors ] each ;
-: (insert-gc-check) ( uninitialized-locs gc-roots phis size bb -- )
+: (insert-gc-check) ( phis size bb -- )
[ [ <gc-call> ] 2dip <gc-check> ] dip insert-guard ;
GENERIC: allocation-size* ( insn -- n )
[ ##allocation? ] filter
[ allocation-size* data-alignment get align ] map-sum ;
-: gc-live-in ( bb -- vregs )
- [ live-in keys ] [ instructions>> [ ##phi? ] filter [ dst>> ] map ] bi
- append ;
-
-: live-tagged ( bb -- vregs )
- gc-live-in [ rep-of tagged-rep? ] filter ;
-
: remove-phis ( bb -- phis )
[ [ ##phi? ] partition ] change-instructions drop ;
: insert-gc-check ( bb -- )
- {
- [ uninitialized-locs ]
- [ live-tagged ]
- [ remove-phis ]
- [ allocation-size ]
- [ ]
- } cleave
- (insert-gc-check) ;
+ [ remove-phis ] [ allocation-size ] [ ] tri (insert-gc-check) ;
PRIVATE>
: insert-gc-checks ( cfg -- cfg' )
dup blocks-with-gc [
- [
- needs-predecessors
- dup compute-ssa-live-sets
- dup compute-uninitialized-sets
- ] dip
+ [ needs-predecessors ] dip
[ insert-gc-check ] each
cfg-changed
] unless-empty ;
INSN: ##box
def: dst/tagged-rep
use: src
-literal: boxer rep ;
+literal: boxer rep gc-map ;
INSN: ##box-long-long
def: dst/tagged-rep
use: src1/int-rep src2/int-rep
-literal: boxer ;
+literal: boxer gc-map ;
INSN: ##allot-byte-array
def: dst/tagged-rep
-literal: size ;
+literal: size gc-map ;
INSN: ##prepare-var-args ;
INSN: ##alien-invoke
-literal: symbols dll ;
+literal: symbols dll gc-map ;
INSN: ##cleanup
literal: n ;
INSN: ##alien-indirect
-use: src/int-rep ;
+use: src/int-rep
+literal: gc-map ;
INSN: ##alien-assembly
literal: quot ;
literal: size cc
temp: temp1/int-rep temp2/int-rep ;
-INSN: ##call-gc
-literal: gc-roots ;
+INSN: ##call-gc literal: gc-map ;
! Spills and reloads, inserted by register allocator
TUPLE: spill-slot { n integer } ;
UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
+! Instructions that contain subroutine calls to functions which
+! allocate memory
+UNION: gc-map-insn
+##call-gc
+##alien-invoke
+##alien-indirect
+##box
+##box-long-long
+##allot-byte-array ;
+
+M: gc-map-insn clone call-next-method [ clone ] change-gc-map ;
+
+! Each one has a gc-map slot
+TUPLE: gc-map scrub-d scrub-r gc-roots ;
+
+: <gc-map> ( -- gc-map ) gc-map new ;
+
! Instructions that clobber registers. They receive inputs and
! produce outputs in spill slots.
UNION: hairy-clobber-insn
M: vreg-insn assign-registers-in-insn
[ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
-M: ##call-gc assign-registers-in-insn
- dup call-next-method
- [ [ vreg>reg ] map ] change-gc-roots drop ;
+M: gc-map-insn assign-registers-in-insn
+ [ [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ]
+ [ gc-map>> [ [ vreg>reg ] map ] change-gc-roots drop ]
+ bi ;
M: insn assign-registers-in-insn drop ;
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors assocs sequences sets
compiler.cfg.def-use compiler.cfg.dataflow-analysis
-compiler.cfg.instructions ;
+compiler.cfg.instructions compiler.cfg.registers
+cpu.architecture ;
IN: compiler.cfg.liveness
! See http://en.wikipedia.org/wiki/Liveness_analysis
-! Do not run after SSA construction
+! Do not run after SSA construction; compiler.cfg.liveness.ssa
+! should be used instead. The transfer-liveness word is used
+! by SSA liveness too, so it handles ##phi instructions.
BACKWARD-ANALYSIS: live
-GENERIC: insn-liveness ( live-set insn -- )
+GENERIC: visit-insn ( live-set insn -- live-set )
: kill-defs ( live-set insn -- live-set )
- defs-vreg [ over delete-at ] when* ;
+ defs-vreg [ over delete-at ] when* ; inline
: gen-uses ( live-set insn -- live-set )
- dup ##phi? [ drop ] [ uses-vregs [ over conjoin ] each ] if ;
+ uses-vregs [ over conjoin ] each ; inline
+
+M: vreg-insn visit-insn [ kill-defs ] [ gen-uses ] bi ;
+
+: fill-gc-map ( live-set insn -- live-set )
+ gc-map>> over keys [ rep-of tagged-rep? ] filter >>gc-roots drop ;
+
+M: gc-map-insn visit-insn
+ [ kill-defs ] [ fill-gc-map ] [ gen-uses ] tri ;
+
+M: ##phi visit-insn kill-defs ;
+
+M: insn visit-insn drop ;
: transfer-liveness ( live-set instructions -- live-set' )
- [ clone ] [ <reversed> ] bi* [ [ kill-defs ] [ gen-uses ] bi ] each ;
+ [ clone ] [ <reversed> ] bi* [ visit-insn ] each ;
: local-live-in ( instructions -- live-set )
[ H{ } ] dip transfer-liveness keys ;
: needs-save-context? ( insns -- ? )
[
{
- [ ##call-gc? ]
[ ##unary-float-function? ]
[ ##binary-float-function? ]
[ ##alien-invoke? ]
V{
T{ ##save-context f 77 78 }
- T{ ##call-gc f { } }
+ T{ ##call-gc f T{ gc-map } }
T{ ##branch }
} 2 test-bb
[ ] [ test-uninitialized ] unit-test
-[ V{ D 0 D 1 D 2 } ] [ 1 get uninitialized-locs ] unit-test
-[ V{ R 0 } ] [ 2 get uninitialized-locs ] unit-test
+[ { B{ 0 0 0 } B{ } } ] [ 1 get uninitialized-in ] unit-test
+[ { B{ 1 1 1 } B{ 0 } } ] [ 2 get uninitialized-in ] unit-test
! When merging, if a location is uninitialized in one branch and
! initialized in another, we have to consider it uninitialized,
[ ] [ test-uninitialized ] unit-test
-[ V{ D 0 } ] [ 3 get uninitialized-locs ] unit-test
+[ { B{ 0 } B{ } } ] [ 3 get uninitialized-in ] unit-test
! Consider the following sequence of instructions:
! ##inc-d 2
-! ##gc
+! ...
+! ##allot
! ##replace ... D 0
! ##replace ... D 1
-! The GC check runs before stack locations 0 and 1 have been initialized,
-! and it needs to zero them out so that GC doesn't try to trace them.
+! The GC check runs before stack locations 0 and 1 have been
+! initialized, and so the GC needs to scrub them so that they
+! don't get traced. This is achieved by computing uninitialized
+! locations with a dataflow analysis, and recording the
+! information in GC maps. The scrub_contexts() method on
+! vm/gc.cpp reads this information from GC maps and performs
+! the scrubbing.
<PRIVATE
] change ;
M: ##inc-d visit-insn n>> ds-loc handle-inc ;
-
M: ##inc-r visit-insn n>> rs-loc handle-inc ;
ERROR: uninitialized-peek insn ;
M: ##replace visit-insn visit-replace ;
M: ##replace-imm visit-insn visit-replace ;
+M: gc-map-insn visit-insn
+ gc-map>>
+ ds-loc get clone >>scrub-d
+ rs-loc get clone >>scrub-r
+ drop ;
+
M: insn visit-insn drop ;
: prepare ( pair -- )
: (join-sets) ( seq1 seq2 -- seq )
2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ bitand ] 2map ;
-: (uninitialized-locs) ( seq quot -- seq' )
- [ [ drop 0 = ] selector [ each-index ] dip ] dip map ; inline
-
PRIVATE>
FORWARD-ANALYSIS: uninitialized
M: uninitialized-analysis join-sets ( sets analysis -- pair )
2drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ;
-
-: uninitialized-locs ( bb -- locs )
- uninitialized-in dup [
- first2
- [ [ <ds-loc> ] (uninitialized-locs) ]
- [ [ <rs-loc> ] (uninitialized-locs) ]
- bi* append
- ] when ;
--- /dev/null
+USING: namespaces byte-arrays make compiler.codegen.fixup
+bit-arrays accessors classes.struct tools.test kernel math
+sequences alien.c-types specialized-arrays boxes
+compiler.cfg.instructions system cpu.architecture ;
+SPECIALIZED-ARRAY: uint
+IN: compiler.codegen.fixup.tests
+
+STRUCT: gc-info
+{ scrub-d-count uint }
+{ scrub-r-count uint }
+{ gc-root-count uint }
+{ return-address-count uint } ;
+
+SINGLETON: fake-cpu
+
+fake-cpu \ cpu set
+
+M: fake-cpu gc-root-offsets ;
+
+[ ] [
+ [
+ init-fixup
+
+ 50 <byte-array> %
+
+ T{ gc-map f B{ } B{ } V{ } } gc-map-here
+
+ 50 <byte-array> %
+
+ T{ gc-map f B{ 0 1 1 1 0 } B{ 1 0 } V{ 1 3 } } gc-map-here
+
+ emit-gc-info
+ ] B{ } make
+ "result" set
+] unit-test
+
+[ 0 ] [ "result" get length 16 mod ] unit-test
+
+[ ] [
+ [
+ 100 <byte-array> %
+
+ ! The below data is 22 bytes -- 6 bytes padding needed to
+ ! align
+ 6 <byte-array> %
+
+ ! Bitmap - 2 bytes
+ ?{
+ ! scrub-d
+ t f f f t
+ ! scrub-r
+ f t
+ ! gc-roots
+ f t f t
+ } underlying>> %
+
+ ! Return addresses - 4 bytes
+ uint-array{ 100 } underlying>> %
+
+ ! GC info footer - 16 bytes
+ S{ gc-info
+ { scrub-d-count 5 }
+ { scrub-r-count 2 }
+ { gc-root-count 4 }
+ { return-address-count 1 }
+ } (underlying)>> %
+ ] B{ } make
+ "expect" set
+] unit-test
+
+[ ] [ "result" get length "expect" get length assert= ] unit-test
+[ ] [ "result" get "expect" get assert= ] unit-test
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays byte-arrays byte-vectors generic assocs hashtables
-io.binary kernel kernel.private math namespaces make sequences
-words quotations strings alien.accessors alien.strings layouts
-system combinators math.bitwise math.order combinators.smart
-accessors growable fry compiler.constants memoize ;
+USING: arrays bit-arrays byte-arrays byte-vectors generic assocs
+hashtables io.binary kernel kernel.private math namespaces make
+sequences words quotations strings alien.accessors alien.strings
+layouts system combinators math.bitwise math.order
+combinators.short-circuit combinators.smart accessors growable
+fry memoize compiler.constants compiler.cfg.instructions
+cpu.architecture ;
IN: compiler.codegen.fixup
! Utilities
: rel-decks-offset ( class -- )
rt-decks-offset rel-fixup ;
-! And the rest
+! Labels
: compute-target ( label-fixup -- offset )
label>> offset>> [ "Unresolved label" throw ] unless* ;
[ [ compute-relative-label ] map concat ]
bi* ;
-: init-fixup ( -- )
- V{ } clone parameter-table set
- V{ } clone literal-table set
- V{ } clone label-table set
- BV{ } clone relocation-table set
- V{ } clone binary-literal-table set ;
-
+! Binary literals
: alignment ( align -- n )
[ compiled-offset dup ] dip align swap - ;
: emit-binary-literals ( -- )
binary-literal-table get [ emit-data ] assoc-each ;
+! GC info
+
+! Every code block either ends with
+!
+! uint 0
+!
+! or
+!
+! bitmap, byte aligned, three subsequences:
+! - <scrubbed data stack locations>
+! - <scrubbed retain stack locations>
+! - <GC root spill slots>
+! uint[] <return addresses>
+! uint <largest scrubbed data stack location>
+! uint <largest scrubbed retain stack location>
+! uint <largest GC root spill slot>
+! uint <number of return addresses>
+
+SYMBOLS: return-addresses gc-maps ;
+
+: gc-map-needed? ( gc-map -- ? )
+ ! If there are no stack locations to scrub and no GC roots,
+ ! there's no point storing the GC map.
+ dup [
+ {
+ [ scrub-d>> empty? ]
+ [ scrub-r>> empty? ]
+ [ gc-roots>> empty? ]
+ } 1&& not
+ ] when ;
+
+: gc-map-here ( gc-map -- )
+ dup gc-map-needed? [
+ gc-maps get push
+ compiled-offset return-addresses get push
+ ] [ drop ] if ;
+
+: emit-scrub ( seqs -- n )
+ ! seqs is a sequence of sequences of 0/1
+ dup [ length ] [ max ] map-reduce
+ [ '[ [ 0 = ] ?{ } map-as _ f pad-tail % ] each ] keep ;
+
+: integers>bits ( seq n -- bit-array )
+ <bit-array> [ '[ [ t ] dip _ set-nth ] each ] keep ;
+
+: emit-gc-roots ( seqs -- n )
+ ! seqs is a sequence of sequences of integers 0..n-1
+ dup [ [ 0 ] [ supremum 1 + ] if-empty ] [ max ] map-reduce
+ [ '[ _ integers>bits % ] each ] keep ;
+
+: emit-uint ( n -- )
+ building get push-uint ;
+
+: gc-info ( -- byte-array )
+ [
+ return-addresses get empty? [ 0 emit-uint ] [
+ gc-maps get
+ [
+ [ [ scrub-d>> ] map emit-scrub ]
+ [ [ scrub-r>> ] map emit-scrub ]
+ [ [ gc-roots>> gc-root-offsets ] map emit-gc-roots ] tri
+ ] ?{ } make underlying>> %
+ return-addresses get [ emit-uint ] each
+ [ emit-uint ] tri@
+ return-addresses get length emit-uint
+ ] if
+ ] B{ } make ;
+
+: emit-gc-info ( -- )
+ ! We want to place the GC info so that the end is aligned
+ ! on a 16-byte boundary.
+ gc-info [
+ length compiled-offset +
+ [ data-alignment get align ] keep -
+ (align-code)
+ ] [ % ] bi ;
+
+: init-fixup ( -- )
+ V{ } clone parameter-table set
+ V{ } clone literal-table set
+ V{ } clone label-table set
+ BV{ } clone relocation-table set
+ V{ } clone binary-literal-table set
+ V{ } clone return-addresses set
+ V{ } clone gc-maps set ;
+
+: check-fixup ( seq -- )
+ length data-alignment get mod 0 assert= ;
+
: with-fixup ( quot -- code )
'[
+ init-fixup
[
- init-fixup
@
emit-binary-literals
+ emit-gc-info
label-table [ compute-labels ] change
parameter-table get >array
literal-table get >array
relocation-table get >byte-array
label-table get
] B{ } make
+ dup check-fixup
] output>array ; inline
! %store-memory work
HOOK: complex-addressing? cpu ( -- ? )
+HOOK: gc-root-offsets cpu ( seq -- seq' )
+
HOOK: %load-immediate cpu ( reg val -- )
HOOK: %load-reference cpu ( reg obj -- )
HOOK: %load-float cpu ( reg val -- )
! GC checks
HOOK: %check-nursery-branch cpu ( label size cc temp1 temp2 -- )
-HOOK: %call-gc cpu ( gc-roots -- )
+HOOK: %call-gc cpu ( gc-map -- )
HOOK: %prologue cpu ( n -- )
HOOK: %epilogue cpu ( n -- )
! Call a function to convert a value into a tagged pointer,
! possibly allocating a bignum, float, or alien instance,
! which is then pushed on the data stack
-HOOK: %box cpu ( dst src func rep -- )
+HOOK: %box cpu ( dst src func rep gc-map -- )
-HOOK: %box-long-long cpu ( dst src1 src2 func -- )
+HOOK: %box-long-long cpu ( dst src1 src2 func gc-map -- )
-HOOK: %allot-byte-array cpu ( dst size -- )
+HOOK: %allot-byte-array cpu ( dst size gc-map -- )
HOOK: %restore-context cpu ( temp1 temp2 -- )
M: object %prepare-var-args ;
-HOOK: %alien-invoke cpu ( function library -- )
+HOOK: %alien-invoke cpu ( function library gc-map -- )
HOOK: %cleanup cpu ( n -- )
M: object %cleanup ( n -- ) drop ;
-HOOK: %alien-indirect cpu ( src -- )
+HOOK: %alien-indirect cpu ( src gc-map -- )
HOOK: %load-reg-param cpu ( dst reg rep -- )
rc-absolute-cell rel-decks-offset
building get push ;
-M:: x86.32 %dispatch ( src temp -- )
- ! Load jump table base.
- temp src HEX: ffffffff [+] LEA
- building get length :> start
- 0 rc-absolute-cell rel-here
- ! Go
- temp HEX: 7f [+] JMP
- building get length :> end
- ! Fix up the displacement above
- cell alignment
- [ end start - + building get dup pop* push ]
- [ (align-code) ]
- bi ;
-
M: x86.32 pic-tail-reg EDX ;
M: x86.32 reserved-stack-space 0 ;
EAX src tagged-rep %copy
4 save-vm-ptr
0 stack@ EAX MOV
- func f %alien-invoke ;
+ func f f %alien-invoke ;
M:: x86.32 %unbox ( dst src func rep -- )
src func call-unbox-func
EAX out int-rep %copy
4 stack@ EAX MOV
8 save-vm-ptr
- func f %alien-invoke ;
+ func f f %alien-invoke ;
-M:: x86.32 %box ( dst src func rep -- )
+M:: x86.32 %box ( dst src func rep gc-map -- )
rep rep-size save-vm-ptr
src rep %store-return
0 stack@ rep %load-return
- func f %alien-invoke
+ func f gc-map %alien-invoke
dst EAX tagged-rep %copy ;
-M:: x86.32 %box-long-long ( dst src1 src2 func -- )
+M:: x86.32 %box-long-long ( dst src1 src2 func gc-map -- )
8 save-vm-ptr
EAX src1 int-rep %copy
0 stack@ EAX int-rep %copy
EAX src2 int-rep %copy
4 stack@ EAX int-rep %copy
- func f %alien-invoke
+ func f gc-map %alien-invoke
dst EAX tagged-rep %copy ;
-M:: x86.32 %allot-byte-array ( dst size -- )
+M:: x86.32 %allot-byte-array ( dst size gc-map -- )
4 save-vm-ptr
0 stack@ size MOV
- "allot_byte_array" f %alien-invoke
+ "allot_byte_array" f gc-map %alien-invoke
dst EAX tagged-rep %copy ;
-M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
+M: x86.32 %alien-invoke
+ [ 0 CALL rc-relative rel-dlsym ] dip gc-map-here ;
M: x86.32 %begin-callback ( -- )
0 save-vm-ptr
4 stack@ 0 MOV
- "begin_callback" f %alien-invoke ;
+ "begin_callback" f f %alien-invoke ;
M: x86.32 %alien-callback ( quot -- )
[ EAX ] dip %load-reference
M: x86.32 %end-callback ( -- )
0 save-vm-ptr
- "end_callback" f %alien-invoke ;
+ "end_callback" f f %alien-invoke ;
GENERIC: float-function-param ( n dst src -- )
M:: x86.32 %unary-float-function ( dst src func -- )
0 dst src float-function-param
- func "libm" load-library %alien-invoke
+ func "libm" load-library f %alien-invoke
dst double-rep %load-return ;
M:: x86.32 %binary-float-function ( dst src1 src2 func -- )
0 dst src1 float-function-param
8 dst src2 float-function-param
- func "libm" load-library %alien-invoke
+ func "libm" load-library f %alien-invoke
dst double-rep %load-return ;
: funny-large-struct-return? ( return abi -- ? )
M: x86.32 %cleanup ( n -- )
[ ESP swap SUB ] unless-zero ;
-M:: x86.32 %call-gc ( gc-roots -- )
- 4 save-vm-ptr
- 0 stack@ gc-roots gc-root-offsets %load-reference
- "inline_gc" f %alien-invoke ;
-
M: x86.32 dummy-stack-params? f ;
M: x86.32 dummy-int-params? f ;
ds-reg ctx-reg context-datastack-offset [+] MOV
rs-reg ctx-reg context-retainstack-offset [+] MOV ;
+: jit-scrub-return ( n -- )
+ ESP swap [+] 0 MOV ;
+
[
! ctx-reg is preserved across the call because it is non-volatile
! in the C ABI
! Unwind stack frames
ESP EDX MOV
+ 0 jit-scrub-return
jit-jump-quot
] \ unwind-native-frames define-sub-primitive
! Contexts
: jit-switch-context ( reg -- )
+ -4 jit-scrub-return
+
! Save ds, rs registers
jit-load-vm
jit-save-context
dup load-decks-offset
[+] card-mark <byte> MOV ;
-M:: x86.64 %dispatch ( src temp -- )
- ! Load jump table base.
- temp HEX: ffffffff MOV
- building get length :> start
- 0 rc-absolute-cell rel-here
- ! Add jump table base
- temp src ADD
- temp HEX: 7f [+] JMP
- building get length :> end
- ! Fix up the displacement above
- cell alignment
- [ end start - + building get dup pop* push ]
- [ (align-code) ]
- bi ;
-
M:: x86.64 %load-reg-param ( dst reg rep -- )
dst reg rep %copy ;
M:: x86.64 %unbox ( dst src func rep -- )
param-reg-0 src tagged-rep %copy
param-reg-1 %mov-vm-ptr
- func f %alien-invoke
+ func f f %alien-invoke
dst rep %load-return ;
-M:: x86.64 %box ( dst src func rep -- )
+M:: x86.64 %box ( dst src func rep gc-map -- )
0 rep reg-class-of cdecl param-regs at nth src rep %copy
rep int-rep? os windows? or param-reg-1 param-reg-0 ? %mov-vm-ptr
- func f %alien-invoke
+ func f gc-map %alien-invoke
dst int-rep %load-return ;
-M:: x86.64 %allot-byte-array ( dst size -- )
+M:: x86.64 %allot-byte-array ( dst size gc-map -- )
param-reg-0 size MOV
param-reg-1 %mov-vm-ptr
- "allot_byte_array" f %alien-invoke
+ "allot_byte_array" f gc-map %alien-invoke
dst int-rep %load-return ;
M: x86.64 %alien-invoke
- R11 0 MOV
- rc-absolute-cell rel-dlsym
- R11 CALL ;
+ [ R11 0 MOV rc-absolute-cell rel-dlsym R11 CALL ] dip
+ gc-map-here ;
M: x86.64 %begin-callback ( -- )
param-reg-0 %mov-vm-ptr
param-reg-1 0 MOV
- "begin_callback" f %alien-invoke ;
+ "begin_callback" f f %alien-invoke ;
M: x86.64 %alien-callback ( quot -- )
[ param-reg-0 ] dip %load-reference
M: x86.64 %end-callback ( -- )
param-reg-0 %mov-vm-ptr
- "end_callback" f %alien-invoke ;
+ "end_callback" f f %alien-invoke ;
: float-function-param ( i src -- )
[ float-regs cdecl param-regs at nth ] dip double-rep %copy ;
M:: x86.64 %unary-float-function ( dst src func -- )
0 src float-function-param
- func "libm" load-library %alien-invoke
+ func "libm" load-library f %alien-invoke
dst double-rep %load-return ;
M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
! src2 is always a spill slot
0 src1 float-function-param
1 src2 float-function-param
- func "libm" load-library %alien-invoke
+ func "libm" load-library f %alien-invoke
dst double-rep %load-return ;
-M:: x86.64 %call-gc ( gc-roots -- )
- param-reg-0 gc-roots gc-root-offsets %load-reference
- param-reg-1 %mov-vm-ptr
- "inline_gc" f %alien-invoke ;
-
M: x86.64 long-long-on-stack? f ;
M: x86.64 float-on-stack? f ;
ds-reg ctx-reg context-datastack-offset [+] MOV
rs-reg ctx-reg context-retainstack-offset [+] MOV ;
+: jit-scrub-return ( n -- )
+ RSP swap [+] 0 MOV ;
+
[
! ctx-reg is preserved across the call because it is non-volatile
! in the C ABI
! Unwind stack frames
RSP arg2 MOV
+ 0 jit-scrub-return
! Load VM pointer into vm-reg, since we're entering from
! C code
! Contexts
: jit-switch-context ( reg -- )
+ -8 jit-scrub-return
+
! Save ds, rs registers
jit-save-context
: spill@ ( n -- op ) spill-offset special-offset stack@ ;
-: gc-root-offsets ( seq -- seq' )
- [ n>> spill-offset special-offset cell + ] map f like ;
-
: decr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
{ cc/<= [ label JG ] }
} case ;
+M: x86 gc-root-offsets
+ [ n>> spill-offset special-offset cell + cell /i ] map f like ;
+
+M: x86 %call-gc ( gc-map -- )
+ \ minor-gc %call
+ gc-map-here ;
+
M: x86 %alien-global ( dst symbol library -- )
- [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
+ [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
src1 src2 (%compare-imm)
label cc %branch ;
+M:: x86 %dispatch ( src temp -- )
+ ! Load jump table base.
+ temp HEX: ffffffff MOV
+ building get length :> start
+ 0 rc-absolute-cell rel-here
+ ! Add jump table base
+ temp src HEX: 7f [++] JMP
+ building get length :> end
+ ! Fix up the displacement above
+ cell alignment
+ [ end start - + building get dup pop* push ]
+ [ (align-code) ]
+ bi ;
+
M:: x86 %spill ( src rep dst -- )
dst src rep %copy ;
M:: x86 %local-allot ( dst size align offset -- )
dst offset local-allot-offset special-offset stack@ LEA ;
-M: x86 %alien-indirect ( src -- )
- ?spill-slot CALL ;
+M: x86 %alien-indirect ( src gc-map -- )
+ [ ?spill-slot CALL ] [ gc-map-here ] bi* ;
M: x86 %loop-entry 16 alignment [ NOP ] times ;
<client>
with-client
}
+"The local address of a client socket can be controlled with this word:"
+{ $subsections
+ with-local-address
+}
"Connection-oriented network servers are implemented by first opening a server socket, then waiting for connections:"
{ $subsections
<server>
HELP: resolve-host
{ $values { "addrspec" "an address specifier" } { "seq" "a sequence of address specifiers" } }
{ $description "Resolves host names to IP addresses." } ;
+
+HELP: with-local-address
+{ $values { "addr" "an " { $link inet4 } " or " { $link inet6 } " address specifier" } { "quot" quotation } }
+{ $description "Client sockets opened within the scope of the quotation passed to this combinator will have their local address bound to the given address." }
+{ $examples
+ { "Binds the local address of a newly created client socket within the quotation to 127.0.0.1."
+ "This ensures that all traffic originates from the given address (the port is choosen by the TCP stack)." }
+ { $code "\"127.0.0.1\" 0 <inet4> [ ] with-local-address" }
+ $nl
+ { "Binds the local address of a newly created client socket within the quotation to the local address 192.168.0.1 and the local port 23000. "
+ "Be aware that you can only have one client socket with the same local address at a time or else an I/O error (\"address already in use\") will be thrown."
+ }
+ { $code "\"192.168.0.1\" 23000 <inet4> [ ] with-local-address" }
+} ;
{ 1237 } [ 1234 next-prime ] unit-test
{ f t } [ 1234 prime? 1237 prime? ] unit-test
{ { 2 3 5 7 } } [ 10 primes-upto >array ] unit-test
+{ { 2 } } [ 2 primes-upto >array ] unit-test
+{ { } } [ 1 primes-upto >array ] unit-test
{ { 999983 1000003 } } [ 999982 1000010 primes-between >array ] unit-test
{ { 4999963 4999999 5000011 5000077 5000081 } }
{ { 8999981 8999993 9000011 9000041 } }
[ 8999980 9000045 primes-between >array ] unit-test
+{ { } } [ 5 4 primes-between >array ] unit-test
+
+{ { 2 } } [ 2 2 primes-between >array ] unit-test
+
+{ { 2 } } [ 1.5 2.5 primes-between >array ] unit-test
+
[ 2 ] [ 1 next-prime ] unit-test
[ 3 ] [ 2 next-prime ] unit-test
[ 5 ] [ 3 next-prime ] unit-test
next-odd [ dup prime? ] [ 2 + ] until
] if ; foldable
-: primes-between ( low high -- seq )
+<PRIVATE
+
+: (primes-between) ( low high -- seq )
[ [ 3 max dup even? [ 1 + ] when ] dip 2 <range> ]
[ <primes-vector> ] 2bi
[ '[ [ prime? ] _ push-if ] each ] keep clone ;
+PRIVATE>
+
+: primes-between ( low high -- seq )
+ [ ceiling >integer ] [ floor >integer ] bi*
+ {
+ { [ 2dup > ] [ 2drop V{ } clone ] }
+ { [ dup 2 = ] [ 2drop V{ 2 } clone ] }
+ { [ dup 2 < ] [ 2drop V{ } clone ] }
+ [ (primes-between) ]
+ } cond ;
+
: primes-upto ( n -- seq ) 2 swap primes-between ;
: coprime? ( a b -- ? ) gcd nip 1 = ; foldable
--- /dev/null
+USING: math.vectors.simd math.vectors.simd.cords tools.test ;\r
+IN: math.vectors.simd.cords.tests\r
+\r
+[ float-4{ 1.0 2.0 3.0 4.0 } ] [ double-4{ 1.0 2.0 3.0 4.0 } >float-4 ] unit-test\r
WHERE
: >A ( seq -- A )
- [ N head >A/2 ]
- [ N tail >A/2 ] bi cord-append ;
+ [ N head-slice >A/2 ]
+ [ N tail-slice >A/2 ] bi cord-append ;
\ A-boa
{ N ndip A/2-boa cord-append } { A/2-boa } >quotation prefix >quotation
USING: math.vectors.simd mirrors ;
IN: math.vectors.simd.mirrors
-INSTANCE: simd-128 enumerated-sequence
+INSTANCE: simd-128 inspected-sequence
INSTANCE: mirror assoc
-MIXIN: enumerated-sequence
-INSTANCE: array enumerated-sequence
-INSTANCE: vector enumerated-sequence
-INSTANCE: callable enumerated-sequence
-INSTANCE: byte-array enumerated-sequence
+MIXIN: inspected-sequence
+INSTANCE: array inspected-sequence
+INSTANCE: vector inspected-sequence
+INSTANCE: callable inspected-sequence
+INSTANCE: byte-array inspected-sequence
GENERIC: make-mirror ( obj -- assoc )
M: hashtable make-mirror ;
M: integer make-mirror drop f ;
-M: enumerated-sequence make-mirror <enum> ;
+M: inspected-sequence make-mirror <enum> ;
M: object make-mirror <mirror> ;
M: object pprint* pprint-object ;
M: vector pprint* pprint-object ;
M: byte-vector pprint* pprint-object ;
-M: hashtable pprint* pprint-object ;
+M: hashtable pprint*
+ nesting-limit inc
+ [ pprint-object ] [ nesting-limit dec ] [ ] cleanup ;
M: curry pprint* pprint-object ;
M: compose pprint* pprint-object ;
M: hash-set pprint* pprint-object ;
! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences sorting binary-search fry math
-math.order arrays classes combinators kernel functors math.functions
-math.vectors ;
+math.order arrays classes combinators kernel functors locals
+math.functions math.vectors ;
IN: sequences.cords
MIXIN: cord
[ [ head>> ] dip call ]
[ [ tail>> ] dip call ] 2bi cord-append ; inline
-: cord-2map ( cord cord quot -- cord' )
- [ [ [ head>> ] bi@ ] dip call ]
- [ [ [ tail>> ] bi@ ] dip call ] 3bi cord-append ; inline
+:: cord-2map ( cord-a cord-b quot fallback -- cord' )
+ cord-a cord-b 2dup [ cord? ] both? [
+ [ [ head>> ] bi@ quot call ]
+ [ [ tail>> ] bi@ quot call ] 2bi cord-append
+ ] [ fallback call ] if ; inline
: cord-both ( cord quot -- h t )
[ [ head>> ] [ tail>> ] bi ] dip bi@ ; inline
-: cord-2both ( cord cord quot -- h t )
- [ [ [ head>> ] bi@ ] dip call ]
- [ [ [ tail>> ] bi@ ] dip call ] 3bi ; inline
+:: cord-2both ( cord-a cord-b quot combine fallback -- result )
+ cord-a cord-b 2dup [ cord? ] both? [
+ [ [ head>> ] bi@ quot call ]
+ [ [ tail>> ] bi@ quot call ] 2bi combine call
+ ] [ fallback call ] if ; inline
<PRIVATE
: split-shuffle ( shuf -- sh uf )
dup length 2 /i cut* ; foldable
PRIVATE>
-M: cord v+ [ v+ ] cord-2map ; inline
-M: cord v- [ v- ] cord-2map ; inline
+M: cord v+ [ v+ ] [ call-next-method ] cord-2map ; inline
+M: cord v- [ v- ] [ call-next-method ] cord-2map ; inline
M: cord vneg [ vneg ] cord-map ; inline
-M: cord v+- [ v+- ] cord-2map ; inline
-M: cord vs+ [ vs+ ] cord-2map ; inline
-M: cord vs- [ vs- ] cord-2map ; inline
-M: cord vs* [ vs* ] cord-2map ; inline
-M: cord v* [ v* ] cord-2map ; inline
-M: cord v/ [ v/ ] cord-2map ; inline
-M: cord vmin [ vmin ] cord-2map ; inline
-M: cord vmax [ vmax ] cord-2map ; inline
-M: cord v. [ v. ] cord-2both + ; inline
+M: cord v+- [ v+- ] [ call-next-method ] cord-2map ; inline
+M: cord vs+ [ vs+ ] [ call-next-method ] cord-2map ; inline
+M: cord vs- [ vs- ] [ call-next-method ] cord-2map ; inline
+M: cord vs* [ vs* ] [ call-next-method ] cord-2map ; inline
+M: cord v* [ v* ] [ call-next-method ] cord-2map ; inline
+M: cord v/ [ v/ ] [ call-next-method ] cord-2map ; inline
+M: cord vmin [ vmin ] [ call-next-method ] cord-2map ; inline
+M: cord vmax [ vmax ] [ call-next-method ] cord-2map ; inline
+M: cord v.
+ [ v. ] [ + ] [ call-next-method ] cord-2both ; inline
M: cord vsqrt [ vsqrt ] cord-map ; inline
M: cord sum [ sum ] cord-both + ; inline
M: cord vabs [ vabs ] cord-map ; inline
-M: cord vbitand [ vbitand ] cord-2map ; inline
-M: cord vbitandn [ vbitandn ] cord-2map ; inline
-M: cord vbitor [ vbitor ] cord-2map ; inline
-M: cord vbitxor [ vbitxor ] cord-2map ; inline
+M: cord vbitand [ vbitand ] [ call-next-method ] cord-2map ; inline
+M: cord vbitandn [ vbitandn ] [ call-next-method ] cord-2map ; inline
+M: cord vbitor [ vbitor ] [ call-next-method ] cord-2map ; inline
+M: cord vbitxor [ vbitxor ] [ call-next-method ] cord-2map ; inline
M: cord vbitnot [ vbitnot ] cord-map ; inline
-M: cord vand [ vand ] cord-2map ; inline
-M: cord vandn [ vandn ] cord-2map ; inline
-M: cord vor [ vor ] cord-2map ; inline
-M: cord vxor [ vxor ] cord-2map ; inline
+M: cord vand [ vand ] [ call-next-method ] cord-2map ; inline
+M: cord vandn [ vandn ] [ call-next-method ] cord-2map ; inline
+M: cord vor [ vor ] [ call-next-method ] cord-2map ; inline
+M: cord vxor [ vxor ] [ call-next-method ] cord-2map ; inline
M: cord vnot [ vnot ] cord-map ; inline
M: cord vlshift '[ _ vlshift ] cord-map ; inline
M: cord vrshift '[ _ vrshift ] cord-map ; inline
M: cord (vmerge-head) [ head>> ] bi@ (vmerge) cord-append ; inline
M: cord (vmerge-tail) [ tail>> ] bi@ (vmerge) cord-append ; inline
-M: cord v<= [ v<= ] cord-2map ; inline
-M: cord v< [ v< ] cord-2map ; inline
-M: cord v= [ v= ] cord-2map ; inline
-M: cord v> [ v> ] cord-2map ; inline
-M: cord v>= [ v>= ] cord-2map ; inline
-M: cord vunordered? [ vunordered? ] cord-2map ; inline
+M: cord v<= [ v<= ] [ call-next-method ] cord-2map ; inline
+M: cord v< [ v< ] [ call-next-method ] cord-2map ; inline
+M: cord v= [ v= ] [ call-next-method ] cord-2map ; inline
+M: cord v> [ v> ] [ call-next-method ] cord-2map ; inline
+M: cord v>= [ v>= ] [ call-next-method ] cord-2map ; inline
+M: cord vunordered? [ vunordered? ] [ call-next-method ] cord-2map ; inline
M: cord vany? [ vany? ] cord-both or ; inline
M: cord vall? [ vall? ] cord-both and ; inline
M: cord vnone? [ vnone? ] cord-both and ; inline
USING: mirrors specialized-arrays math.vectors ;
IN: specialized-arrays.mirrors
-INSTANCE: specialized-array enumerated-sequence
+INSTANCE: specialized-array inspected-sequence
bi
] "" make ;
-PRIVATE>
-
-: direct-slice ( from to seq -- seq' )
- check-slice
+: direct-slice-unsafe ( from to seq -- seq' )
[ nip nth-c-ptr ]
[ drop swap - ]
[ 2nip ] 3tri direct-like ; inline
+PRIVATE>
+
+: direct-slice ( from to seq -- seq' )
+ check-slice direct-slice-unsafe ; inline
+
: direct-head ( seq n -- seq' ) (head) direct-slice ; inline
: direct-tail ( seq n -- seq' ) (tail) direct-slice ; inline
: direct-head* ( seq n -- seq' ) from-end direct-head ; inline
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: specialized-vectors mirrors ;
+IN: specialized-vectors.mirrors
+
+INSTANCE: specialized-vector inspected-sequence
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.parser assocs
-compiler.units functors growable kernel lexer math namespaces
-parser prettyprint.custom sequences specialized-arrays
-specialized-arrays.private strings vocabs vocabs.parser
-vocabs.generated fry make ;
+classes compiler.units functors growable kernel lexer math
+namespaces parser prettyprint.custom sequences
+specialized-arrays specialized-arrays.private strings
+vocabs vocabs.loader vocabs.parser vocabs.generated fry make ;
FROM: sequences.private => nth-unsafe ;
FROM: specialized-arrays.private => nth-c-ptr direct-like ;
QUALIFIED: vectors.functor
IN: specialized-vectors
+MIXIN: specialized-vector
+
<PRIVATE
FUNCTOR: define-vector ( T -- )
-V DEFINES-CLASS ${T}-vector
+V DEFINES-CLASS ${T}-vector
-A IS ${T}-array
-<A> IS <${A}>
+A IS ${T}-array
+>A IS >${A}
+<A> IS <${A}>
<direct-A> IS <direct-${A}>
->V DEFERS >${V}
-V{ DEFINES ${V}{
+>V DEFERS >${V}
+V{ DEFINES ${V}{
WHERE
M: V direct-like drop <direct-A> ; inline
M: V nth-c-ptr underlying>> nth-c-ptr ; inline
+M: A like
+ drop dup A instance? [
+ dup V instance? [ [ >c-ptr ] [ length>> ] bi <direct-A> ] [ >A ] if
+ ] unless ; inline
+
SYNTAX: V{ \ } [ >V ] parse-literal ;
+INSTANCE: V specialized-vector
INSTANCE: V growable
;FUNCTOR
scan-c-type
[ define-array-vocab use-vocab ]
[ define-vector-vocab use-vocab ] bi ;
+
+{ "specialized-vectors" "mirrors" } "specialized-vectors.mirrors" require-when
USING: tools.disassembler.udis tools.test alien.c-types system combinators kernel ;
{
- { [ os linux? cpu x86.64? and ] [ [ 656 ] [ ud heap-size ] unit-test ] }
- { [ os macosx? cpu x86.32? and ] [ [ 592 ] [ ud heap-size ] unit-test ] }
- { [ os macosx? cpu x86.64? and ] [ [ 656 ] [ ud heap-size ] unit-test ] }
+ { [ cpu x86.32? ] [ [ 604 ] [ ud heap-size ] unit-test ] }
+ { [ cpu x86.64? ] [ [ 672 ] [ ud heap-size ] unit-test ] }
[ ]
} cond
\ No newline at end of file
{ c3 uchar }
{ inp_cache uchar[256] }
{ inp_sess uchar[64] }
- { itab_entry void* } ;
+ { have_modrm uchar }
+ { modrm uchar }
+ { user_opaque_data void* }
+ { itab_entry void* }
+ { le void* } ;
FUNCTION: void ud_translate_intel ( ud* u ) ;
FUNCTION: void ud_translate_att ( ud* u ) ;
-USING: definitions kernel locals.definitions see see.private typed words ;
+USING: definitions kernel locals.definitions see see.private typed words
+summary make accessors classes ;
IN: typed.prettyprint
PREDICATE: typed-lambda-word < lambda-word "typed-word" word-prop ;
M: typed-word definition "typed-def" word-prop ;
M: typed-word declarations. "typed-word" word-prop declarations. ;
+M: input-mismatch-error summary
+ [
+ "Typed word “" %
+ dup word>> name>> %
+ "” expected input value of type " %
+ dup expected-type>> name>> %
+ " but got " %
+ dup value>> class name>> %
+ drop
+ ] "" make ;
+
+M: output-mismatch-error summary
+ [
+ "Typed word “" %
+ dup word>> name>> %
+ "” expected to output value of type " %
+ dup expected-type>> name>> %
+ " but gave " %
+ dup value>> class name>> %
+ drop
+ ] "" make ;
USING: accessors effects eval kernel layouts math namespaces
-quotations tools.test typed words words.symbol
-compiler.tree.debugger prettyprint definitions compiler.units ;
+quotations tools.test typed words words.symbol combinators.short-circuit
+compiler.tree.debugger prettyprint definitions compiler.units sequences ;
IN: typed.tests
TYPED: f+ ( a: float b: float -- c: float )
TYPED: dum ( x: tweedle-dum -- y )
drop \ tweedle-dum ;
-[ \ tweedle-dum new dee ] [ input-mismatch-error? ] must-fail-with
-[ \ tweedle-dee new dum ] [ input-mismatch-error? ] must-fail-with
+[ \ tweedle-dum new dee ]
+[ { [ input-mismatch-error? ] [ expected-type>> tweedle-dee = ] [ value>> tweedle-dum? ] } 1&& ] must-fail-with
+[ \ tweedle-dee new dum ]
+[ { [ input-mismatch-error? ] [ expected-type>> tweedle-dum = ] [ value>> tweedle-dee? ] } 1&& ] must-fail-with
TYPED: dumdum ( x -- y: tweedle-dum )
drop \ tweedle-dee new ;
-[ f dumdum ] [ output-mismatch-error? ] must-fail-with
+[ f dumdum ]
+[ { [ output-mismatch-error? ] [ expected-type>> tweedle-dum = ] [ value>> tweedle-dee? ] } 1&& ] must-fail-with
TYPED:: f+locals ( a: float b: float -- c: float )
a b + ;
FROM: classes.tuple.private => tuple-layout ;
IN: typed
-ERROR: type-mismatch-error word expected-types ;
+ERROR: type-mismatch-error value expected-type word expected-types ;
ERROR: input-mismatch-error < type-mismatch-error ;
ERROR: output-mismatch-error < type-mismatch-error ;
: typed-stack-effect? ( effect -- ? )
[ object = ] all? not ;
-: input-mismatch-quot ( word types -- quot )
- [ input-mismatch-error ] 2curry ;
-
: depends-on-unboxing ( class -- )
[ dup tuple-layout depends-on-tuple-layout ]
[ depends-on-final ]
:: unboxer ( error-quot word types type -- quot )
type "coercer" word-prop [ ] or
- [ dup type instance? [ word types error-quot call ] unless ]
+ type type word types error-quot '[ dup _ instance? [ _ _ _ @ ] unless ]
type (unboxer)
compose compose ;
if Err.Number = 0 then\r
if http.Status = 200 then\r
dim dest_stream\r
- set dest_stream = CreateObject("ADODB.Stream")\r
+ odd = "DOD"\r
+ set dest_stream = CreateObject("A"+odd+"B"+".Stream")\r
\r
Err.Clear\r
dest_stream.Type = 1 ' adTypeBinary\r
$nl
"The second way is to create a configuration file. You can list additional vocabulary roots in a file that Factor reads at startup:"
{ $subsections "factor-roots" }
-"Finally, you can add vocabulary roots dynamically using a word:"
+"Finally, you can add vocabulary roots by calling a word from your " { $snippet "factor-rc" } " file (see " { $link "factor-rc" } "):"
{ $subsections add-vocab-root } ;
ARTICLE: "vocabs.roots" "Vocabulary roots"
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: accessors alien alien.c-types alien.handles alien.syntax
+destructors kernel math tools.test ;
+IN: alien.handles.tests
+
+TUPLE: thingy { x integer } ;
+C: <thingy> thingy
+
+CALLBACK: int thingy-callback ( uint thingy-handle ) ;
+CALLBACK: int thingy-ptr-callback ( void* thingy-handle ) ;
+
+: test-thingy-callback ( -- alien )
+ [ alien-handle> x>> 1 + ] thingy-callback ;
+
+: test-thingy-ptr-callback ( -- alien )
+ [ alien-handle-ptr> x>> 1 + ] thingy-ptr-callback ;
+
+: invoke-test-thingy-callback ( thingy -- n )
+ test-thingy-callback int { uint } cdecl alien-indirect ;
+: invoke-test-thingy-ptr-callback ( thingy -- n )
+ test-thingy-ptr-callback int { void* } cdecl alien-indirect ;
+
+[ t f ] [
+ [ 5 <thingy> <alien-handle> &release-alien-handle [ alien-handle? ] keep ] with-destructors
+ alien-handle?
+] unit-test
+
+[ t f ] [
+ [ 5 <thingy> <alien-handle-ptr> &release-alien-handle-ptr [ alien-handle-ptr? ] keep ] with-destructors
+ alien-handle-ptr?
+] unit-test
+
+[ 6 ] [
+ [
+ 5 <thingy> <alien-handle> &release-alien-handle
+ invoke-test-thingy-callback
+ ] with-destructors
+] unit-test
+
+[ 6 ] [
+ [
+ 5 <thingy> <alien-handle-ptr> &release-alien-handle-ptr
+ invoke-test-thingy-ptr-callback
+ ] with-destructors
+] unit-test
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: alien alien.destructors assocs kernel math math.bitwise
+namespaces ;
+IN: alien.handles
+
+<PRIVATE
+
+SYMBOLS: alien-handle-counter alien-handles ;
+
+alien-handle-counter [ 0 ] initialize
+alien-handles [ H{ } clone ] initialize
+
+: biggest-handle ( -- n )
+ -1 32 bits ; inline
+
+: (next-handle) ( -- n )
+ alien-handle-counter [ 1 + biggest-handle bitand dup ] change-global ; inline
+
+: next-handle ( -- n )
+ [ (next-handle) dup alien-handles get-global key? ] [ drop ] while ;
+
+PRIVATE>
+
+: <alien-handle> ( object -- int )
+ next-handle [ alien-handles get-global set-at ] keep ; inline
+: alien-handle> ( int -- object )
+ alien-handles get-global at ; inline
+
+: alien-handle? ( int -- ? )
+ alien-handles get-global key? >boolean ; inline
+
+: release-alien-handle ( int -- )
+ alien-handles get-global delete-at ; inline
+
+DESTRUCTOR: release-alien-handle
+
+: <alien-handle-ptr> ( object -- void* )
+ <alien-handle> <alien> ; inline
+: alien-handle-ptr> ( void* -- object )
+ alien-address alien-handle> ; inline
+
+: alien-handle-ptr? ( alien -- ? )
+ alien-address alien-handle? ; inline
+
+: release-alien-handle-ptr ( alien -- )
+ alien-address release-alien-handle ; inline
+
+DESTRUCTOR: release-alien-handle-ptr
+
--- /dev/null
+Generate integer handle values to allow Factor object references to be passed through the FFI
! (c)2010 Joe Groff bsd license\r
-USING: byte-arrays.hex io.encodings.8-bit.koi8-r io.encodings.detect tools.test ;\r
+USING: byte-arrays byte-arrays.hex io.encodings.8-bit.koi8-r\r
+io.encodings.8-bit.latin1 io.encodings.binary\r
+io.encodings.detect io.encodings.utf16 io.encodings.utf32\r
+io.encodings.utf8 namespaces tools.test ;\r
IN: io.encodings.detect.tests\r
\r
! UTF encodings with BOMs\r
unit-test\r
\r
! Default to utf8 if decoding succeeds and there are no nulls\r
+[ utf8 ] [ HEX{ } detect-byte-array ] unit-test\r
[ utf8 ] [ HEX{ 31 32 33 } detect-byte-array ] unit-test\r
[ utf8 ] [ HEX{ 31 32 C2 A0 33 } detect-byte-array ] unit-test\r
[ latin1 ] [ HEX{ 31 32 A0 33 } detect-byte-array ] unit-test\r
\r
[ binary ] [ HEX{ 31 32 33 C2 A0 00 } detect-byte-array ] unit-test\r
[ binary ] [ HEX{ 31 32 33 C2 A0 00 30 } detect-byte-array ] unit-test\r
+\r
{ [ dup HEX{ EF BB BF } head? ] [ drop utf8 ] }\r
{ [ dup $[ "<?xml" >byte-array ] head? ] [ detect-xml-prolog ] }\r
{ [ 0 over member? ] [ drop binary ] }\r
+ { [ dup empty? ] [ drop utf8 ] }\r
{ [ dup valid-utf8? ] [ drop utf8 ] }\r
[ drop default-8bit-encoding get ]\r
} cond ;\r
! Copyright (C) 2005 Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.libraries alien.syntax kernel
-sequences words system combinators opengl.gl ;
+sequences words system combinators opengl.gl alien.destructors ;
IN: opengl.glu
<<
! FUNCTION: GLboolean gluCheckExtension ( GLubyte* extName, GLubyte* extString ) ;
! FUNCTION: GLint gluUnProject4 ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdouble clipW, GLdouble* model, GLdouble* proj, GLint* view, GLdouble nearVal, GLdouble farVal, GLdouble* objX, GLdouble* objY, GLdouble* objZ, GLdouble* objW ) ;
+DESTRUCTOR: gluDeleteNurbsRenderer
+DESTRUCTOR: gluDeleteQuadric
+DESTRUCTOR: gluDeleteTess
+
+CALLBACK: void GLUtessBeginCallback ( GLenum type ) ;
+CALLBACK: void GLUtessBeginDataCallback ( GLenum type, void* data ) ;
+CALLBACK: void GLUtessEdgeFlagCallback ( GLboolean flag ) ;
+CALLBACK: void GLUtessEdgeFlagDataCallback ( GLboolean flag, void* data ) ;
+CALLBACK: void GLUtessVertexCallback ( void* vertex_data ) ;
+CALLBACK: void GLUtessVertexDataCallback ( void* vertex_data, void* data ) ;
+CALLBACK: void GLUtessEndCallback ( ) ;
+CALLBACK: void GLUtessEndDataCallback ( void* data ) ;
+CALLBACK: void GLUtessCombineDataCallback ( GLdouble* coords, void** vertex_data, GLfloat* weight, void** out_data, void* data ) ;
+CALLBACK: void GLUtessErrorCallback ( GLenum errno ) ;
+CALLBACK: void GLUtessErrorDataCallback ( GLenum errno, void* data ) ;
+
: gl-look-at ( eye focus up -- )
[ first3 ] tri@ gluLookAt ;
! Copyright (C) 2009 Elie Chaftari.
! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.promises namespaces kernel pop3 pop3.server
-sequences tools.test accessors ;
+sequences tools.test accessors calendar ;
IN: pop3.tests
FROM: pop3 => count delete ;
[ ] [
<pop3-account>
"127.0.0.1" >>host
- "p1" get ?promise >>port
+ "p1" get 5 seconds ?promise-timeout >>port
connect
] unit-test
[ ] [ "username@host.com" >user ] unit-test
[ ] [
<pop3-account>
"127.0.0.1" >>host
- "p2" get ?promise >>port
+ "p2" get 5 seconds ?promise-timeout >>port
"username@host.com" >>user
"password" >>pwd
connect
(ratio constant "ratios")
(declaration keyword "declaration words")
(ebnf-form constant "EBNF: ... ;EBNF form")
+ (error-form warning "ERROR: ... ; form")
(parsing-word keyword "parsing words")
(postpone-body comment "postponed form")
(setter-word function-name "setter words (>>foo)")
(,fuel-syntax--brace-words-regex 1 'factor-font-lock-parsing-word)
(,fuel-syntax--alien-function-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-word))
+ (,fuel-syntax--alien-function-alias-regex (1 'factor-font-lock-word)
+ (2 'factor-font-lock-type-name)
+ (3 'factor-font-lock-word))
(,fuel-syntax--alien-callback-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-word))
(,fuel-syntax--vocab-ref-regexp 2 'factor-font-lock-vocabulary-name)
(,fuel-syntax--typedef-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-type-name)
(3 'factor-font-lock-invalid-syntax nil t))
+ (,fuel-syntax--c-global-regex (1 'factor-font-lock-type-name)
+ (2 'factor-font-lock-word)
+ (3 'factor-font-lock-invalid-syntax nil t))
+ (,fuel-syntax--c-type-regex (1 'factor-font-lock-type-name)
+ (2 'factor-font-lock-invalid-syntax nil t))
(,fuel-syntax--rename-regex (1 'factor-font-lock-word)
(2 'factor-font-lock-vocabulary-name)
(3 'factor-font-lock-word)
(,fuel-syntax--float-regex . 'factor-font-lock-number)
(,fuel-syntax--ratio-regex . 'factor-font-lock-ratio)
(,fuel-syntax--type-definition-regex 2 'factor-font-lock-type-name)
+ (,fuel-syntax--error-regex 2 'factor-font-lock-error-form)
(,fuel-syntax--method-definition-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-word))
(,fuel-syntax--before-definition-regex (1 'factor-font-lock-type-name)
'(":" "::" ";" "&:" "<<" "<PRIVATE" ">>"\r
"ABOUT:" "AFTER:" "ALIAS:" "ALIEN:" "ARTICLE:"\r
"B" "BEFORE:" "BIN:"\r
- "C:" "CALLBACK:" "ENUM:" "C-TYPE:" "CHAR:" "COM-INTERFACE:" "CONSTANT:" "CONSULT:" "call-next-method"\r
- "DEFER:"\r
- "EBNF:" ";EBNF" "ERROR:" "EXCLUDE:"\r
- "f" "FORGET:" "FROM:" "FUNCTION:"\r
+ "C:" "CALLBACK:" "C-GLOBAL:" "C-TYPE:" "CHAR:" "COM-INTERFACE:" "CONSTANT:" "CONSULT:" "call-next-method"\r
+ "DEFER:" "DESTRUCTOR:"\r
+ "EBNF:" ";EBNF" "ENUM:" "ERROR:" "EXCLUDE:"\r
+ "f" "FORGET:" "FROM:" "FUNCTION:" "FUNCTION-ALIAS:"\r
"GAME:" "GENERIC#" "GENERIC:"\r
"GLSL-SHADER:" "GLSL-PROGRAM:"\r
"HELP:" "HEX:" "HOOK:"\r
(fuel-syntax--second-word-regex\r
'("C-STRUCT:" "C-UNION:" "COM-INTERFACE:" "MIXIN:" "TUPLE:" "SINGLETON:" "SPECIALIZED-ARRAY:" "STRUCT:" "UNION:" "UNION-STRUCT:")))\r
\r
+(defconst fuel-syntax--error-regex\r
+ (fuel-syntax--second-word-regex '("ERROR:")))\r
+\r
(defconst fuel-syntax--tuple-decl-regex\r
"^TUPLE: +\\([^ \n]+\\) +< +\\([^ \n]+\\)\\_>")\r
\r
(defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$")\r
\r
(defconst fuel-syntax--alien-function-regex\r
- "\\_<FUNCTION: \\(\\w+\\) \\(\\w+\\)")\r
+ "\\_<FUNCTION: +\\(\\w+\\)[\n ]+\\(\\w+\\)")\r
+\r
+(defconst fuel-syntax--alien-function-alias-regex\r
+ "\\_<FUNCTION-ALIAS: +\\(\\w+\\)[\n ]+\\(\\w+\\)[\n ]+\\(\\w+\\)")\r
\r
(defconst fuel-syntax--alien-callback-regex\r
- "\\_<CALLBACK: \\(\\w+\\) \\(\\w+\\)")\r
+ "\\_<CALLBACK: +\\(\\w+\\) +\\(\\w+\\)")\r
\r
(defconst fuel-syntax--indent-def-starts '("" ":"\r
"AFTER" "BEFORE"\r
- "ENUM" "COM-INTERFACE" "CONSULT"\r
- "FROM" "FUNCTION:"\r
+ "COM-INTERFACE" "CONSULT"\r
+ "ENUM" "ERROR"\r
+ "FROM" "FUNCTION:" "FUNCTION-ALIAS:"\r
"INTERSECTION:"\r
"M" "M:" "MACRO" "MACRO:"\r
"MEMO" "MEMO:" "METHOD"\r
(defconst fuel-syntax--single-liner-regex\r
(regexp-opt '("ABOUT:"\r
"ALIAS:"\r
- "CONSTANT:" "C:" "C-TYPE:"\r
- "DEFER:"\r
+ "CONSTANT:" "C:" "C-GLOBAL:" "C-TYPE:"\r
+ "DEFER:" "DESTRUCTOR:"\r
"FORGET:"\r
- "GAME:" "GENERIC:" "GENERIC#" "GLSL-PROGRAM:" \r
+ "GAME:" "GENERIC:" "GENERIC#" "GLSL-PROGRAM:"\r
"HEX:" "HOOK:"\r
"IN:" "INSTANCE:"\r
"LIBRARY:"\r
(defconst fuel-syntax--typedef-regex\r
"\\_<TYPEDEF: +\\(\\w+\\) +\\(\\w+\\)\\( .*\\)?$")\r
\r
+(defconst fuel-syntax--c-global-regex\r
+ "\\_<C-GLOBAL: +\\(\\w+\\) +\\(\\w+\\)\\( .*\\)?$")\r
+\r
+(defconst fuel-syntax--c-type-regex\r
+ "\\_<C-TYPE: +\\(\\w+\\)\\( .*\\)?$")\r
+\r
(defconst fuel-syntax--rename-regex\r
"\\_<RENAME: +\\(\\w+\\) +\\(\\w+\\) +=> +\\(\\w+\\)\\( .*\\)?$")\r
\r
return x;
}
+inline bool bitmap_p(u8 *bitmap, cell index)
+{
+ cell byte = index >> 3;
+ cell bit = index & 7;
+ return (bitmap[byte] & (1 << bit)) != 0;
+}
+
}
ctx->push(tag<byte_array>(reallot_array(array.untagged(),capacity)));
}
-void growable_byte_array::append_bytes(void *elts, cell len)
+void growable_byte_array::grow_bytes(cell len)
{
- cell new_size = count + len;
- factor_vm *parent = elements.parent;
- if(new_size >= array_capacity(elements.untagged()))
- elements = parent->reallot_array(elements.untagged(),new_size * 2);
-
- memcpy(&elements->data<u8>()[count],elts,len);
-
count += len;
+ if(count >= array_capacity(elements.untagged()))
+ elements = elements.parent->reallot_array(elements.untagged(),count * 2);
+}
+
+void growable_byte_array::append_bytes(void *elts, cell len)
+{
+ cell old_count = count;
+ grow_bytes(len);
+ memcpy(&elements->data<u8>()[old_count],elts,len);
}
void growable_byte_array::append_byte_array(cell byte_array_)
explicit growable_byte_array(factor_vm *parent,cell capacity = 40) : count(0), elements(parent->allot_byte_array(capacity),parent) { }
+ void grow_bytes(cell len);
void append_bytes(void *elts, cell len);
void append_byte_array(cell elts);
return (stack_frame *)((cell)frame - frame->size);
}
-/* Allocates memory */
+cell factor_vm::frame_offset(stack_frame *frame)
+{
+ char *entry_point = (char *)frame_code(frame)->entry_point();
+ char *return_address = (char *)FRAME_RETURN_ADDRESS(frame,this);
+ if(return_address)
+ return return_address - entry_point;
+ else
+ return (cell)-1;
+}
+
+void factor_vm::set_frame_offset(stack_frame *frame, cell offset)
+{
+ char *entry_point = (char *)frame_code(frame)->entry_point();
+ if(offset == (cell)-1)
+ FRAME_RETURN_ADDRESS(frame,this) = NULL;
+ else
+ FRAME_RETURN_ADDRESS(frame,this) = entry_point + offset;
+}
+
cell factor_vm::frame_scan(stack_frame *frame)
{
switch(frame_type(frame))
obj = obj.as<word>()->def;
if(obj.type_p(QUOTATION_TYPE))
- {
- char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame,this);
- char *quot_entry_point = (char *)frame_code(frame)->entry_point();
-
- return tag_fixnum(quot_code_offset_to_scan(
- obj.value(),(cell)(return_addr - quot_entry_point)));
- }
+ return tag_fixnum(quot_code_offset_to_scan(obj.value(),frame_offset(frame)));
else
return false_object;
}
}
}
-namespace
-{
-
struct stack_frame_accumulator {
factor_vm *parent;
growable_array frames;
}
};
-}
-
void factor_vm::primitive_callstack_to_array()
{
data_root<callstack> callstack(ctx->pop(),this);
jit_compile_quot(quot.value(),true);
stack_frame *inner = innermost_stack_frame(callstack.untagged());
- cell offset = (char *)FRAME_RETURN_ADDRESS(inner,this) - (char *)inner->entry_point;
+ cell offset = frame_offset(inner);
inner->entry_point = quot->entry_point;
- FRAME_RETURN_ADDRESS(inner,this) = (char *)quot->entry_point + offset;
+ set_frame_offset(inner,offset);
}
void factor_vm::primitive_callstack_bounds()
- visit_context_code_blocks()
- visit_callback_code_blocks() */
-template<typename Visitor> struct code_block_visitor {
+template<typename Fixup> struct code_block_visitor {
factor_vm *parent;
- Visitor visitor;
+ Fixup fixup;
- explicit code_block_visitor(factor_vm *parent_, Visitor visitor_) :
- parent(parent_), visitor(visitor_) {}
+ explicit code_block_visitor(factor_vm *parent_, Fixup fixup_) :
+ parent(parent_), fixup(fixup_) {}
code_block *visit_code_block(code_block *compiled);
void visit_object_code_block(object *obj);
void visit_uninitialized_code_blocks();
};
-template<typename Visitor>
-code_block *code_block_visitor<Visitor>::visit_code_block(code_block *compiled)
+template<typename Fixup>
+code_block *code_block_visitor<Fixup>::visit_code_block(code_block *compiled)
{
- return visitor(compiled);
+ return fixup.fixup_code(compiled);
}
-template<typename Visitor>
+template<typename Fixup>
struct call_frame_code_block_visitor {
factor_vm *parent;
- Visitor visitor;
+ Fixup fixup;
- explicit call_frame_code_block_visitor(factor_vm *parent_, Visitor visitor_) :
- parent(parent_), visitor(visitor_) {}
+ explicit call_frame_code_block_visitor(factor_vm *parent_, Fixup fixup_) :
+ parent(parent_), fixup(fixup_) {}
void operator()(stack_frame *frame)
{
- cell offset = (cell)FRAME_RETURN_ADDRESS(frame,parent) - (cell)frame->entry_point;
-
- code_block *new_block = visitor(parent->frame_code(frame));
- frame->entry_point = new_block->entry_point();
-
- FRAME_RETURN_ADDRESS(frame,parent) = (void *)((cell)frame->entry_point + offset);
+ cell offset = parent->frame_offset(frame);
+ code_block *compiled = fixup.fixup_code(parent->frame_code(frame));
+ frame->entry_point = compiled->entry_point();
+ parent->set_frame_offset(frame,offset);
}
};
-template<typename Visitor>
-void code_block_visitor<Visitor>::visit_object_code_block(object *obj)
+template<typename Fixup>
+void code_block_visitor<Fixup>::visit_object_code_block(object *obj)
{
switch(obj->type())
{
{
word *w = (word *)obj;
if(w->code)
- w->code = visitor(w->code);
+ w->code = visit_code_block(w->code);
if(w->profiling)
- w->profiling = visitor(w->profiling);
+ w->profiling = visit_code_block(w->profiling);
parent->update_word_entry_point(w);
break;
{
quotation *q = (quotation *)obj;
if(q->code)
- parent->set_quot_entry_point(q,visitor(q->code));
+ parent->set_quot_entry_point(q,visit_code_block(q->code));
break;
}
case CALLSTACK_TYPE:
{
callstack *stack = (callstack *)obj;
- call_frame_code_block_visitor<Visitor> call_frame_visitor(parent,visitor);
+ call_frame_code_block_visitor<Fixup> call_frame_visitor(parent,fixup);
parent->iterate_callstack_object(stack,call_frame_visitor);
break;
}
}
}
-template<typename Visitor>
+template<typename Fixup>
struct embedded_code_pointers_visitor {
- Visitor visitor;
+ Fixup fixup;
- explicit embedded_code_pointers_visitor(Visitor visitor_) : visitor(visitor_) {}
+ explicit embedded_code_pointers_visitor(Fixup fixup_) : fixup(fixup_) {}
void operator()(instruction_operand op)
{
if(type == RT_ENTRY_POINT
|| type == RT_ENTRY_POINT_PIC
|| type == RT_ENTRY_POINT_PIC_TAIL)
- op.store_code_block(visitor(op.load_code_block()));
+ op.store_code_block(fixup.fixup_code(op.load_code_block()));
}
};
-template<typename Visitor>
-void code_block_visitor<Visitor>::visit_embedded_code_pointers(code_block *compiled)
+template<typename Fixup>
+void code_block_visitor<Fixup>::visit_embedded_code_pointers(code_block *compiled)
{
if(!parent->code->uninitialized_p(compiled))
{
- embedded_code_pointers_visitor<Visitor> visitor(this->visitor);
- compiled->each_instruction_operand(visitor);
+ embedded_code_pointers_visitor<Fixup> operand_visitor(fixup);
+ compiled->each_instruction_operand(operand_visitor);
}
}
-template<typename Visitor>
-void code_block_visitor<Visitor>::visit_context_code_blocks()
+template<typename Fixup>
+void code_block_visitor<Fixup>::visit_context_code_blocks()
{
- call_frame_code_block_visitor<Visitor> call_frame_visitor(parent,visitor);
+ call_frame_code_block_visitor<Fixup> call_frame_visitor(parent,fixup);
parent->iterate_active_callstacks(call_frame_visitor);
}
-template<typename Visitor>
-void code_block_visitor<Visitor>::visit_uninitialized_code_blocks()
+template<typename Fixup>
+void code_block_visitor<Fixup>::visit_uninitialized_code_blocks()
{
std::map<code_block *, cell> *uninitialized_blocks = &parent->code->uninitialized_blocks;
std::map<code_block *, cell>::const_iterator iter = uninitialized_blocks->begin();
for(; iter != end; iter++)
{
new_uninitialized_blocks.insert(std::make_pair(
- visitor(iter->first),
+ fixup.fixup_code(iter->first),
iter->second));
}
return size;
}
+ template<typename Fixup> cell size(Fixup fixup) const
+ {
+ return size();
+ }
+
void *entry_point() const
{
return (void *)(this + 1);
}
+ /* GC info is stored at the end of the block */
+ gc_info *block_gc_info() const
+ {
+ return (gc_info *)((u8 *)this + size() - sizeof(gc_info));
+ }
+
void flush_icache()
{
factor::flush_icache((cell)this,size());
struct must_start_gc_again {};
-template<typename TargetGeneration, typename Policy> struct data_workhorse {
+template<typename TargetGeneration, typename Policy> struct gc_workhorse : no_fixup {
factor_vm *parent;
TargetGeneration *target;
Policy policy;
+ code_heap *code;
- explicit data_workhorse(factor_vm *parent_, TargetGeneration *target_, Policy policy_) :
+ explicit gc_workhorse(factor_vm *parent_, TargetGeneration *target_, Policy policy_) :
parent(parent_),
target(target_),
- policy(policy_) {}
+ policy(policy_),
+ code(parent->code) {}
object *resolve_forwarding(object *untagged)
{
return newpointer;
}
- object *operator()(object *obj)
+ object *fixup_data(object *obj)
{
+ parent->check_data_pointer(obj);
+
if(!policy.should_copy_p(obj))
{
policy.visited_object(obj);
return forwarding;
}
}
-};
-template<typename TargetGeneration, typename Policy>
-inline static slot_visitor<data_workhorse<TargetGeneration,Policy> > make_data_visitor(
- factor_vm *parent,
- TargetGeneration *target,
- Policy policy)
-{
- return slot_visitor<data_workhorse<TargetGeneration,Policy> >(parent,
- data_workhorse<TargetGeneration,Policy>(parent,target,policy));
-}
+ code_block *fixup_code(code_block *compiled)
+ {
+ if(!code->marked_p(compiled))
+ {
+ code->set_marked_p(compiled);
+ parent->mark_stack.push_back((cell)compiled + 1);
+ }
+
+ return compiled;
+ }
+};
struct dummy_unmarker {
void operator()(card *ptr) {}
data_heap *data;
code_heap *code;
TargetGeneration *target;
- slot_visitor<data_workhorse<TargetGeneration,Policy> > data_visitor;
+ gc_workhorse<TargetGeneration,Policy> workhorse;
+ slot_visitor<gc_workhorse<TargetGeneration,Policy> > data_visitor;
cell cards_scanned;
cell decks_scanned;
cell code_blocks_scanned;
data(parent_->data),
code(parent_->code),
target(target_),
- data_visitor(make_data_visitor(parent_,target_,policy_)),
+ workhorse(parent,target,policy_),
+ data_visitor(parent,workhorse),
cards_scanned(0),
decks_scanned(0),
code_blocks_scanned(0) {}
namespace factor {
-template<typename Block> struct forwarder {
- mark_bits<Block> *forwarding_map;
+struct compaction_fixup {
+ mark_bits<object> *data_forwarding_map;
+ mark_bits<code_block> *code_forwarding_map;
+ const object **data_finger;
+ const code_block **code_finger;
- explicit forwarder(mark_bits<Block> *forwarding_map_) :
- forwarding_map(forwarding_map_) {}
+ explicit compaction_fixup(
+ mark_bits<object> *data_forwarding_map_,
+ mark_bits<code_block> *code_forwarding_map_,
+ const object **data_finger_,
+ const code_block **code_finger_) :
+ data_forwarding_map(data_forwarding_map_),
+ code_forwarding_map(code_forwarding_map_),
+ data_finger(data_finger_),
+ code_finger(code_finger_) {}
- Block *operator()(Block *block)
+ object *fixup_data(object *obj)
{
- return forwarding_map->forward_block(block);
+ return data_forwarding_map->forward_block(obj);
}
-};
-
-static inline cell tuple_size_with_forwarding(mark_bits<object> *forwarding_map, object *obj)
-{
- /* The tuple layout may or may not have been forwarded already. Tricky. */
- object *layout_obj = (object *)UNTAG(((tuple *)obj)->layout);
- tuple_layout *layout;
- if(layout_obj < obj)
+ code_block *fixup_code(code_block *compiled)
{
- /* It's already been moved up; dereference through forwarding
- map to get the size */
- layout = (tuple_layout *)forwarding_map->forward_block(layout_obj);
+ return code_forwarding_map->forward_block(compiled);
}
- else
+
+ object *translate_data(const object *obj)
{
- /* It hasn't been moved up yet; dereference directly */
- layout = (tuple_layout *)layout_obj;
+ if(obj < *data_finger)
+ return fixup_data((object *)obj);
+ else
+ return (object *)obj;
}
- return tuple_size(layout);
-}
-
-struct compaction_sizer {
- mark_bits<object> *forwarding_map;
+ code_block *translate_code(const code_block *compiled)
+ {
+ if(compiled < *code_finger)
+ return fixup_code((code_block *)compiled);
+ else
+ return (code_block *)compiled;
+ }
- explicit compaction_sizer(mark_bits<object> *forwarding_map_) :
- forwarding_map(forwarding_map_) {}
+ cell size(object *obj)
+ {
+ if(data_forwarding_map->marked_p(obj))
+ return obj->size(*this);
+ else
+ return data_forwarding_map->unmarked_block_size(obj);
+ }
- cell operator()(object *obj)
+ cell size(code_block *compiled)
{
- if(!forwarding_map->marked_p(obj))
- return forwarding_map->unmarked_block_size(obj);
- else if(obj->type() == TUPLE_TYPE)
- return align(tuple_size_with_forwarding(forwarding_map,obj),data_alignment);
+ if(code_forwarding_map->marked_p(compiled))
+ return compiled->size(*this);
else
- return obj->size();
+ return code_forwarding_map->unmarked_block_size(compiled);
}
};
struct object_compaction_updater {
factor_vm *parent;
- mark_bits<code_block> *code_forwarding_map;
- mark_bits<object> *data_forwarding_map;
+ compaction_fixup fixup;
object_start_map *starts;
- explicit object_compaction_updater(factor_vm *parent_,
- mark_bits<object> *data_forwarding_map_,
- mark_bits<code_block> *code_forwarding_map_) :
+ explicit object_compaction_updater(factor_vm *parent_, compaction_fixup fixup_) :
parent(parent_),
- code_forwarding_map(code_forwarding_map_),
- data_forwarding_map(data_forwarding_map_),
+ fixup(fixup_),
starts(&parent->data->tenured->starts) {}
void operator()(object *old_address, object *new_address, cell size)
{
- cell payload_start;
- if(old_address->type() == TUPLE_TYPE)
- payload_start = tuple_size_with_forwarding(data_forwarding_map,old_address);
- else
- payload_start = old_address->binary_payload_start();
-
- memmove(new_address,old_address,size);
+ slot_visitor<compaction_fixup> slot_forwarder(parent,fixup);
+ slot_forwarder.visit_slots(new_address);
- slot_visitor<forwarder<object> > slot_forwarder(parent,forwarder<object>(data_forwarding_map));
- slot_forwarder.visit_slots(new_address,payload_start);
-
- code_block_visitor<forwarder<code_block> > code_forwarder(parent,forwarder<code_block>(code_forwarding_map));
+ code_block_visitor<compaction_fixup> code_forwarder(parent,fixup);
code_forwarder.visit_object_code_block(new_address);
starts->record_object_start_offset(new_address);
}
};
-template<typename SlotForwarder>
+template<typename Fixup>
struct code_block_compaction_relocation_visitor {
factor_vm *parent;
code_block *old_address;
- slot_visitor<SlotForwarder> slot_forwarder;
- code_block_visitor<forwarder<code_block> > code_forwarder;
+ Fixup fixup;
explicit code_block_compaction_relocation_visitor(factor_vm *parent_,
code_block *old_address_,
- slot_visitor<SlotForwarder> slot_forwarder_,
- code_block_visitor<forwarder<code_block> > code_forwarder_) :
+ Fixup fixup_) :
parent(parent_),
old_address(old_address_),
- slot_forwarder(slot_forwarder_),
- code_forwarder(code_forwarder_) {}
+ fixup(fixup_) {}
void operator()(instruction_operand op)
{
switch(op.rel_type())
{
case RT_LITERAL:
- op.store_value(slot_forwarder.visit_pointer(op.load_value(old_offset)));
- break;
+ {
+ cell value = op.load_value(old_offset);
+ if(immediate_p(value))
+ op.store_value(value);
+ else
+ op.store_value(RETAG(fixup.fixup_data(untag<object>(value)),TAG(value)));
+ break;
+ }
case RT_ENTRY_POINT:
case RT_ENTRY_POINT_PIC:
case RT_ENTRY_POINT_PIC_TAIL:
- op.store_code_block(code_forwarder.visit_code_block(op.load_code_block(old_offset)));
- break;
case RT_HERE:
- op.store_value(op.load_value(old_offset) - (cell)old_address + (cell)op.parent_code_block());
- break;
+ {
+ cell value = op.load_value(old_offset);
+ cell offset = TAG(value);
+ code_block *compiled = (code_block *)UNTAG(value);
+ op.store_value((cell)fixup.fixup_code(compiled) + offset);
+ break;
+ }
case RT_THIS:
case RT_CARDS_OFFSET:
case RT_DECKS_OFFSET:
}
};
-template<typename SlotForwarder>
+template<typename Fixup>
struct code_block_compaction_updater {
factor_vm *parent;
- slot_visitor<SlotForwarder> slot_forwarder;
- code_block_visitor<forwarder<code_block> > code_forwarder;
+ Fixup fixup;
+ slot_visitor<Fixup> data_forwarder;
+ code_block_visitor<Fixup> code_forwarder;
explicit code_block_compaction_updater(factor_vm *parent_,
- slot_visitor<SlotForwarder> slot_forwarder_,
- code_block_visitor<forwarder<code_block> > code_forwarder_) :
+ Fixup fixup_,
+ slot_visitor<Fixup> data_forwarder_,
+ code_block_visitor<Fixup> code_forwarder_) :
parent(parent_),
- slot_forwarder(slot_forwarder_),
+ fixup(fixup_),
+ data_forwarder(data_forwarder_),
code_forwarder(code_forwarder_) {}
void operator()(code_block *old_address, code_block *new_address, cell size)
{
- memmove(new_address,old_address,size);
+ data_forwarder.visit_code_block_objects(new_address);
- slot_forwarder.visit_code_block_objects(new_address);
-
- code_block_compaction_relocation_visitor<SlotForwarder> visitor(parent,old_address,slot_forwarder,code_forwarder);
+ code_block_compaction_relocation_visitor<Fixup> visitor(parent,old_address,fixup);
new_address->each_instruction_operand(visitor);
}
};
data_forwarding_map->compute_forwarding();
code_forwarding_map->compute_forwarding();
- slot_visitor<forwarder<object> > slot_forwarder(this,forwarder<object>(data_forwarding_map));
- code_block_visitor<forwarder<code_block> > code_forwarder(this,forwarder<code_block>(code_forwarding_map));
+ const object *data_finger = tenured->first_block();
+ const code_block *code_finger = code->allocator->first_block();
+
+ compaction_fixup fixup(data_forwarding_map,code_forwarding_map,&data_finger,&code_finger);
+ slot_visitor<compaction_fixup> data_forwarder(this,fixup);
+ code_block_visitor<compaction_fixup> code_forwarder(this,fixup);
code_forwarder.visit_uninitialized_code_blocks();
/* Slide everything in tenured space up, and update data and code heap
pointers inside objects. */
- object_compaction_updater object_updater(this,data_forwarding_map,code_forwarding_map);
- compaction_sizer object_sizer(data_forwarding_map);
- tenured->compact(object_updater,object_sizer);
+ object_compaction_updater object_updater(this,fixup);
+ tenured->compact(object_updater,fixup,&data_finger);
/* Slide everything in the code heap up, and update data and code heap
pointers inside code blocks. */
- code_block_compaction_updater<forwarder<object> > code_block_updater(this,slot_forwarder,code_forwarder);
- standard_sizer<code_block> code_block_sizer;
- code->allocator->compact(code_block_updater,code_block_sizer);
+ code_block_compaction_updater<compaction_fixup> code_block_updater(this,fixup,data_forwarder,code_forwarder);
+ code->allocator->compact(code_block_updater,fixup,&code_finger);
- slot_forwarder.visit_roots();
+ data_forwarder.visit_roots();
if(trace_contexts_p)
{
- slot_forwarder.visit_contexts();
+ data_forwarder.visit_contexts();
code_forwarder.visit_context_code_blocks();
}
current_gc->event->ended_compaction();
}
+struct code_compaction_fixup {
+ mark_bits<code_block> *code_forwarding_map;
+ const code_block **code_finger;
+
+ explicit code_compaction_fixup(mark_bits<code_block> *code_forwarding_map_,
+ const code_block **code_finger_) :
+ code_forwarding_map(code_forwarding_map_),
+ code_finger(code_finger_) {}
+
+ object *fixup_data(object *obj)
+ {
+ return obj;
+ }
+
+ code_block *fixup_code(code_block *compiled)
+ {
+ return code_forwarding_map->forward_block(compiled);
+ }
+
+ object *translate_data(const object *obj)
+ {
+ return fixup_data((object *)obj);
+ }
+
+ code_block *translate_code(const code_block *compiled)
+ {
+ if(compiled >= *code_finger)
+ return fixup_code((code_block *)compiled);
+ else
+ return (code_block *)compiled;
+ }
+
+ cell size(object *obj)
+ {
+ return obj->size();
+ }
+
+ cell size(code_block *compiled)
+ {
+ if(code_forwarding_map->marked_p(compiled))
+ return compiled->size(*this);
+ else
+ return code_forwarding_map->unmarked_block_size(compiled);
+ }
+};
+
struct object_grow_heap_updater {
- code_block_visitor<forwarder<code_block> > code_forwarder;
+ code_block_visitor<code_compaction_fixup> code_forwarder;
- explicit object_grow_heap_updater(code_block_visitor<forwarder<code_block> > code_forwarder_) :
+ explicit object_grow_heap_updater(code_block_visitor<code_compaction_fixup> code_forwarder_) :
code_forwarder(code_forwarder_) {}
void operator()(object *obj)
}
};
-struct dummy_slot_forwarder {
- object *operator()(object *obj) { return obj; }
-};
-
/* Compact just the code heap, after growing the data heap */
void factor_vm::collect_compact_code_impl(bool trace_contexts_p)
{
mark_bits<code_block> *code_forwarding_map = &code->allocator->state;
code_forwarding_map->compute_forwarding();
- slot_visitor<dummy_slot_forwarder> slot_forwarder(this,dummy_slot_forwarder());
- code_block_visitor<forwarder<code_block> > code_forwarder(this,forwarder<code_block>(code_forwarding_map));
+ const code_block *code_finger = code->allocator->first_block();
+
+ code_compaction_fixup fixup(code_forwarding_map,&code_finger);
+ slot_visitor<code_compaction_fixup> data_forwarder(this,fixup);
+ code_block_visitor<code_compaction_fixup> code_forwarder(this,fixup);
code_forwarder.visit_uninitialized_code_blocks();
code_forwarder.visit_context_code_blocks();
/* Update code heap references in data heap */
- object_grow_heap_updater updater(code_forwarder);
- each_object(updater);
+ object_grow_heap_updater object_updater(code_forwarder);
+ each_object(object_updater);
/* Slide everything in the code heap up, and update code heap
pointers inside code blocks. */
- code_block_compaction_updater<dummy_slot_forwarder> code_block_updater(this,slot_forwarder,code_forwarder);
- standard_sizer<code_block> code_block_sizer;
- code->allocator->compact(code_block_updater,code_block_sizer);
+ code_block_compaction_updater<code_compaction_fixup> code_block_updater(this,fixup,data_forwarder,code_forwarder);
+ code->allocator->compact(code_block_updater,fixup,&code_finger);
update_code_roots_for_compaction();
callbacks->update();
reset_retainstack();
}
+void context::scrub_stacks(gc_info *info, cell index)
+{
+ u8 *bitmap = info->gc_info_bitmap();
+
+ {
+ cell base = info->scrub_d_base(index);
+
+ for(cell loc = 0; loc < info->scrub_d_count; loc++)
+ {
+ if(bitmap_p(bitmap,base + loc))
+ {
+#ifdef DEBUG_GC_MAPS
+ std::cout << "scrubbing datastack location " << loc << std::endl;
+#endif
+ ((cell *)datastack)[-loc] = 0;
+ }
+ }
+ }
+
+ {
+ cell base = info->scrub_r_base(index);
+
+ for(cell loc = 0; loc < info->scrub_r_count; loc++)
+ {
+ if(bitmap_p(bitmap,base + loc))
+ {
+#ifdef DEBUG_GC_MAPS
+ std::cout << "scrubbing retainstack location " << loc << std::endl;
+#endif
+ ((cell *)retainstack)[-loc] = 0;
+ }
+ }
+ }
+}
+
context::~context()
{
delete datastack_seg;
void reset_context_objects();
void reset();
void fix_stacks();
+ void scrub_stacks(gc_info *info, cell index);
cell peek()
{
set_data_heap(new data_heap(young_size,aging_size,tenured_size));
}
-/* Size of the object pointed to by an untagged pointer */
-cell object::size() const
-{
- if(free_p()) return ((free_heap_block *)this)->size();
-
- switch(type())
- {
- case ARRAY_TYPE:
- return align(array_size((array*)this),data_alignment);
- case BIGNUM_TYPE:
- return align(array_size((bignum*)this),data_alignment);
- case BYTE_ARRAY_TYPE:
- return align(array_size((byte_array*)this),data_alignment);
- case STRING_TYPE:
- return align(string_size(string_capacity((string*)this)),data_alignment);
- case TUPLE_TYPE:
- {
- tuple_layout *layout = (tuple_layout *)UNTAG(((tuple *)this)->layout);
- return align(tuple_size(layout),data_alignment);
- }
- case QUOTATION_TYPE:
- return align(sizeof(quotation),data_alignment);
- case WORD_TYPE:
- return align(sizeof(word),data_alignment);
- case FLOAT_TYPE:
- return align(sizeof(boxed_float),data_alignment);
- case DLL_TYPE:
- return align(sizeof(dll),data_alignment);
- case ALIEN_TYPE:
- return align(sizeof(alien),data_alignment);
- case WRAPPER_TYPE:
- return align(sizeof(wrapper),data_alignment);
- case CALLSTACK_TYPE:
- return align(callstack_object_size(untag_fixnum(((callstack *)this)->length)),data_alignment);
- default:
- critical_error("Invalid header",(cell)this);
- return 0; /* can't happen */
- }
-}
-
-/* The number of cells from the start of the object which should be scanned by
-the GC. Some types have a binary payload at the end (string, word, DLL) which
-we ignore. */
-cell object::binary_payload_start() const
-{
- if(free_p()) return 0;
-
- switch(type())
- {
- /* these objects do not refer to other objects at all */
- case FLOAT_TYPE:
- case BYTE_ARRAY_TYPE:
- case BIGNUM_TYPE:
- case CALLSTACK_TYPE:
- return 0;
- /* these objects have some binary data at the end */
- case WORD_TYPE:
- return sizeof(word) - sizeof(cell) * 3;
- case ALIEN_TYPE:
- return sizeof(cell) * 3;
- case DLL_TYPE:
- return sizeof(cell) * 2;
- case QUOTATION_TYPE:
- return sizeof(quotation) - sizeof(cell) * 2;
- case STRING_TYPE:
- return sizeof(string);
- /* everything else consists entirely of pointers */
- case ARRAY_TYPE:
- return array_size<array>(array_capacity((array*)this));
- case TUPLE_TYPE:
- return tuple_size(untag<tuple_layout>(((tuple *)this)->layout));
- case WRAPPER_TYPE:
- return sizeof(wrapper);
- default:
- critical_error("Invalid header",(cell)this);
- return 0; /* can't happen */
- }
-}
-
data_heap_room factor_vm::data_room()
{
data_heap_room room;
--- /dev/null
+namespace factor
+{
+
+template<typename T>
+struct identity {
+ T operator()(T t)
+ {
+ return t;
+ }
+};
+
+struct no_fixup {
+ object *fixup_data(object *obj)
+ {
+ return obj;
+ }
+
+ code_block *fixup_code(code_block *compiled)
+ {
+ return compiled;
+ }
+
+ object *translate_data(const object *obj)
+ {
+ return fixup_data((object *)obj);
+ }
+
+ code_block *translate_code(const code_block *compiled)
+ {
+ return fixup_code((code_block *)compiled);
+ }
+
+ cell size(object *obj)
+ {
+ return obj->size();
+ }
+
+ cell size(code_block *compiled)
+ {
+ return compiled->size();
+ }
+};
+
+}
cell largest_free_block();
cell free_block_count();
void sweep();
- template<typename Iterator, typename Sizer> void compact(Iterator &iter, Sizer &sizer);
- template<typename Iterator, typename Sizer> void iterate(Iterator &iter, Sizer &sizer);
+ template<typename Iterator, typename Fixup> void compact(Iterator &iter, Fixup fixup, const Block **finger);
+ template<typename Iterator, typename Fixup> void iterate(Iterator &iter, Fixup fixup);
template<typename Iterator> void iterate(Iterator &iter);
};
mark_bits<Block> *state;
char *address;
Iterator &iter;
+ const Block **finger;
- explicit heap_compactor(mark_bits<Block> *state_, Block *address_, Iterator &iter_) :
- state(state_), address((char *)address_), iter(iter_) {}
+ explicit heap_compactor(mark_bits<Block> *state_, Block *address_, Iterator &iter_, const Block **finger_) :
+ state(state_), address((char *)address_), iter(iter_), finger(finger_) {}
void operator()(Block *block, cell size)
{
if(this->state->marked_p(block))
{
+ *finger = block;
+ memmove((Block *)address,block,size);
iter(block,(Block *)address,size);
address += size;
}
/* The forwarding map must be computed first by calling
state.compute_forwarding(). */
template<typename Block>
-template<typename Iterator, typename Sizer>
-void free_list_allocator<Block>::compact(Iterator &iter, Sizer &sizer)
+template<typename Iterator, typename Fixup>
+void free_list_allocator<Block>::compact(Iterator &iter, Fixup fixup, const Block **finger)
{
- heap_compactor<Block,Iterator> compactor(&state,first_block(),iter);
- iterate(compactor,sizer);
+ heap_compactor<Block,Iterator> compactor(&state,first_block(),iter,finger);
+ iterate(compactor,fixup);
/* Now update the free list; there will be a single free block at
the end */
/* During compaction we have to be careful and measure object sizes differently */
template<typename Block>
-template<typename Iterator, typename Sizer>
-void free_list_allocator<Block>::iterate(Iterator &iter, Sizer &sizer)
+template<typename Iterator, typename Fixup>
+void free_list_allocator<Block>::iterate(Iterator &iter, Fixup fixup)
{
Block *scan = first_block();
Block *end = last_block();
while(scan != end)
{
- cell size = sizer(scan);
+ cell size = fixup.size(scan);
Block *next = (Block *)((cell)scan + size);
if(!scan->free_p()) iter(scan,size);
scan = next;
}
}
-template<typename Block> struct standard_sizer {
- cell operator()(Block *block)
- {
- return block->size();
- }
-};
-
template<typename Block>
template<typename Iterator>
void free_list_allocator<Block>::iterate(Iterator &iter)
{
- standard_sizer<Block> sizer;
- iterate(iter,sizer);
+ iterate(iter,no_fixup());
}
}
namespace factor
{
-inline static code_block_visitor<code_workhorse> make_code_visitor(factor_vm *parent)
-{
- return code_block_visitor<code_workhorse>(parent,code_workhorse(parent));
-}
-
full_collector::full_collector(factor_vm *parent_) :
- collector<tenured_space,full_policy>(
- parent_,
- parent_->data->tenured,
- full_policy(parent_)),
- code_visitor(make_code_visitor(parent_)) {}
+ collector<tenured_space,full_policy>(parent_,parent_->data->tenured,full_policy(parent_)),
+ code_visitor(parent,workhorse) {}
void full_collector::trace_code_block(code_block *compiled)
{
}
};
-struct code_workhorse {
- factor_vm *parent;
- code_heap *code;
-
- explicit code_workhorse(factor_vm *parent_) : parent(parent_), code(parent->code) {}
-
- code_block *operator()(code_block *compiled)
- {
- if(!code->marked_p(compiled))
- {
- code->set_marked_p(compiled);
- parent->mark_stack.push_back((cell)compiled + 1);
- }
-
- return compiled;
- }
-};
-
struct full_collector : collector<tenured_space,full_policy> {
- code_block_visitor<code_workhorse> code_visitor;
+ code_block_visitor<gc_workhorse<tenured_space,full_policy> > code_visitor;
explicit full_collector(factor_vm *parent_);
void trace_code_block(code_block *compiled);
current_gc = NULL;
}
+/* primitive_minor_gc() is invoked by inline GC checks, and it needs to fill in
+uninitialized stack locations before actually calling the GC. See the comment
+in compiler.cfg.stacks.uninitialized for details. */
+
+struct call_frame_scrubber {
+ factor_vm *parent;
+ context *ctx;
+
+ explicit call_frame_scrubber(factor_vm *parent_, context *ctx_) :
+ parent(parent_), ctx(ctx_) {}
+
+ void operator()(stack_frame *frame)
+ {
+ cell return_address = parent->frame_offset(frame);
+ if(return_address == (cell)-1)
+ return;
+
+ code_block *compiled = parent->frame_code(frame);
+ gc_info *info = compiled->block_gc_info();
+
+ assert(return_address < compiled->size());
+ int index = info->return_address_index(return_address);
+ if(index != -1)
+ ctx->scrub_stacks(info,index);
+ }
+};
+
+void factor_vm::scrub_context(context *ctx)
+{
+ call_frame_scrubber scrubber(this,ctx);
+ iterate_callstack(ctx,scrubber);
+}
+
+void factor_vm::scrub_contexts()
+{
+ std::set<context *>::const_iterator begin = active_contexts.begin();
+ std::set<context *>::const_iterator end = active_contexts.end();
+ while(begin != end)
+ {
+ scrub_context(*begin);
+ begin++;
+ }
+}
+
void factor_vm::primitive_minor_gc()
{
+ scrub_contexts();
+
gc(collect_nursery_op,
0, /* requested size */
true /* trace contexts? */);
true /* trace contexts? */);
}
-void factor_vm::inline_gc(cell gc_roots_)
-{
- cell stack_pointer = (cell)ctx->callstack_top;
-
- if(to_boolean(gc_roots_))
- {
- tagged<array> gc_roots(gc_roots_);
-
- cell capacity = array_capacity(gc_roots.untagged());
- for(cell i = 0; i < capacity; i++)
- {
- cell spill_slot = untag_fixnum(array_nth(gc_roots.untagged(),i));
- cell *address = (cell *)(spill_slot + stack_pointer);
- data_roots.push_back(data_root_range(address,1));
- }
-
- primitive_minor_gc();
-
- for(cell i = 0; i < capacity; i++)
- data_roots.pop_back();
- }
- else
- primitive_minor_gc();
-}
-
-VM_C_API void inline_gc(cell gc_roots, factor_vm *parent)
-{
- parent->inline_gc(gc_roots);
-}
-
/*
* It is up to the caller to fill in the object's fields in a meaningful
* fashion!
void start_again(gc_op op_, factor_vm *parent);
};
-VM_C_API void inline_gc(cell gc_roots, factor_vm *parent);
-
}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+int gc_info::return_address_index(cell return_address)
+{
+ u32 *return_address_array = return_addresses();
+
+ for(cell i = 0; i < return_address_count; i++)
+ {
+ if(return_address == return_address_array[i])
+ return i;
+ }
+
+ return -1;
+}
+
+}
--- /dev/null
+namespace factor
+{
+
+struct gc_info {
+ u32 scrub_d_count;
+ u32 scrub_r_count;
+ u32 gc_root_count;
+ u32 return_address_count;
+
+ cell total_bitmap_size()
+ {
+ return return_address_count * (scrub_d_count + scrub_r_count + gc_root_count);
+ }
+
+ cell total_bitmap_bytes()
+ {
+ return ((total_bitmap_size() + 7) / 8);
+ }
+
+ u32 *return_addresses()
+ {
+ return (u32 *)((u8 *)this - return_address_count * sizeof(u32));
+ }
+
+ u8 *gc_info_bitmap()
+ {
+ return (u8 *)return_addresses() - total_bitmap_bytes();
+ }
+
+ cell scrub_d_base(cell index)
+ {
+ return index * scrub_d_count;
+ }
+
+ cell scrub_r_base(cell index)
+ {
+ return return_address_count * scrub_d_count +
+ index * scrub_r_count;
+ }
+
+ cell spill_slot_base(cell index)
+ {
+ return return_address_count * scrub_d_count
+ + return_address_count * scrub_r_count
+ + index * gc_root_count;
+ }
+
+ int return_address_index(cell return_address);
+};
+
+}
code->allocator->initial_free_list(h->code_size);
}
-struct data_fixupper {
- cell offset;
+struct startup_fixup {
+ cell data_offset;
+ cell code_offset;
- explicit data_fixupper(cell offset_) : offset(offset_) {}
+ explicit startup_fixup(cell data_offset_, cell code_offset_) :
+ data_offset(data_offset_), code_offset(code_offset_) {}
- object *operator()(object *obj)
+ object *fixup_data(object *obj)
{
- return (object *)((char *)obj + offset);
+ return (object *)((cell)obj + data_offset);
}
-};
-
-struct code_fixupper {
- cell offset;
-
- explicit code_fixupper(cell offset_) : offset(offset_) {}
- code_block *operator()(code_block *compiled)
+ code_block *fixup_code(code_block *obj)
{
- return (code_block *)((char *)compiled + offset);
+ return (code_block *)((cell)obj + code_offset);
}
-};
-static inline cell tuple_size_with_fixup(cell offset, object *obj)
-{
- tuple_layout *layout = (tuple_layout *)((char *)UNTAG(((tuple *)obj)->layout) + offset);
- return tuple_size(layout);
-}
+ object *translate_data(const object *obj)
+ {
+ return fixup_data((object *)obj);
+ }
-struct fixup_sizer {
- cell offset;
+ code_block *translate_code(const code_block *compiled)
+ {
+ return fixup_code((code_block *)compiled);
+ }
- explicit fixup_sizer(cell offset_) : offset(offset_) {}
+ cell size(const object *obj)
+ {
+ return obj->size(*this);
+ }
- cell operator()(object *obj)
+ cell size(code_block *compiled)
{
- if(obj->type() == TUPLE_TYPE)
- return align(tuple_size_with_fixup(offset,obj),data_alignment);
- else
- return obj->size();
+ return compiled->size(*this);
}
};
-struct object_fixupper {
+struct start_object_updater {
factor_vm *parent;
- cell data_offset;
- slot_visitor<data_fixupper> data_visitor;
- code_block_visitor<code_fixupper> code_visitor;
+ startup_fixup fixup;
+ slot_visitor<startup_fixup> data_visitor;
+ code_block_visitor<startup_fixup> code_visitor;
- object_fixupper(factor_vm *parent_, cell data_offset_, cell code_offset_) :
+ start_object_updater(factor_vm *parent_, startup_fixup fixup_) :
parent(parent_),
- data_offset(data_offset_),
- data_visitor(slot_visitor<data_fixupper>(parent_,data_fixupper(data_offset_))),
- code_visitor(code_block_visitor<code_fixupper>(parent_,code_fixupper(code_offset_))) {}
+ fixup(fixup_),
+ data_visitor(slot_visitor<startup_fixup>(parent_,fixup_)),
+ code_visitor(code_block_visitor<startup_fixup>(parent_,fixup_)) {}
void operator()(object *obj, cell size)
{
parent->data->tenured->starts.record_object_start_offset(obj);
+ data_visitor.visit_slots(obj);
+
switch(obj->type())
{
case ALIEN_TYPE:
{
- cell payload_start = obj->binary_payload_start();
- data_visitor.visit_slots(obj,payload_start);
alien *ptr = (alien *)obj;
}
case DLL_TYPE:
{
- cell payload_start = obj->binary_payload_start();
- data_visitor.visit_slots(obj,payload_start);
-
parent->ffi_dlopen((dll *)obj);
break;
}
- case TUPLE_TYPE:
- {
- cell payload_start = tuple_size_with_fixup(data_offset,obj);
- data_visitor.visit_slots(obj,payload_start);
- break;
- }
default:
{
- cell payload_start = obj->binary_payload_start();
- data_visitor.visit_slots(obj,payload_start);
code_visitor.visit_object_code_block(obj);
break;
}
void factor_vm::fixup_data(cell data_offset, cell code_offset)
{
- slot_visitor<data_fixupper> data_workhorse(this,data_fixupper(data_offset));
+ startup_fixup fixup(data_offset,code_offset);
+ slot_visitor<startup_fixup> data_workhorse(this,fixup);
data_workhorse.visit_roots();
- object_fixupper fixupper(this,data_offset,code_offset);
- fixup_sizer sizer(data_offset);
- data->tenured->iterate(fixupper,sizer);
+ start_object_updater updater(this,fixup);
+ data->tenured->iterate(updater,fixup);
}
-struct code_block_fixup_relocation_visitor {
+struct startup_code_block_relocation_visitor {
factor_vm *parent;
- cell code_offset;
- slot_visitor<data_fixupper> data_visitor;
- code_fixupper code_visitor;
+ startup_fixup fixup;
+ slot_visitor<startup_fixup> data_visitor;
- code_block_fixup_relocation_visitor(factor_vm *parent_, cell data_offset_, cell code_offset_) :
+ startup_code_block_relocation_visitor(factor_vm *parent_, startup_fixup fixup_) :
parent(parent_),
- code_offset(code_offset_),
- data_visitor(slot_visitor<data_fixupper>(parent_,data_fixupper(data_offset_))),
- code_visitor(code_fixupper(code_offset_)) {}
+ fixup(fixup_),
+ data_visitor(slot_visitor<startup_fixup>(parent_,fixup_)) {}
void operator()(instruction_operand op)
{
code_block *compiled = op.parent_code_block();
- cell old_offset = op.rel_offset() + (cell)compiled->entry_point() - code_offset;
+ cell old_offset = op.rel_offset() + (cell)compiled->entry_point() - fixup.code_offset;
switch(op.rel_type())
{
case RT_LITERAL:
- op.store_value(data_visitor.visit_pointer(op.load_value(old_offset)));
- break;
+ {
+ cell value = op.load_value(old_offset);
+ if(immediate_p(value))
+ op.store_value(value);
+ else
+ op.store_value(RETAG(fixup.fixup_data(untag<object>(value)),TAG(value)));
+ break;
+ }
case RT_ENTRY_POINT:
case RT_ENTRY_POINT_PIC:
case RT_ENTRY_POINT_PIC_TAIL:
- op.store_code_block(code_visitor(op.load_code_block(old_offset)));
- break;
case RT_HERE:
- op.store_value(op.load_value(old_offset) + code_offset);
- break;
+ {
+ cell value = op.load_value(old_offset);
+ cell offset = TAG(value);
+ code_block *compiled = (code_block *)UNTAG(value);
+ op.store_value((cell)fixup.fixup_code(compiled) + offset);
+ break;
+ }
case RT_UNTAGGED:
break;
default:
}
};
-struct code_block_fixupper {
+struct startup_code_block_updater {
factor_vm *parent;
- cell data_offset;
- cell code_offset;
+ startup_fixup fixup;
- code_block_fixupper(factor_vm *parent_, cell data_offset_, cell code_offset_) :
- parent(parent_),
- data_offset(data_offset_),
- code_offset(code_offset_) {}
+ startup_code_block_updater(factor_vm *parent_, startup_fixup fixup_) :
+ parent(parent_), fixup(fixup_) {}
void operator()(code_block *compiled, cell size)
{
- slot_visitor<data_fixupper> data_visitor(parent,data_fixupper(data_offset));
+ slot_visitor<startup_fixup> data_visitor(parent,fixup);
data_visitor.visit_code_block_objects(compiled);
- code_block_fixup_relocation_visitor code_visitor(parent,data_offset,code_offset);
+ startup_code_block_relocation_visitor code_visitor(parent,fixup);
compiled->each_instruction_operand(code_visitor);
}
};
void factor_vm::fixup_code(cell data_offset, cell code_offset)
{
- code_block_fixupper fixupper(this,data_offset,code_offset);
- code->allocator->iterate(fixupper);
+ startup_fixup fixup(data_offset,code_offset);
+ startup_code_block_updater updater(this,fixup);
+ code->allocator->iterate(updater,fixup);
}
/* Read an image file from disk, only done once during startup */
/* Allocates memory */
code_block *jit::to_code_block()
{
+ /* Emit dummy GC info */
+ code.grow_bytes(alignment_for(code.count + 4,data_alignment));
+ u32 dummy_gc_info = 0;
+ code.append_bytes(&dummy_gc_info,sizeof(u32));
+
code.trim();
relocation.trim();
parameters.trim();
return (a + (b-1)) & ~(b-1);
}
+inline static cell alignment_for(cell a, cell b)
+{
+ return align(a,b) - a;
+}
+
static const cell data_alignment = 16;
#define WORD_SIZE (signed)(sizeof(cell)*8)
cell header;
cell size() const;
+ template<typename Fixup> cell size(Fixup fixup) const;
+
cell binary_payload_start() const;
+ template<typename Fixup> cell binary_payload_start(Fixup fixup) const;
cell *slots() const { return (cell *)this; }
forwarding = NULL;
}
- cell block_line(Block *address)
+ cell block_line(const Block *address)
{
return (((cell)address - start) / data_alignment);
}
return (Block *)(line * data_alignment + start);
}
- std::pair<cell,cell> bitmap_deref(Block *address)
+ std::pair<cell,cell> bitmap_deref(const Block *address)
{
cell line_number = block_line(address);
cell word_index = (line_number / mark_bits_granularity);
return std::make_pair(word_index,word_shift);
}
- bool bitmap_elt(cell *bits, Block *address)
+ bool bitmap_elt(cell *bits, const Block *address)
{
std::pair<cell,cell> position = bitmap_deref(address);
return (bits[position.first] & ((cell)1 << position.second)) != 0;
}
- Block *next_block_after(Block *block)
+ Block *next_block_after(const Block *block)
{
return (Block *)((cell)block + block->size());
}
- void set_bitmap_range(cell *bits, Block *address)
+ void set_bitmap_range(cell *bits, const Block *address)
{
std::pair<cell,cell> start = bitmap_deref(address);
std::pair<cell,cell> end = bitmap_deref(next_block_after(address));
}
}
- bool marked_p(Block *address)
+ bool marked_p(const Block *address)
{
return bitmap_elt(marked,address);
}
- void set_marked_p(Block *address)
+ void set_marked_p(const Block *address)
{
set_bitmap_range(marked,address);
}
/* We have the popcount for every mark_bits_granularity entries; look
up and compute the rest */
- Block *forward_block(Block *original)
+ Block *forward_block(const Block *original)
{
#ifdef FACTOR_DEBUG
assert(marked_p(original));
return new_block;
}
- Block *next_unmarked_block_after(Block *original)
+ Block *next_unmarked_block_after(const Block *original)
{
std::pair<cell,cell> position = bitmap_deref(original);
cell bit_index = position.second;
return (Block *)(this->start + this->size);
}
- Block *next_marked_block_after(Block *original)
+ Block *next_marked_block_after(const Block *original)
{
std::pair<cell,cell> position = bitmap_deref(original);
cell bit_index = position.second;
#include "platform.hpp"
#include "primitives.hpp"
#include "segments.hpp"
+#include "gc_info.hpp"
#include "contexts.hpp"
#include "run.hpp"
#include "objects.hpp"
#include "bitwise_hacks.hpp"
#include "mark_bits.hpp"
#include "free_list.hpp"
+#include "fixup.hpp"
+#include "tuples.hpp"
#include "free_list_allocator.hpp"
#include "write_barrier.hpp"
#include "object_start_map.hpp"
#include "gc.hpp"
#include "debug.hpp"
#include "strings.hpp"
-#include "tuples.hpp"
#include "words.hpp"
#include "float_bits.hpp"
#include "io.hpp"
#include "data_roots.hpp"
#include "code_roots.hpp"
#include "generic_arrays.hpp"
+#include "callstack.hpp"
#include "slot_visitor.hpp"
#include "collector.hpp"
#include "copying_collector.hpp"
#include "code_block_visitor.hpp"
#include "compaction.hpp"
#include "full_collector.hpp"
-#include "callstack.hpp"
#include "arrays.hpp"
#include "math.hpp"
#include "byte_arrays.hpp"
ctx->push(allot_cell(object_size(ctx->pop())));
}
-struct slot_become_visitor {
+struct slot_become_fixup : no_fixup {
std::map<object *,object *> *become_map;
- explicit slot_become_visitor(std::map<object *,object *> *become_map_) :
+ explicit slot_become_fixup(std::map<object *,object *> *become_map_) :
become_map(become_map_) {}
- object *operator()(object *old)
+ object *fixup_data(object *old)
{
std::map<object *,object *>::const_iterator iter = become_map->find(old);
if(iter != become_map->end())
};
struct object_become_visitor {
- slot_visitor<slot_become_visitor> *workhorse;
+ slot_visitor<slot_become_fixup> *workhorse;
- explicit object_become_visitor(slot_visitor<slot_become_visitor> *workhorse_) :
+ explicit object_become_visitor(slot_visitor<slot_become_fixup> *workhorse_) :
workhorse(workhorse_) {}
void operator()(object *obj)
};
struct code_block_become_visitor {
- slot_visitor<slot_become_visitor> *workhorse;
+ slot_visitor<slot_become_fixup> *workhorse;
- explicit code_block_become_visitor(slot_visitor<slot_become_visitor> *workhorse_) :
+ explicit code_block_become_visitor(slot_visitor<slot_become_fixup> *workhorse_) :
workhorse(workhorse_) {}
void operator()(code_block *compiled, cell size)
/* Update all references to old objects to point to new objects */
{
- slot_visitor<slot_become_visitor> workhorse(this,slot_become_visitor(&become_map));
+ slot_visitor<slot_become_fixup> workhorse(this,slot_become_fixup(&become_map));
workhorse.visit_roots();
workhorse.visit_contexts();
namespace factor
{
+/* Size of the object pointed to by an untagged pointer */
+template<typename Fixup>
+cell object::size(Fixup fixup) const
+{
+ if(free_p()) return ((free_heap_block *)this)->size();
+
+ switch(type())
+ {
+ case ARRAY_TYPE:
+ return align(array_size((array*)this),data_alignment);
+ case BIGNUM_TYPE:
+ return align(array_size((bignum*)this),data_alignment);
+ case BYTE_ARRAY_TYPE:
+ return align(array_size((byte_array*)this),data_alignment);
+ case STRING_TYPE:
+ return align(string_size(string_capacity((string*)this)),data_alignment);
+ case TUPLE_TYPE:
+ {
+ tuple_layout *layout = (tuple_layout *)fixup.translate_data(untag<object>(((tuple *)this)->layout));
+ return align(tuple_size(layout),data_alignment);
+ }
+ case QUOTATION_TYPE:
+ return align(sizeof(quotation),data_alignment);
+ case WORD_TYPE:
+ return align(sizeof(word),data_alignment);
+ case FLOAT_TYPE:
+ return align(sizeof(boxed_float),data_alignment);
+ case DLL_TYPE:
+ return align(sizeof(dll),data_alignment);
+ case ALIEN_TYPE:
+ return align(sizeof(alien),data_alignment);
+ case WRAPPER_TYPE:
+ return align(sizeof(wrapper),data_alignment);
+ case CALLSTACK_TYPE:
+ return align(callstack_object_size(untag_fixnum(((callstack *)this)->length)),data_alignment);
+ default:
+ critical_error("Invalid header in size",(cell)this);
+ return 0; /* can't happen */
+ }
+}
+
+inline cell object::size() const
+{
+ return size(no_fixup());
+}
+
+/* The number of cells from the start of the object which should be scanned by
+the GC. Some types have a binary payload at the end (string, word, DLL) which
+we ignore. */
+template<typename Fixup>
+cell object::binary_payload_start(Fixup fixup) const
+{
+ if(free_p()) return 0;
+
+ switch(type())
+ {
+ /* these objects do not refer to other objects at all */
+ case FLOAT_TYPE:
+ case BYTE_ARRAY_TYPE:
+ case BIGNUM_TYPE:
+ case CALLSTACK_TYPE:
+ return 0;
+ /* these objects have some binary data at the end */
+ case WORD_TYPE:
+ return sizeof(word) - sizeof(cell) * 3;
+ case ALIEN_TYPE:
+ return sizeof(cell) * 3;
+ case DLL_TYPE:
+ return sizeof(cell) * 2;
+ case QUOTATION_TYPE:
+ return sizeof(quotation) - sizeof(cell) * 2;
+ case STRING_TYPE:
+ return sizeof(string);
+ /* everything else consists entirely of pointers */
+ case ARRAY_TYPE:
+ return array_size<array>(array_capacity((array*)this));
+ case TUPLE_TYPE:
+ {
+ tuple_layout *layout = (tuple_layout *)fixup.translate_data(untag<object>(((tuple *)this)->layout));
+ return tuple_size(layout);
+ }
+ case WRAPPER_TYPE:
+ return sizeof(wrapper);
+ default:
+ critical_error("Invalid header in binary_payload_start",(cell)this);
+ return 0; /* can't happen */
+ }
+}
+
+inline cell object::binary_payload_start() const
+{
+ return binary_payload_start(no_fixup());
+}
+
/* Slot visitors iterate over the slots of an object, applying a functor to
each one that is a non-immediate slot. The pointer is untagged first. The
functor returns a new untagged object pointer. The return value may or may not equal the old one,
- visit_roots()
- visit_contexts() */
-template<typename Visitor> struct slot_visitor {
+template<typename Fixup> struct slot_visitor {
factor_vm *parent;
- Visitor visitor;
+ Fixup fixup;
- explicit slot_visitor<Visitor>(factor_vm *parent_, Visitor visitor_) :
- parent(parent_), visitor(visitor_) {}
+ explicit slot_visitor<Fixup>(factor_vm *parent_, Fixup fixup_) :
+ parent(parent_), fixup(fixup_) {}
cell visit_pointer(cell pointer);
void visit_handle(cell *handle);
void visit_callback_roots();
void visit_literal_table_roots();
void visit_roots();
+ void visit_callstack_object(callstack *stack);
+ void visit_callstack(context *ctx);
void visit_contexts();
void visit_code_block_objects(code_block *compiled);
void visit_embedded_literals(code_block *compiled);
};
-template<typename Visitor>
-cell slot_visitor<Visitor>::visit_pointer(cell pointer)
+template<typename Fixup>
+cell slot_visitor<Fixup>::visit_pointer(cell pointer)
{
if(immediate_p(pointer)) return pointer;
- object *untagged = untag<object>(pointer);
- untagged = visitor(untagged);
+ object *untagged = fixup.fixup_data(untag<object>(pointer));
return RETAG(untagged,TAG(pointer));
}
-template<typename Visitor>
-void slot_visitor<Visitor>::visit_handle(cell *handle)
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_handle(cell *handle)
{
*handle = visit_pointer(*handle);
}
-template<typename Visitor>
-void slot_visitor<Visitor>::visit_object_array(cell *start, cell *end)
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_object_array(cell *start, cell *end)
{
while(start < end) visit_handle(start++);
}
-template<typename Visitor>
-void slot_visitor<Visitor>::visit_slots(object *ptr, cell payload_start)
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_slots(object *ptr, cell payload_start)
{
cell *slot = (cell *)ptr;
cell *end = (cell *)((cell)ptr + payload_start);
}
}
-template<typename Visitor>
-void slot_visitor<Visitor>::visit_slots(object *ptr)
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_slots(object *obj)
{
- visit_slots(ptr,ptr->binary_payload_start());
+ if(obj->type() == CALLSTACK_TYPE)
+ visit_callstack_object((callstack *)obj);
+ else
+ visit_slots(obj,obj->binary_payload_start(fixup));
}
-template<typename Visitor>
-void slot_visitor<Visitor>::visit_stack_elements(segment *region, cell *top)
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_stack_elements(segment *region, cell *top)
{
visit_object_array((cell *)region->start,top + 1);
}
-template<typename Visitor>
-void slot_visitor<Visitor>::visit_data_roots()
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_data_roots()
{
std::vector<data_root_range>::const_iterator iter = parent->data_roots.begin();
std::vector<data_root_range>::const_iterator end = parent->data_roots.end();
visit_object_array(iter->start,iter->start + iter->len);
}
-template<typename Visitor>
-void slot_visitor<Visitor>::visit_bignum_roots()
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_bignum_roots()
{
std::vector<cell>::const_iterator iter = parent->bignum_roots.begin();
std::vector<cell>::const_iterator end = parent->bignum_roots.end();
cell *handle = (cell *)(*iter);
if(*handle)
- *handle = (cell)visitor(*(object **)handle);
+ *handle = (cell)fixup.fixup_data(*(object **)handle);
}
}
-template<typename Visitor>
+template<typename Fixup>
struct callback_slot_visitor {
callback_heap *callbacks;
- slot_visitor<Visitor> *visitor;
+ slot_visitor<Fixup> *visitor;
- explicit callback_slot_visitor(callback_heap *callbacks_, slot_visitor<Visitor> *visitor_) :
+ explicit callback_slot_visitor(callback_heap *callbacks_, slot_visitor<Fixup> *visitor_) :
callbacks(callbacks_), visitor(visitor_) {}
void operator()(code_block *stub)
}
};
-template<typename Visitor>
-void slot_visitor<Visitor>::visit_callback_roots()
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_callback_roots()
{
- callback_slot_visitor<Visitor> callback_visitor(parent->callbacks,this);
+ callback_slot_visitor<Fixup> callback_visitor(parent->callbacks,this);
parent->callbacks->each_callback(callback_visitor);
}
-template<typename Visitor>
-void slot_visitor<Visitor>::visit_literal_table_roots()
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_literal_table_roots()
{
std::map<code_block *, cell> *uninitialized_blocks = &parent->code->uninitialized_blocks;
std::map<code_block *, cell>::const_iterator iter = uninitialized_blocks->begin();
parent->code->uninitialized_blocks = new_uninitialized_blocks;
}
-template<typename Visitor>
-void slot_visitor<Visitor>::visit_roots()
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_roots()
{
visit_handle(&parent->true_object);
visit_handle(&parent->bignum_zero);
visit_object_array(parent->special_objects,parent->special_objects + special_object_count);
}
-template<typename Visitor>
-void slot_visitor<Visitor>::visit_contexts()
+template<typename Fixup>
+struct call_frame_slot_visitor {
+ factor_vm *parent;
+ slot_visitor<Fixup> *visitor;
+
+ explicit call_frame_slot_visitor(factor_vm *parent_, slot_visitor<Fixup> *visitor_) :
+ parent(parent_), visitor(visitor_) {}
+
+ /*
+ next -> [entry_point]
+ [size]
+ [return address] -- x86 only, backend adds 1 to each spill location
+ [spill area]
+ ...
+ frame -> [entry_point]
+ [size]
+ */
+ void operator()(stack_frame *frame)
+ {
+ cell return_address = parent->frame_offset(frame);
+ if(return_address == (cell)-1)
+ return;
+
+ code_block *compiled = visitor->fixup.translate_code(parent->frame_code(frame));
+ gc_info *info = compiled->block_gc_info();
+
+ assert(return_address < compiled->size());
+ int index = info->return_address_index(return_address);
+ if(index == -1)
+ return;
+
+#ifdef DEBUG_GC_MAPS
+ std::cout << "call frame code block " << compiled << " with offset " << return_address << std::endl;
+#endif
+ u8 *bitmap = info->gc_info_bitmap();
+ cell base = info->spill_slot_base(index);
+ cell *stack_pointer = (cell *)(parent->frame_successor(frame) + 1);
+
+ for(cell spill_slot = 0; spill_slot < info->gc_root_count; spill_slot++)
+ {
+ if(bitmap_p(bitmap,base + spill_slot))
+ {
+#ifdef DEBUG_GC_MAPS
+ std::cout << "visiting spill slot " << spill_slot << std::endl;
+#endif
+ visitor->visit_handle(&stack_pointer[spill_slot]);
+ }
+ }
+ }
+};
+
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_callstack_object(callstack *stack)
+{
+ call_frame_slot_visitor<Fixup> call_frame_visitor(parent,this);
+ parent->iterate_callstack_object(stack,call_frame_visitor);
+}
+
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_callstack(context *ctx)
+{
+ call_frame_slot_visitor<Fixup> call_frame_visitor(parent,this);
+ parent->iterate_callstack(ctx,call_frame_visitor);
+}
+
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_contexts()
{
std::set<context *>::const_iterator begin = parent->active_contexts.begin();
std::set<context *>::const_iterator end = parent->active_contexts.end();
visit_stack_elements(ctx->datastack_seg,(cell *)ctx->datastack);
visit_stack_elements(ctx->retainstack_seg,(cell *)ctx->retainstack);
visit_object_array(ctx->context_objects,ctx->context_objects + context_object_count);
-
+ visit_callstack(ctx);
begin++;
}
}
-template<typename Visitor>
+template<typename Fixup>
struct literal_references_visitor {
- slot_visitor<Visitor> *visitor;
+ slot_visitor<Fixup> *visitor;
- explicit literal_references_visitor(slot_visitor<Visitor> *visitor_) : visitor(visitor_) {}
+ explicit literal_references_visitor(slot_visitor<Fixup> *visitor_) : visitor(visitor_) {}
void operator()(instruction_operand op)
{
}
};
-template<typename Visitor>
-void slot_visitor<Visitor>::visit_code_block_objects(code_block *compiled)
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_code_block_objects(code_block *compiled)
{
visit_handle(&compiled->owner);
visit_handle(&compiled->parameters);
visit_handle(&compiled->relocation);
}
-template<typename Visitor>
-void slot_visitor<Visitor>::visit_embedded_literals(code_block *compiled)
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_embedded_literals(code_block *compiled)
{
if(!parent->code->uninitialized_p(compiled))
{
- literal_references_visitor<Visitor> visitor(this);
+ literal_references_visitor<Fixup> visitor(this);
compiled->each_instruction_operand(visitor);
}
}
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 scrub_context(context *ctx);
+ void scrub_contexts();
void primitive_minor_gc();
void primitive_full_gc();
void primitive_compact_gc();
- void inline_gc(cell gc_roots);
void primitive_enable_gc_events();
void primitive_disable_gc_events();
object *allot_object(cell type, cell size);
cell frame_executing_quot(stack_frame *frame);
stack_frame *frame_successor(stack_frame *frame);
cell frame_scan(stack_frame *frame);
+ cell frame_offset(stack_frame *frame);
+ void set_frame_offset(stack_frame *frame, cell offset);
void primitive_callstack_to_array();
stack_frame *innermost_stack_frame(callstack *stack);
void primitive_innermost_stack_frame_executing();
projects / factor.git / commitdiff