Merge branch 'master' of git://factorcode.org/git/factor
Anton Gorenko
commit
507583c8d3
|
|
@ -102,7 +102,7 @@ M: #alien-invoke emit-node
|
|||
[
|
||||
{
|
||||
[ 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
|
||||
|
|
@ -111,7 +111,7 @@ M: #alien-invoke emit-node
|
|||
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
|
||||
|
|
|
|||
|
|
@ -105,13 +105,13 @@ M: struct-c-type flatten-parameter-type frob-struct flatten-c-type ;
|
|||
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 )
|
||||
|
|
|
|||
|
|
@ -1,15 +1,17 @@
|
|||
! 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
|
||||
|
|
|
|||
|
|
@ -42,13 +42,12 @@ V{
|
|||
|
||||
[
|
||||
V{
|
||||
T{ ##gc-map f V{ 0 } V{ 3 } { 0 1 2 } }
|
||||
T{ ##call-gc }
|
||||
T{ ##call-gc f T{ gc-map } }
|
||||
T{ ##branch }
|
||||
}
|
||||
]
|
||||
[
|
||||
V{ D 0 R 3 } { 0 1 2 } <gc-call> instructions>>
|
||||
<gc-call> instructions>>
|
||||
] unit-test
|
||||
|
||||
30 \ vreg-counter set-global
|
||||
|
|
@ -82,7 +81,7 @@ V{
|
|||
|
||||
[ ] [ 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
|
||||
|
||||
|
|
@ -146,8 +145,7 @@ H{
|
|||
|
||||
[
|
||||
V{
|
||||
T{ ##gc-map f V{ 0 1 2 } V{ } { 2 } }
|
||||
T{ ##call-gc }
|
||||
T{ ##call-gc f T{ gc-map } }
|
||||
T{ ##branch }
|
||||
}
|
||||
] [ 2 get predecessors>> second instructions>> ] unit-test
|
||||
|
|
|
|||
|
|
@ -9,10 +9,7 @@ compiler.cfg.registers
|
|||
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
|
||||
|
|
@ -50,12 +47,9 @@ IN: compiler.cfg.gc-checks
|
|||
] bi*
|
||||
] V{ } make >>instructions ;
|
||||
|
||||
: scrubbed ( uninitialized-locs -- scrub-d scrub-r )
|
||||
[ ds-loc? ] partition [ [ n>> ] map ] bi@ ;
|
||||
|
||||
: <gc-call> ( uninitialized-locs gc-roots -- bb )
|
||||
[ <basic-block> ] 2dip
|
||||
[ [ scrubbed ] dip ##gc-map ##call-gc ##branch ] V{ } make
|
||||
: <gc-call> ( -- bb )
|
||||
<basic-block>
|
||||
[ <gc-map> ##call-gc ##branch ] V{ } make
|
||||
>>instructions t >>unlikely? ;
|
||||
|
||||
:: insert-guard ( body check bb -- )
|
||||
|
|
@ -69,7 +63,7 @@ IN: compiler.cfg.gc-checks
|
|||
|
||||
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 )
|
||||
|
|
@ -85,35 +79,17 @@ M: ##box-displaced-alien allocation-size* drop 5 cells ;
|
|||
[ ##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 ;
|
||||
|
|
|
|||
|
|
@ -670,27 +670,28 @@ literal: size align offset ;
|
|||
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 ;
|
||||
|
|
@ -819,10 +820,7 @@ INSN: ##check-nursery-branch
|
|||
literal: size cc
|
||||
temp: temp1/int-rep temp2/int-rep ;
|
||||
|
||||
INSN: ##call-gc ;
|
||||
|
||||
INSN: ##gc-map
|
||||
literal: scrub-d scrub-r gc-roots ;
|
||||
INSN: ##call-gc literal: gc-map ;
|
||||
|
||||
! Spills and reloads, inserted by register allocator
|
||||
TUPLE: spill-slot { n integer } ;
|
||||
|
|
@ -860,6 +858,23 @@ UNION: conditional-branch-insn
|
|||
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
|
||||
|
|
|
|||
|
|
@ -142,8 +142,10 @@ RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
|
|||
M: vreg-insn assign-registers-in-insn
|
||||
[ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
|
||||
|
||||
M: ##gc-map assign-registers-in-insn
|
||||
[ [ 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,25 +1,40 @@
|
|||
! 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 ;
|
||||
|
|
|
|||
|
|
@ -182,7 +182,7 @@ V{
|
|||
|
||||
V{
|
||||
T{ ##save-context f 77 78 }
|
||||
T{ ##call-gc f { } }
|
||||
T{ ##call-gc f T{ gc-map } }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
|
|
|
|||
|
|
@ -29,8 +29,8 @@ V{
|
|||
|
||||
[ ] [ 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,
|
||||
|
|
@ -57,4 +57,4 @@ V{
|
|||
|
||||
[ ] [ test-uninitialized ] unit-test
|
||||
|
||||
[ V{ D 0 } ] [ 3 get uninitialized-locs ] unit-test
|
||||
[ { B{ 0 } B{ } } ] [ 3 get uninitialized-in ] unit-test
|
||||
|
|
|
|||
|
|
@ -9,11 +9,17 @@ IN: compiler.cfg.stacks.uninitialized
|
|||
|
||||
! 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
|
||||
|
||||
|
|
@ -28,7 +34,6 @@ GENERIC: visit-insn ( insn -- )
|
|||
] 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 ;
|
||||
|
|
@ -46,6 +51,12 @@ M: ##peek visit-insn visit-peek ;
|
|||
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 -- )
|
||||
|
|
@ -59,9 +70,6 @@ M: insn visit-insn drop ;
|
|||
: (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
|
||||
|
|
@ -71,11 +79,3 @@ M: uninitialized-analysis transfer-set ( pair bb analysis -- pair' )
|
|||
|
||||
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 f like
|
||||
] when ;
|
||||
|
|
|
|||
|
|
@ -258,7 +258,6 @@ CODEGEN: ##restore-context %restore-context
|
|||
CODEGEN: ##vm-field %vm-field
|
||||
CODEGEN: ##set-vm-field %set-vm-field
|
||||
CODEGEN: ##alien-global %alien-global
|
||||
CODEGEN: ##gc-map %gc-map
|
||||
CODEGEN: ##call-gc %call-gc
|
||||
CODEGEN: ##spill %spill
|
||||
CODEGEN: ##reload %reload
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
USING: namespaces byte-arrays make compiler.codegen.fixup
|
||||
bit-arrays accessors classes.struct tools.test kernel math
|
||||
sequences alien.c-types specialized-arrays boxes ;
|
||||
sequences alien.c-types specialized-arrays boxes
|
||||
compiler.cfg.instructions system cpu.architecture ;
|
||||
SPECIALIZED-ARRAY: uint
|
||||
IN: compiler.codegen.fixup.tests
|
||||
|
||||
|
|
@ -10,19 +11,23 @@ STRUCT: gc-info
|
|||
{ 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> %
|
||||
|
||||
{ { } { } { } } set-next-gc-map
|
||||
gc-map-here
|
||||
T{ gc-map f B{ } B{ } V{ } } gc-map-here
|
||||
|
||||
50 <byte-array> %
|
||||
|
||||
{ { 0 4 } { 1 } { 1 3 } } set-next-gc-map
|
||||
gc-map-here
|
||||
T{ gc-map f B{ 0 1 1 1 0 } B{ 1 0 } V{ 1 3 } } gc-map-here
|
||||
|
||||
emit-gc-info
|
||||
] B{ } make
|
||||
|
|
|
|||
|
|
@ -4,8 +4,9 @@ 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.smart accessors growable fry compiler.constants
|
||||
memoize boxes ;
|
||||
combinators.short-circuit combinators.smart accessors growable
|
||||
fry memoize compiler.constants compiler.cfg.instructions
|
||||
cpu.architecture ;
|
||||
IN: compiler.codegen.fixup
|
||||
|
||||
! Utilities
|
||||
|
|
@ -149,30 +150,37 @@ MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
|
|||
! uint <largest GC root spill slot>
|
||||
! uint <number of return addresses>
|
||||
|
||||
SYMBOLS: next-gc-map return-addresses gc-maps ;
|
||||
SYMBOLS: return-addresses gc-maps ;
|
||||
|
||||
: gc-map? ( triple -- ? )
|
||||
: 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.
|
||||
[ empty? not ] any? ;
|
||||
dup [
|
||||
{
|
||||
[ scrub-d>> empty? ]
|
||||
[ scrub-r>> empty? ]
|
||||
[ gc-roots>> empty? ]
|
||||
} 1&& not
|
||||
] when ;
|
||||
|
||||
: gc-map-here ( -- )
|
||||
next-gc-map get box> dup gc-map? [
|
||||
: gc-map-here ( gc-map -- )
|
||||
dup gc-map-needed? [
|
||||
gc-maps get push
|
||||
compiled-offset return-addresses get push
|
||||
] [ drop ] if ;
|
||||
|
||||
: set-next-gc-map ( gc-map -- ) next-gc-map get >box ;
|
||||
: 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-bitmap ( seqs -- n )
|
||||
: emit-gc-roots ( seqs -- n )
|
||||
! seqs is a sequence of sequences of integers 0..n-1
|
||||
[ 0 ] [
|
||||
dup [ [ 0 ] [ supremum 1 + ] if-empty ] [ max ] map-reduce
|
||||
[ '[ _ integers>bits % ] each ] keep
|
||||
] if-empty ;
|
||||
dup [ [ 0 ] [ supremum 1 + ] if-empty ] [ max ] map-reduce
|
||||
[ '[ _ integers>bits % ] each ] keep ;
|
||||
|
||||
: emit-uint ( n -- )
|
||||
building get push-uint ;
|
||||
|
|
@ -182,9 +190,9 @@ SYMBOLS: next-gc-map return-addresses gc-maps ;
|
|||
return-addresses get empty? [ 0 emit-uint ] [
|
||||
gc-maps get
|
||||
[
|
||||
[ [ first ] map emit-bitmap ]
|
||||
[ [ second ] map emit-bitmap ]
|
||||
[ [ third ] map emit-bitmap ] tri
|
||||
[ [ 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@
|
||||
|
|
@ -208,12 +216,10 @@ SYMBOLS: next-gc-map return-addresses gc-maps ;
|
|||
BV{ } clone relocation-table set
|
||||
V{ } clone binary-literal-table set
|
||||
V{ } clone return-addresses set
|
||||
V{ } clone gc-maps set
|
||||
<box> next-gc-map set ;
|
||||
V{ } clone gc-maps set ;
|
||||
|
||||
: check-fixup ( seq -- )
|
||||
length data-alignment get mod 0 assert=
|
||||
next-gc-map get occupied>> f assert= ;
|
||||
length data-alignment get mod 0 assert= ;
|
||||
|
||||
: with-fixup ( quot -- code )
|
||||
'[
|
||||
|
|
|
|||
|
|
@ -225,6 +225,8 @@ M: object vm-stack-space 0 ;
|
|||
! %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 -- )
|
||||
|
|
@ -488,8 +490,7 @@ HOOK: %write-barrier-imm cpu ( src slot tag temp1 temp2 -- )
|
|||
|
||||
! GC checks
|
||||
HOOK: %check-nursery-branch cpu ( label size cc temp1 temp2 -- )
|
||||
HOOK: %gc-map cpu ( scrub-d scrub-r gc-roots -- )
|
||||
HOOK: %call-gc cpu ( -- )
|
||||
HOOK: %call-gc cpu ( gc-map -- )
|
||||
|
||||
HOOK: %prologue cpu ( n -- )
|
||||
HOOK: %epilogue cpu ( n -- )
|
||||
|
|
@ -595,11 +596,11 @@ HOOK: %local-allot cpu ( dst size align offset -- )
|
|||
! 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 -- )
|
||||
|
||||
|
|
@ -609,13 +610,13 @@ HOOK: %prepare-var-args cpu ( -- )
|
|||
|
||||
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 -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -134,7 +134,7 @@ M: x86.32 %store-reg-param ( src reg rep -- )
|
|||
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
|
||||
|
|
@ -146,36 +146,37 @@ M:: x86.32 %unbox-long-long ( src out 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
|
||||
|
|
@ -183,7 +184,7 @@ M: x86.32 %alien-callback ( quot -- )
|
|||
|
||||
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 -- )
|
||||
|
||||
|
|
@ -198,13 +199,13 @@ M:: register 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 -- ? )
|
||||
|
|
|
|||
|
|
@ -63,6 +63,9 @@ IN: bootstrap.x86
|
|||
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
|
||||
|
|
@ -130,6 +133,7 @@ IN: bootstrap.x86
|
|||
|
||||
! Unwind stack frames
|
||||
ESP EDX MOV
|
||||
0 jit-scrub-return
|
||||
|
||||
jit-jump-quot
|
||||
] \ unwind-native-frames define-sub-primitive
|
||||
|
|
@ -252,9 +256,7 @@ IN: bootstrap.x86
|
|||
|
||||
! Contexts
|
||||
: jit-switch-context ( reg -- )
|
||||
! Dummy return address -- it never gets returned to but it
|
||||
! must point to inside the current code block
|
||||
ESP -4 [+] HEX: ffffffff MOV rc-absolute-cell rt-this jit-rel
|
||||
-4 jit-scrub-return
|
||||
|
||||
! Save ds, rs registers
|
||||
jit-load-vm
|
||||
|
|
|
|||
|
|
@ -90,30 +90,29 @@ M:: x86.64 %store-reg-param ( src reg rep -- )
|
|||
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
|
||||
|
|
@ -121,14 +120,14 @@ M: x86.64 %alien-callback ( quot -- )
|
|||
|
||||
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 -- )
|
||||
|
|
@ -136,7 +135,7 @@ 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 long-long-on-stack? f ;
|
||||
|
|
|
|||
|
|
@ -61,6 +61,9 @@ IN: bootstrap.x86
|
|||
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
|
||||
|
|
@ -111,6 +114,7 @@ IN: bootstrap.x86
|
|||
|
||||
! Unwind stack frames
|
||||
RSP arg2 MOV
|
||||
0 jit-scrub-return
|
||||
|
||||
! Load VM pointer into vm-reg, since we're entering from
|
||||
! C code
|
||||
|
|
@ -228,10 +232,7 @@ IN: bootstrap.x86
|
|||
|
||||
! Contexts
|
||||
: jit-switch-context ( reg -- )
|
||||
! Dummy return address -- it never gets returned to but it
|
||||
! must point to inside the current code block
|
||||
R11 0 [RIP+] LEA
|
||||
RSP -8 [+] R11 MOV
|
||||
-8 jit-scrub-return
|
||||
|
||||
! Save ds, rs registers
|
||||
jit-save-context
|
||||
|
|
|
|||
|
|
@ -480,13 +480,10 @@ M:: x86 %check-nursery-branch ( label size cc temp1 temp2 -- )
|
|||
{ cc/<= [ label JG ] }
|
||||
} case ;
|
||||
|
||||
: gc-root-offsets ( seq -- seq' )
|
||||
M: x86 gc-root-offsets
|
||||
[ n>> spill-offset special-offset cell + cell /i ] map f like ;
|
||||
|
||||
M: x86 %gc-map ( scrub-d scrub-r gc-roots -- )
|
||||
gc-root-offsets 3array set-next-gc-map ;
|
||||
|
||||
M: x86 %call-gc
|
||||
M: x86 %call-gc ( gc-map -- )
|
||||
\ minor-gc %call
|
||||
gc-map-here ;
|
||||
|
||||
|
|
@ -612,8 +609,8 @@ M:: x86 %load-stack-param ( dst n rep -- )
|
|||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -34,6 +34,10 @@ ARTICLE: "network-connection" "Connection-oriented networking"
|
|||
<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>
|
||||
|
|
@ -215,3 +219,17 @@ HELP: send
|
|||
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" }
|
||||
} ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,4 @@
|
|||
USING: math.vectors.simd math.vectors.simd.cords tools.test ;
|
||||
IN: math.vectors.simd.cords.tests
|
||||
|
||||
[ float-4{ 1.0 2.0 3.0 4.0 } ] [ double-4{ 1.0 2.0 3.0 4.0 } >float-4 ] unit-test
|
||||
|
|
@ -28,8 +28,8 @@ BOA-EFFECT [ N 2 * "n" <array> { "v" } <effect> ]
|
|||
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
|
||||
|
|
|
|||
|
|
@ -226,7 +226,9 @@ M: object pprint-object ( obj -- )
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! 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
|
||||
|
|
@ -47,57 +47,62 @@ M: T cord-append
|
|||
[ [ 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
|
||||
|
|
|
|||
|
|
@ -2,8 +2,7 @@ IN: tools.disassembler.udis.tests
|
|||
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
|
||||
|
|
@ -67,7 +67,11 @@ STRUCT: ud
|
|||
{ 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 ) ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
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 ;
|
||||
|
|
@ -9,3 +10,24 @@ M: typed-lambda-word definer drop \ TYPED:: \ ; ;
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
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 )
|
||||
|
|
@ -24,14 +24,17 @@ TYPED: dee ( x: tweedle-dee -- y )
|
|||
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 + ;
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ locals.parser macros stack-checker.dependencies ;
|
|||
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 ;
|
||||
|
||||
|
|
@ -28,9 +28,6 @@ PREDICATE: typed-word < word "typed-word" word-prop >boolean ;
|
|||
: 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 ]
|
||||
|
|
@ -47,7 +44,7 @@ PREDICATE: typed-word < word "typed-word" word-prop >boolean ;
|
|||
|
||||
:: 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ $nl
|
|||
$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"
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
||||
|
|
@ -0,0 +1,45 @@
|
|||
! (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
|
||||
|
|
@ -0,0 +1,49 @@
|
|||
! (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
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Generate integer handle values to allow Factor object references to be passed through the FFI
|
||||
|
|
@ -19,6 +19,16 @@ TUPLE: oid { a initial: 0 } { b initial: 0 } ;
|
|||
|
||||
TUPLE: dbref ref id db ;
|
||||
|
||||
TUPLE: mongo-timestamp incr seconds ;
|
||||
|
||||
: <mongo-timestamp> ( incr seconds -- mongo-timestamp )
|
||||
mongo-timestamp boa ;
|
||||
|
||||
TUPLE: mongo-scoped-code code object ;
|
||||
|
||||
: <mongo-scoped-code> ( code object -- mongo-scoped-code )
|
||||
mongo-scoped-code boa ;
|
||||
|
||||
CONSTRUCTOR: dbref ( ref id -- dbref ) ;
|
||||
|
||||
: dbref>assoc ( dbref -- assoc )
|
||||
|
|
@ -47,30 +57,31 @@ TUPLE: mdbregexp { regexp string } { options string } ;
|
|||
CONSTANT: MDB_OID_FIELD "_id"
|
||||
CONSTANT: MDB_META_FIELD "_mfd"
|
||||
|
||||
CONSTANT: T_EOO 0
|
||||
CONSTANT: T_Double 1
|
||||
CONSTANT: T_Integer 16
|
||||
CONSTANT: T_Boolean 8
|
||||
CONSTANT: T_String 2
|
||||
CONSTANT: T_Object 3
|
||||
CONSTANT: T_Array 4
|
||||
CONSTANT: T_Binary 5
|
||||
CONSTANT: T_Undefined 6
|
||||
CONSTANT: T_OID 7
|
||||
CONSTANT: T_Date 9
|
||||
CONSTANT: T_NULL 10
|
||||
CONSTANT: T_Regexp 11
|
||||
CONSTANT: T_DBRef 12
|
||||
CONSTANT: T_Code 13
|
||||
CONSTANT: T_ScopedCode 17
|
||||
CONSTANT: T_Symbol 14
|
||||
CONSTANT: T_JSTypeMax 16
|
||||
CONSTANT: T_MaxKey 127
|
||||
|
||||
CONSTANT: T_Binary_Function 1
|
||||
CONSTANT: T_Binary_Bytes 2
|
||||
CONSTANT: T_Binary_UUID 3
|
||||
CONSTANT: T_Binary_MD5 5
|
||||
CONSTANT: T_Binary_Custom 128
|
||||
CONSTANT: T_EOO 0
|
||||
CONSTANT: T_Double HEX: 1
|
||||
CONSTANT: T_String HEX: 2
|
||||
CONSTANT: T_Object HEX: 3
|
||||
CONSTANT: T_Array HEX: 4
|
||||
CONSTANT: T_Binary HEX: 5
|
||||
CONSTANT: T_Undefined HEX: 6
|
||||
CONSTANT: T_OID HEX: 7
|
||||
CONSTANT: T_Boolean HEX: 8
|
||||
CONSTANT: T_Date HEX: 9
|
||||
CONSTANT: T_NULL HEX: A
|
||||
CONSTANT: T_Regexp HEX: B
|
||||
CONSTANT: T_DBRef HEX: C
|
||||
CONSTANT: T_Code HEX: D
|
||||
CONSTANT: T_Symbol HEX: E
|
||||
CONSTANT: T_ScopedCode HEX: F
|
||||
CONSTANT: T_Integer HEX: 10
|
||||
CONSTANT: T_Timestamp HEX: 11
|
||||
CONSTANT: T_Integer64 HEX: 12
|
||||
CONSTANT: T_MinKey HEX: FF
|
||||
CONSTANT: T_MaxKey HEX: 7F
|
||||
|
||||
CONSTANT: T_Binary_Function HEX: 1
|
||||
CONSTANT: T_Binary_Bytes HEX: 2
|
||||
CONSTANT: T_Binary_UUID HEX: 3
|
||||
CONSTANT: T_Binary_MD5 HEX: 5
|
||||
CONSTANT: T_Binary_Custom HEX: 80
|
||||
|
||||
|
|
|
|||
|
|
@ -10,65 +10,46 @@ FROM: typed => TYPED: ;
|
|||
|
||||
IN: bson.reader
|
||||
|
||||
SYMBOL: state
|
||||
|
||||
DEFER: stream>assoc
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: element { type integer } name ;
|
||||
DEFER: read-elements
|
||||
|
||||
TUPLE: state
|
||||
{ size initial: -1 }
|
||||
{ exemplar assoc }
|
||||
result
|
||||
{ scope vector }
|
||||
{ elements vector } ;
|
||||
|
||||
TYPED: (prepare-elements) ( -- elements-vector: vector )
|
||||
V{ } clone [ T_Object "" element boa swap push ] [ ] bi ; inline
|
||||
|
||||
: <state> ( exemplar -- state )
|
||||
[ state new ] dip
|
||||
{
|
||||
[ clone >>exemplar ]
|
||||
[ clone >>result ]
|
||||
[ V{ } clone [ push ] keep >>scope ]
|
||||
} cleave
|
||||
(prepare-elements) >>elements ;
|
||||
|
||||
TYPED: get-state ( -- state: state )
|
||||
state get ; inline
|
||||
|
||||
TYPED: read-int32 ( -- int32: integer )
|
||||
: read-int32 ( -- int32 )
|
||||
4 read signed-le> ; inline
|
||||
|
||||
TYPED: read-longlong ( -- longlong: integer )
|
||||
: read-longlong ( -- longlong )
|
||||
8 read signed-le> ; inline
|
||||
|
||||
TYPED: read-double ( -- double: float )
|
||||
: read-double ( -- double )
|
||||
8 read le> bits>double ; inline
|
||||
|
||||
TYPED: read-byte-raw ( -- byte-raw: byte-array )
|
||||
: read-byte-raw ( -- byte-raw )
|
||||
1 read ; inline
|
||||
|
||||
TYPED: read-byte ( -- byte: integer )
|
||||
: read-byte ( -- byte )
|
||||
read-byte-raw first ; inline
|
||||
|
||||
TYPED: read-cstring ( -- string: string )
|
||||
: read-cstring ( -- string )
|
||||
"\0" read-until drop >string ; inline
|
||||
|
||||
TYPED: read-sized-string ( length: integer -- string: string )
|
||||
: read-sized-string ( length -- string )
|
||||
read 1 head-slice* >string ; inline
|
||||
|
||||
TYPED: push-element ( type: integer name: string state: state -- )
|
||||
[ element boa ] dip elements>> push ; inline
|
||||
: read-timestamp ( -- timestamp )
|
||||
8 read [ 4 head signed-le> ] [ 4 tail signed-le> ] bi <mongo-timestamp> ;
|
||||
|
||||
TYPED: pop-element ( state: state -- element: element )
|
||||
elements>> pop ; inline
|
||||
: object-result ( quot -- object )
|
||||
[
|
||||
state get clone
|
||||
[ clear-assoc ] [ ] [ ] tri state
|
||||
] dip with-variable ; inline
|
||||
|
||||
TYPED: peek-scope ( state: state -- ht )
|
||||
scope>> last ; inline
|
||||
|
||||
: bson-object-data-read ( -- object )
|
||||
read-int32 drop get-state
|
||||
[ exemplar>> clone dup ] [ scope>> ] bi push ; inline
|
||||
: bson-object-data-read ( -- )
|
||||
read-int32 drop read-elements ; inline recursive
|
||||
|
||||
: bson-binary-read ( -- binary )
|
||||
read-int32 read-byte
|
||||
|
|
@ -86,68 +67,35 @@ TYPED: bson-regexp-read ( -- mdbregexp: mdbregexp )
|
|||
TYPED: bson-oid-read ( -- oid: oid )
|
||||
read-longlong read-int32 oid boa ; inline
|
||||
|
||||
TYPED: element-data-read ( type: integer -- object )
|
||||
{
|
||||
{ T_OID [ bson-oid-read ] }
|
||||
{ T_String [ read-int32 read-sized-string ] }
|
||||
{ T_Integer [ read-int32 ] }
|
||||
{ T_Binary [ bson-binary-read ] }
|
||||
{ T_Object [ bson-object-data-read ] }
|
||||
{ T_Array [ bson-object-data-read ] }
|
||||
{ T_Double [ read-double ] }
|
||||
{ T_Boolean [ read-byte 1 = ] }
|
||||
{ T_Date [ read-longlong millis>timestamp ] }
|
||||
{ T_Regexp [ bson-regexp-read ] }
|
||||
{ T_NULL [ f ] }
|
||||
} case ; inline
|
||||
|
||||
TYPED: bson-array? ( type: integer -- ?: boolean )
|
||||
T_Array = ; inline
|
||||
|
||||
TYPED: bson-object? ( type: integer -- ?: boolean )
|
||||
T_Object = ; inline
|
||||
|
||||
: check-object ( assoc -- object )
|
||||
dup dbref-assoc? [ assoc>dbref ] when ; inline
|
||||
|
||||
TYPED: fix-result ( assoc type: integer -- result )
|
||||
TYPED: element-data-read ( type: integer -- object )
|
||||
{
|
||||
{ T_Array [ values ] }
|
||||
{ T_Object [ check-object ] }
|
||||
} case ; inline
|
||||
{ T_OID [ bson-oid-read ] }
|
||||
{ T_String [ read-int32 read-sized-string ] }
|
||||
{ T_Integer [ read-int32 ] }
|
||||
{ T_Integer64 [ read-longlong ] }
|
||||
{ T_Binary [ bson-binary-read ] }
|
||||
{ T_Object [ [ bson-object-data-read ] object-result check-object ] }
|
||||
{ T_Array [ [ bson-object-data-read ] object-result values ] }
|
||||
{ T_Double [ read-double ] }
|
||||
{ T_Boolean [ read-byte 1 = ] }
|
||||
{ T_Date [ read-longlong millis>timestamp ] }
|
||||
{ T_Regexp [ bson-regexp-read ] }
|
||||
{ T_Timestamp [ read-timestamp ] }
|
||||
{ T_Code [ read-int32 read-sized-string ] }
|
||||
{ T_ScopedCode [ read-int32 drop read-cstring H{ } clone stream>assoc <mongo-scoped-code> ] }
|
||||
{ T_NULL [ f ] }
|
||||
} case ; inline recursive
|
||||
|
||||
TYPED: end-element ( type: integer -- )
|
||||
{ [ bson-object? ] [ bson-array? ] } 1||
|
||||
[ get-state pop-element drop ] unless ; inline
|
||||
|
||||
TYPED: (>state<) ( -- state: state scope: vector element: element )
|
||||
get-state [ ] [ scope>> ] [ pop-element ] tri ; inline
|
||||
|
||||
TYPED: (prepare-result) ( scope: vector element: element -- result )
|
||||
[ pop ] [ type>> ] bi* fix-result ; inline
|
||||
|
||||
: bson-eoo-element-read ( -- cont?: boolean )
|
||||
(>state<)
|
||||
[ (prepare-result) ] [ ] [ drop empty? ] 2tri
|
||||
[ 2drop >>result drop f ]
|
||||
[ swap [ name>> ] [ last ] bi* set-at drop t ] if ; inline
|
||||
|
||||
TYPED: (prepare-object) ( type: integer -- object )
|
||||
[ element-data-read ] [ end-element ] bi ; inline
|
||||
|
||||
:: (read-object) ( type name state -- )
|
||||
state peek-scope :> scope
|
||||
type (prepare-object) name scope set-at ; inline
|
||||
|
||||
TYPED: bson-not-eoo-element-read ( type: integer -- cont?: boolean )
|
||||
read-cstring get-state
|
||||
[ push-element ]
|
||||
[ (read-object) t ] 3bi ; inline
|
||||
TYPED: (read-object) ( type: integer name: string -- )
|
||||
[ element-data-read ] dip state get set-at ; inline recursive
|
||||
|
||||
TYPED: (element-read) ( type: integer -- cont?: boolean )
|
||||
dup T_EOO >
|
||||
[ bson-not-eoo-element-read ]
|
||||
[ drop bson-eoo-element-read ] if ; inline
|
||||
[ read-cstring (read-object) t ]
|
||||
[ drop f ] if ; inline recursive
|
||||
|
||||
: read-elements ( -- )
|
||||
read-byte (element-read)
|
||||
|
|
@ -156,6 +104,6 @@ TYPED: (element-read) ( type: integer -- cont?: boolean )
|
|||
PRIVATE>
|
||||
|
||||
: stream>assoc ( exemplar -- assoc )
|
||||
<state> read-int32 >>size
|
||||
[ state [ read-elements ] with-variable ]
|
||||
[ result>> ] bi ;
|
||||
clone [
|
||||
state [ bson-object-data-read ] with-variable
|
||||
] keep ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! 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
|
||||
|
||||
<<
|
||||
|
|
@ -267,5 +267,21 @@ FUNCTION: GLint gluUnProject ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdo
|
|||
! 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 ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! 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 ;
|
||||
|
|
@ -12,7 +12,7 @@ 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
|
||||
|
|
@ -59,7 +59,7 @@ FROM: pop3 => count delete ;
|
|||
[ ] [
|
||||
<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
|
||||
|
|
|
|||
|
|
@ -59,6 +59,7 @@
|
|||
(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)")
|
||||
|
|
@ -101,6 +102,9 @@
|
|||
(,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)
|
||||
|
|
@ -111,6 +115,11 @@
|
|||
(,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)
|
||||
|
|
@ -124,6 +133,7 @@
|
|||
(,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)
|
||||
|
|
|
|||
|
|
@ -47,10 +47,10 @@
|
|||
'(":" "::" ";" "&:" "<<" "<PRIVATE" ">>"
|
||||
"ABOUT:" "AFTER:" "ALIAS:" "ALIEN:" "ARTICLE:"
|
||||
"B" "BEFORE:" "BIN:"
|
||||
"C:" "CALLBACK:" "ENUM:" "C-TYPE:" "CHAR:" "COM-INTERFACE:" "CONSTANT:" "CONSULT:" "call-next-method"
|
||||
"DEFER:"
|
||||
"EBNF:" ";EBNF" "ERROR:" "EXCLUDE:"
|
||||
"f" "FORGET:" "FROM:" "FUNCTION:"
|
||||
"C:" "CALLBACK:" "C-GLOBAL:" "C-TYPE:" "CHAR:" "COM-INTERFACE:" "CONSTANT:" "CONSULT:" "call-next-method"
|
||||
"DEFER:" "DESTRUCTOR:"
|
||||
"EBNF:" ";EBNF" "ENUM:" "ERROR:" "EXCLUDE:"
|
||||
"f" "FORGET:" "FROM:" "FUNCTION:" "FUNCTION-ALIAS:"
|
||||
"GAME:" "GENERIC#" "GENERIC:"
|
||||
"GLSL-SHADER:" "GLSL-PROGRAM:"
|
||||
"HELP:" "HEX:" "HOOK:"
|
||||
|
|
@ -135,6 +135,9 @@
|
|||
(fuel-syntax--second-word-regex
|
||||
'("C-STRUCT:" "C-UNION:" "COM-INTERFACE:" "MIXIN:" "TUPLE:" "SINGLETON:" "SPECIALIZED-ARRAY:" "STRUCT:" "UNION:" "UNION-STRUCT:")))
|
||||
|
||||
(defconst fuel-syntax--error-regex
|
||||
(fuel-syntax--second-word-regex '("ERROR:")))
|
||||
|
||||
(defconst fuel-syntax--tuple-decl-regex
|
||||
"^TUPLE: +\\([^ \n]+\\) +< +\\([^ \n]+\\)\\_>")
|
||||
|
||||
|
|
@ -158,15 +161,19 @@
|
|||
(defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$")
|
||||
|
||||
(defconst fuel-syntax--alien-function-regex
|
||||
"\\_<FUNCTION: \\(\\w+\\) \\(\\w+\\)")
|
||||
"\\_<FUNCTION: +\\(\\w+\\)[\n ]+\\(\\w+\\)")
|
||||
|
||||
(defconst fuel-syntax--alien-function-alias-regex
|
||||
"\\_<FUNCTION-ALIAS: +\\(\\w+\\)[\n ]+\\(\\w+\\)[\n ]+\\(\\w+\\)")
|
||||
|
||||
(defconst fuel-syntax--alien-callback-regex
|
||||
"\\_<CALLBACK: \\(\\w+\\) \\(\\w+\\)")
|
||||
"\\_<CALLBACK: +\\(\\w+\\) +\\(\\w+\\)")
|
||||
|
||||
(defconst fuel-syntax--indent-def-starts '("" ":"
|
||||
"AFTER" "BEFORE"
|
||||
"ENUM" "COM-INTERFACE" "CONSULT"
|
||||
"FROM" "FUNCTION:"
|
||||
"COM-INTERFACE" "CONSULT"
|
||||
"ENUM" "ERROR"
|
||||
"FROM" "FUNCTION:" "FUNCTION-ALIAS:"
|
||||
"INTERSECTION:"
|
||||
"M" "M:" "MACRO" "MACRO:"
|
||||
"MEMO" "MEMO:" "METHOD"
|
||||
|
|
@ -197,10 +204,10 @@
|
|||
(defconst fuel-syntax--single-liner-regex
|
||||
(regexp-opt '("ABOUT:"
|
||||
"ALIAS:"
|
||||
"CONSTANT:" "C:" "C-TYPE:"
|
||||
"DEFER:"
|
||||
"CONSTANT:" "C:" "C-GLOBAL:" "C-TYPE:"
|
||||
"DEFER:" "DESTRUCTOR:"
|
||||
"FORGET:"
|
||||
"GAME:" "GENERIC:" "GENERIC#" "GLSL-PROGRAM:"
|
||||
"GAME:" "GENERIC:" "GENERIC#" "GLSL-PROGRAM:"
|
||||
"HEX:" "HOOK:"
|
||||
"IN:" "INSTANCE:"
|
||||
"LIBRARY:"
|
||||
|
|
@ -242,6 +249,12 @@
|
|||
(defconst fuel-syntax--typedef-regex
|
||||
"\\_<TYPEDEF: +\\(\\w+\\) +\\(\\w+\\)\\( .*\\)?$")
|
||||
|
||||
(defconst fuel-syntax--c-global-regex
|
||||
"\\_<C-GLOBAL: +\\(\\w+\\) +\\(\\w+\\)\\( .*\\)?$")
|
||||
|
||||
(defconst fuel-syntax--c-type-regex
|
||||
"\\_<C-TYPE: +\\(\\w+\\)\\( .*\\)?$")
|
||||
|
||||
(defconst fuel-syntax--rename-regex
|
||||
"\\_<RENAME: +\\(\\w+\\) +\\(\\w+\\) +=> +\\(\\w+\\)\\( .*\\)?$")
|
||||
|
||||
|
|
|
|||
|
|
@ -108,7 +108,25 @@ stack_frame *factor_vm::frame_successor(stack_frame *frame)
|
|||
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))
|
||||
|
|
@ -120,13 +138,7 @@ cell factor_vm::frame_scan(stack_frame *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;
|
||||
}
|
||||
|
|
@ -138,11 +150,6 @@ cell factor_vm::frame_scan(stack_frame *frame)
|
|||
}
|
||||
}
|
||||
|
||||
cell factor_vm::frame_offset(stack_frame *frame)
|
||||
{
|
||||
return (cell)FRAME_RETURN_ADDRESS(frame,this) - (cell)frame_code(frame)->entry_point();
|
||||
}
|
||||
|
||||
struct stack_frame_accumulator {
|
||||
factor_vm *parent;
|
||||
growable_array frames;
|
||||
|
|
@ -209,9 +216,9 @@ void factor_vm::primitive_set_innermost_stack_frame_quot()
|
|||
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()
|
||||
|
|
|
|||
|
|
@ -42,13 +42,10 @@ struct call_frame_code_block_visitor {
|
|||
|
||||
void operator()(stack_frame *frame)
|
||||
{
|
||||
code_block *old_block = parent->frame_code(frame);
|
||||
cell offset = (char *)FRAME_RETURN_ADDRESS(frame,parent) - (char *)old_block;
|
||||
|
||||
const code_block *new_block = fixup.fixup_code(old_block);
|
||||
frame->entry_point = new_block->entry_point();
|
||||
|
||||
FRAME_RETURN_ADDRESS(frame,parent) = (char *)new_block + 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);
|
||||
}
|
||||
};
|
||||
|
||||
|
|
|
|||
|
|
@ -43,6 +43,8 @@ template<typename TargetGeneration, typename Policy> struct gc_workhorse : no_fi
|
|||
|
||||
object *fixup_data(object *obj)
|
||||
{
|
||||
parent->check_data_pointer(obj);
|
||||
|
||||
if(!policy.should_copy_p(obj))
|
||||
{
|
||||
policy.visited_object(obj);
|
||||
|
|
|
|||
|
|
@ -65,7 +65,12 @@ void context::scrub_stacks(gc_info *info, cell 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;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -75,7 +80,12 @@ void context::scrub_stacks(gc_info *info, cell 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;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -164,7 +164,7 @@ template<typename Block, typename Iterator> struct heap_compactor {
|
|||
{
|
||||
if(this->state->marked_p(block))
|
||||
{
|
||||
*finger = block;
|
||||
*finger = (Block *)((char *)block + size);
|
||||
memmove((Block *)address,block,size);
|
||||
iter(block,(Block *)address,size);
|
||||
address += size;
|
||||
|
|
|
|||
|
|
@ -207,13 +207,15 @@ struct call_frame_scrubber {
|
|||
|
||||
void operator()(stack_frame *frame)
|
||||
{
|
||||
const code_block *compiled = parent->frame_code(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();
|
||||
|
||||
cell return_address = parent->frame_offset(frame);
|
||||
assert(return_address < compiled->size());
|
||||
int index = info->return_address_index(return_address);
|
||||
|
||||
if(index != -1)
|
||||
ctx->scrub_stacks(info,index);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -284,22 +284,33 @@ struct call_frame_slot_visitor {
|
|||
*/
|
||||
void operator()(stack_frame *frame)
|
||||
{
|
||||
const code_block *compiled = visitor->fixup.translate_code(parent->frame_code(frame));
|
||||
gc_info *info = compiled->block_gc_info();
|
||||
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;
|
||||
|
||||
if(index != -1)
|
||||
#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++)
|
||||
{
|
||||
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))
|
||||
{
|
||||
if(bitmap_p(bitmap,base + spill_slot))
|
||||
visitor->visit_handle(&stack_pointer[spill_slot]);
|
||||
#ifdef DEBUG_GC_MAPS
|
||||
std::cout << "visiting spill slot " << spill_slot << std::endl;
|
||||
#endif
|
||||
visitor->visit_handle(&stack_pointer[spill_slot]);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -597,6 +597,7 @@ struct factor_vm
|
|||
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();
|
||||
|
|
|
|||
Loading…
Reference in New Issue