vm/math.o \
vm/nursery_collector.o \
vm/object_start_map.o \
+ vm/objects.o \
vm/primitives.o \
vm/profiler.o \
vm/quotations.o \
USING: kernel sequences words fry generic accessors
classes.tuple classes classes.algebra definitions
stack-checker.state quotations classes.tuple.private math
-math.partial-dispatch math.private math.intervals
+math.partial-dispatch math.private math.intervals sets.private
math.floats.private math.integers.private layouts math.order
vectors hashtables combinators effects generalizations assocs
sets combinators.short-circuit sequences.private locals
] [ drop f ] if ;
\ at* [ at-quot ] 1 define-partial-eval
+
+: diff-quot ( seq -- quot: ( seq' -- seq'' ) )
+ tester '[ [ @ not ] filter ] ;
+
+\ diff [ diff-quot ] 1 define-partial-eval
+
+: intersect-quot ( seq -- quot: ( seq' -- seq'' ) )
+ tester '[ _ filter ] ;
+
+\ intersect [ intersect-quot ] 1 define-partial-eval
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators grouping kernel locals math
-math.matrices math.order multiline sequence-parser sequences
+math.matrices math.order multiline sequences.parser sequences
tools.continuations ;
IN: compression.run-length
HELP: ffi-error.
{ $error-description "Thrown by " { $link dlopen } " and " { $link dlsym } " if a problem occurs while loading a native library or looking up a symbol. See " { $link "alien" } "." } ;
-HELP: heap-scan-error.
-{ $error-description "Thrown if " { $link next-object } " is called outside of a " { $link begin-scan } "/" { $link end-scan } " pair." } ;
-
HELP: undefined-symbol-error.
{ $error-description "Thrown if a previously-compiled " { $link alien-invoke } " call refers to a native library symbol which no longer exists." } ;
: ffi-error. ( obj -- )
"FFI error" print drop ;
-: heap-scan-error. ( obj -- )
- "Cannot do next-object outside begin/end-scan" print drop ;
-
: undefined-symbol-error. ( obj -- )
"The image refers to a library or symbol that was not found at load time"
print drop ;
{ 6 [ array-size-error. ] }
{ 7 [ c-string-error. ] }
{ 8 [ ffi-error. ] }
- { 9 [ heap-scan-error. ] }
- { 10 [ undefined-symbol-error. ] }
- { 11 [ datastack-underflow. ] }
- { 12 [ datastack-overflow. ] }
- { 13 [ retainstack-underflow. ] }
- { 14 [ retainstack-overflow. ] }
- { 15 [ memory-error. ] }
- { 16 [ fp-trap-error. ] }
+ { 9 [ undefined-symbol-error. ] }
+ { 10 [ datastack-underflow. ] }
+ { 11 [ datastack-overflow. ] }
+ { 12 [ retainstack-underflow. ] }
+ { 13 [ retainstack-overflow. ] }
+ { 14 [ memory-error. ] }
+ { 15 [ fp-trap-error. ] }
} ; inline
M: vm-error summary drop "VM error" ;
}
{ $description "Takes an existing hashtable and uses " { $link histogram } " to continue counting the number of occurences of each element." } ;
+HELP: sorted-histogram
+{ $values
+ { "seq" sequence }
+ { "alist" "an array of key/value pairs" }
+}
+{ $description "Outputs a " { $link histogram } " of a sequence sorted by number of occurences from lowest to highest." }
+{ $examples
+ { $example "USING: prettyprint math.statistics ;"
+ """"abababbbbbbc" sorted-histogram ."""
+ "{ { 99 1 } { 97 3 } { 98 8 } }"
+ }
+} ;
+
HELP: sequence>assoc
{ $values
{ "seq" sequence } { "quot" quotation } { "exemplar" "an exemplar assoc" }
{ $subsections
histogram
histogram*
+ sorted-histogram
}
"Combinators for implementing histogram:"
{ $subsections
: histogram ( seq -- hashtable )
[ inc-at ] sequence>hashtable ;
+: sorted-histogram ( seq -- alist )
+ histogram >alist sort-values ;
+
: collect-values ( seq quot: ( obj hashtable -- ) -- hash )
'[ [ dup @ ] dip push-at ] sequence>hashtable ; inline
--- /dev/null
+Daniel Ehrenberg
+Doug Coleman
--- /dev/null
+USING: tools.test sequence-parser unicode.categories kernel
+accessors ;
+IN: sequences.parser.tests
+
+[ "hello" ]
+[ "hello" [ take-rest ] parse-sequence ] unit-test
+
+[ "hi" " how are you?" ]
+[
+ "hi how are you?"
+ [ [ [ current blank? ] take-until ] [ take-rest ] bi ] parse-sequence
+] unit-test
+
+[ "foo" ";bar" ]
+[
+ "foo;bar" [
+ [ CHAR: ; take-until-object ] [ take-rest ] bi
+ ] parse-sequence
+] unit-test
+
+[ "foo " "and bar" ]
+[
+ "foo and bar" [
+ [ "and" take-until-sequence ] [ take-rest ] bi
+ ] parse-sequence
+] unit-test
+
+[ "foo " " bar" ]
+[
+ "foo and bar" [
+ [ "and" take-until-sequence ]
+ [ "and" take-sequence drop ]
+ [ take-rest ] tri
+ ] parse-sequence
+] unit-test
+
+[ "foo " " bar" ]
+[
+ "foo and bar" [
+ [ "and" take-until-sequence* ]
+ [ take-rest ] bi
+ ] parse-sequence
+] unit-test
+
+[ { 1 2 } ]
+[ { 1 2 3 4 } <sequence-parser> { 3 4 } take-until-sequence ] unit-test
+
+[ f "aaaa" ]
+[
+ "aaaa" <sequence-parser>
+ [ "b" take-until-sequence ] [ take-rest ] bi
+] unit-test
+
+[ 6 ]
+[
+ " foo " [ skip-whitespace n>> ] parse-sequence
+] unit-test
+
+[ { 1 2 } ]
+[ { 1 2 3 } <sequence-parser> [ current 3 = ] take-until ] unit-test
+
+[ "ab" ]
+[ "abcd" <sequence-parser> "ab" take-sequence ] unit-test
+
+[ f ]
+[ "abcd" <sequence-parser> "lol" take-sequence ] unit-test
+
+[ "ab" ]
+[
+ "abcd" <sequence-parser>
+ [ "lol" take-sequence drop ] [ "ab" take-sequence ] bi
+] unit-test
+
+[ "" ]
+[ "abcd" <sequence-parser> "" take-sequence ] unit-test
+
+[ "cd" ]
+[ "abcd" <sequence-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test
+
+[ f ]
+[ "" <sequence-parser> take-rest ] unit-test
+
+[ f ]
+[ "abc" <sequence-parser> dup "abc" take-sequence drop take-rest ] unit-test
+
+[ f ]
+[ "abc" <sequence-parser> "abcdefg" take-sequence ] unit-test
+
+[ "1234" ]
+[ "1234f" <sequence-parser> take-integer ] unit-test
+
+[ "yes" ]
+[
+ "yes1234f" <sequence-parser>
+ [ take-integer drop ] [ "yes" take-sequence ] bi
+] unit-test
+
+[ f ] [ "" <sequence-parser> 4 take-n ] unit-test
+[ "abcd" ] [ "abcd" <sequence-parser> 4 take-n ] unit-test
+[ "abcd" "efg" ] [ "abcdefg" <sequence-parser> [ 4 take-n ] [ take-rest ] bi ] unit-test
+
+[ f ]
+[ "\n" <sequence-parser> take-integer ] unit-test
+
+[ "\n" ] [ "\n" <sequence-parser> [ ] take-while ] unit-test
+[ f ] [ "\n" <sequence-parser> [ not ] take-while ] unit-test
--- /dev/null
+! Copyright (C) 2005, 2009 Daniel Ehrenberg, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors circular combinators.short-circuit fry io
+kernel locals math math.order sequences sorting.functor
+sorting.slots unicode.categories ;
+IN: sequences.parser
+
+TUPLE: sequence-parser sequence n ;
+
+: <sequence-parser> ( sequence -- sequence-parser )
+ sequence-parser new
+ swap >>sequence
+ 0 >>n ;
+
+:: with-sequence-parser ( sequence-parser quot -- seq/f )
+ sequence-parser n>> :> n
+ sequence-parser quot call [
+ n sequence-parser (>>n) f
+ ] unless* ; inline
+
+: offset ( sequence-parser offset -- char/f )
+ swap
+ [ n>> + ] [ sequence>> ?nth ] bi ; inline
+
+: current ( sequence-parser -- char/f ) 0 offset ; inline
+
+: previous ( sequence-parser -- char/f ) -1 offset ; inline
+
+: peek-next ( sequence-parser -- char/f ) 1 offset ; inline
+
+: advance ( sequence-parser -- sequence-parser )
+ [ 1 + ] change-n ; inline
+
+: advance* ( sequence-parser -- )
+ advance drop ; inline
+
+: next ( sequence-parser -- obj ) [ current ] [ advance* ] bi ;
+
+: get+increment ( sequence-parser -- char/f )
+ [ current ] [ advance drop ] bi ; inline
+
+:: skip-until ( sequence-parser quot: ( obj -- ? ) -- )
+ sequence-parser current [
+ sequence-parser quot call
+ [ sequence-parser advance quot skip-until ] unless
+ ] when ; inline recursive
+
+: sequence-parse-end? ( sequence-parser -- ? ) current not ;
+
+: take-until ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
+ over sequence-parse-end? [
+ 2drop f
+ ] [
+ [ drop n>> ]
+ [ skip-until ]
+ [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq f like
+ ] if ; inline
+
+: take-while ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
+ [ not ] compose take-until ; inline
+
+: <safe-slice> ( from to seq -- slice/f )
+ 3dup {
+ [ 2drop 0 < ]
+ [ [ drop ] 2dip length > ]
+ [ drop > ]
+ } 3|| [ 3drop f ] [ slice boa ] if ; inline
+
+:: take-sequence ( sequence-parser sequence -- obj/f )
+ sequence-parser [ n>> dup sequence length + ] [ sequence>> ] bi
+ <safe-slice> sequence sequence= [
+ sequence
+ sequence-parser [ sequence length + ] change-n drop
+ ] [
+ f
+ ] if ;
+
+: take-sequence* ( sequence-parser sequence -- )
+ take-sequence drop ;
+
+:: take-until-sequence ( sequence-parser sequence -- sequence'/f )
+ sequence-parser n>> :> saved
+ sequence length <growing-circular> :> growing
+ sequence-parser
+ [
+ current growing push-growing-circular
+ sequence growing sequence=
+ ] take-until :> found
+ growing sequence sequence= [
+ found dup length
+ growing length 1 - - head
+ sequence-parser [ growing length - 1 + ] change-n drop
+ ! sequence-parser advance drop
+ ] [
+ saved sequence-parser (>>n)
+ f
+ ] if ;
+
+:: take-until-sequence* ( sequence-parser sequence -- sequence'/f )
+ sequence-parser sequence take-until-sequence :> out
+ out [
+ sequence-parser [ sequence length + ] change-n drop
+ ] when out ;
+
+: skip-whitespace ( sequence-parser -- sequence-parser )
+ [ [ current blank? not ] take-until drop ] keep ;
+
+: skip-whitespace-eol ( sequence-parser -- sequence-parser )
+ [ [ current " \t\r" member? not ] take-until drop ] keep ;
+
+: take-rest-slice ( sequence-parser -- sequence/f )
+ [ sequence>> ] [ n>> ] bi
+ 2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
+
+: take-rest ( sequence-parser -- sequence )
+ [ take-rest-slice ] [ sequence>> like ] bi f like ;
+
+: take-until-object ( sequence-parser obj -- sequence )
+ '[ current _ = ] take-until ;
+
+: parse-sequence ( sequence quot -- )
+ [ <sequence-parser> ] dip call ; inline
+
+: take-integer ( sequence-parser -- n/f )
+ [ current digit? ] take-while ;
+
+:: take-n ( sequence-parser n -- seq/f )
+ n sequence-parser [ n>> + ] [ sequence>> length ] bi > [
+ sequence-parser take-rest
+ ] [
+ sequence-parser n>> dup n + sequence-parser sequence>> subseq
+ sequence-parser [ n + ] change-n drop
+ ] if ;
+
+<< "length" [ length ] define-sorting >>
+
+: sort-tokens ( seq -- seq' )
+ { length>=< <=> } sort-by ;
+
+: take-first-matching ( sequence-parser seq -- seq )
+ swap
+ '[ _ [ swap take-sequence ] with-sequence-parser ] find nip ;
+
+: take-longest ( sequence-parser seq -- seq )
+ sort-tokens take-first-matching ;
+
+: write-full ( sequence-parser -- ) sequence>> write ;
+: write-rest ( sequence-parser -- ) take-rest write ;
\ <array> { integer object } { array } define-primitive
\ <array> make-flushable
-\ begin-scan { } { } define-primitive
-
-\ next-object { } { object } define-primitive
-
-\ end-scan { } { } define-primitive
+\ all-instances { } { array } define-primitive
\ size { object } { fixnum } define-primitive
\ size make-flushable
data-room
code-room
}
-"There are a pair of combinators, analogous to " { $link each } " and " { $link filter } ", which operate on the entire collection of objects in the object heap:"
-{ $subsections
- each-object
- instances
-}
+"A combinator to get objects from the heap:"
+{ $subsections instances }
"You can check an object's the heap memory usage:"
{ $subsections size }
"The garbage collector can be invoked manually:"
USING: classes.struct alien.c-types alien.syntax ;
IN: vm
-TYPEDEF: intptr_t cell
+TYPEDEF: uintptr_t cell
C-TYPE: context
STRUCT: zone
{ "resize-array" "arrays" (( n array -- newarray )) }
{ "resize-string" "strings" (( n str -- newstr )) }
{ "<array>" "arrays" (( n elt -- array )) }
- { "begin-scan" "memory" (( -- )) }
- { "next-object" "memory" (( -- obj )) }
- { "end-scan" "memory" (( -- )) }
+ { "all-instances" "memory" (( -- array )) }
{ "size" "memory" (( obj -- n )) }
{ "die" "kernel" (( -- )) }
{ "(fopen)" "io.streams.c" (( path mode -- alien )) }
! Create a boot quotation for the target
[
[
- ! Rehash hashtables, since bootstrap.image creates them
- ! using the host image's hashing algorithms. We don't
- ! use each-object here since the catch stack isn't yet
- ! set up.
- gc
- begin-scan
- [ hashtable? ] pusher [ (each-object) ] dip
- end-scan
- [ rehash ] each
+ ! Rehash hashtables first, since bootstrap.image creates
+ ! them using the host image's hashing algorithms.
+ [ hashtable? ] instances [ rehash ] each
boot
] %
"math.integers" require
"math.floats" require
"memory" require
-
+
"io.streams.c" require
"vocabs.loader" require
-
+
"syntax" require
"bootstrap.layouts" require
quotations math ;
IN: memory
-HELP: begin-scan ( -- )
-{ $description "Disables the garbage collector and resets the heap scan pointer to point at the first object in the heap. The " { $link next-object } " word can then be called to advance the heap scan pointer and return successive objects."
-$nl
-"This word must always be paired with a call to " { $link end-scan } "." }
-{ $notes "This is a low-level facility and can be dangerous. Use the " { $link each-object } " combinator instead." } ;
-
-HELP: next-object ( -- obj )
-{ $values { "obj" object } }
-{ $description "Outputs the object at the heap scan pointer, and then advances the heap scan pointer. If the end of the heap has been reached, outputs " { $link f } ". This is unambiguous since the " { $link f } " object is tagged immediate and not actually stored in the heap." }
-{ $errors "Throws a " { $link heap-scan-error. } " if called outside a " { $link begin-scan } "/" { $link end-scan } " pair." }
-{ $notes "This is a low-level facility and can be dangerous. Use the " { $link each-object } " combinator instead." } ;
-
-HELP: end-scan ( -- )
-{ $description "Finishes a heap iteration by re-enabling the garbage collector. This word must always be paired with a call to " { $link begin-scan } "." }
-{ $notes "This is a low-level facility and can be dangerous. Use the " { $link each-object } " combinator instead." } ;
-
-HELP: each-object
-{ $values { "quot" { $quotation "( obj -- )" } } }
-{ $description "Applies a quotation to each object in the heap. The garbage collector is switched off while this combinator runs, so the given quotation must not allocate too much memory." }
-{ $notes "This word is the low-level facility used to implement the " { $link instances } " word." } ;
-
HELP: instances
{ $values { "quot" { $quotation "( obj -- ? )" } } { "seq" "a fresh sequence" } }
-{ $description "Outputs a sequence of all objects in the heap which satisfy the quotation." }
-{ $notes "This word relies on " { $link each-object } ", so in particular the garbage collector is switched off while it runs and the given quotation must not allocate too much memory." } ;
+{ $description "Outputs a sequence of all objects in the heap which satisfy the quotation." } ;
HELP: gc ( -- )
{ $description "Performs a full garbage collection." } ;
HELP: save
{ $description "Saves a snapshot of the heap to the current image file." } ;
-HELP: count-instances
-{ $values
- { "quot" quotation }
- { "n" integer } }
-{ $description "Applies the predicate quotation to each object in the heap and returns the number of objects that match. Since this word uses " { $link each-object } " with the garbage collector switched off, avoid allocating too much memory in the quotation." }
-{ $examples { $unchecked-example
- "USING: memory words prettyprint ;"
- "[ word? ] count-instances ."
- "24210"
-} } ;
-
ARTICLE: "images" "Images"
"Factor has the ability to save the entire state of the system into an " { $emphasis "image file" } ". The image contains a complete dump of all data and code in the current Factor instance."
{ $subsections
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel continuations sequences vectors arrays system math
+USING: kernel continuations sequences system
io.backend alien.strings memory.private ;
IN: memory
-: (each-object) ( quot: ( obj -- ) -- )
- next-object dup [
- swap [ call ] keep (each-object)
- ] [ 2drop ] if ; inline recursive
-
-: each-object ( quot -- )
- gc begin-scan [ (each-object) ] [ end-scan ] [ ] cleanup ; inline
-
-: count-instances ( quot -- n )
- 0 swap [ 1 0 ? + ] compose each-object ; inline
-
: instances ( quot -- seq )
- #! To ensure we don't need to grow the vector while scanning
- #! the heap, we do two scans, the first one just counts the
- #! number of objects that satisfy the predicate.
- [ count-instances 100 + <vector> ] keep swap
- [ [ push-if ] 2curry each-object ] keep >array ; inline
+ [ all-instances ] dip filter ; inline
: save-image ( path -- )
normalize-path native-string>alien (save-image) ;
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors c.lexer kernel sequence-parser tools.test ;
+USING: accessors c.lexer kernel sequences.parser tools.test ;
IN: c.lexer.tests
[ 36 ]
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.short-circuit
generalizations kernel locals math.order math.ranges
-sequence-parser sequences sorting.functor sorting.slots
+sequences.parser sequences sorting.functor sorting.slots
unicode.categories ;
IN: c.lexer
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: sequence-parser io io.encodings.utf8 io.files
+USING: sequences.parser io io.encodings.utf8 io.files
io.streams.string kernel combinators accessors io.pathnames
fry sequences arrays locals namespaces io.directories
assocs math splitting make unicode.categories
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays hashtables sequence-parser
+USING: accessors arrays hashtables sequences.parser
html.parser.utils kernel namespaces sequences math
unicode.case unicode.categories combinators.short-circuit
quoting fry ;
+++ /dev/null
-USING: tools.test sequence-parser unicode.categories kernel
-accessors ;
-IN: sequence-parser.tests
-
-[ "hello" ]
-[ "hello" [ take-rest ] parse-sequence ] unit-test
-
-[ "hi" " how are you?" ]
-[
- "hi how are you?"
- [ [ [ current blank? ] take-until ] [ take-rest ] bi ] parse-sequence
-] unit-test
-
-[ "foo" ";bar" ]
-[
- "foo;bar" [
- [ CHAR: ; take-until-object ] [ take-rest ] bi
- ] parse-sequence
-] unit-test
-
-[ "foo " "and bar" ]
-[
- "foo and bar" [
- [ "and" take-until-sequence ] [ take-rest ] bi
- ] parse-sequence
-] unit-test
-
-[ "foo " " bar" ]
-[
- "foo and bar" [
- [ "and" take-until-sequence ]
- [ "and" take-sequence drop ]
- [ take-rest ] tri
- ] parse-sequence
-] unit-test
-
-[ "foo " " bar" ]
-[
- "foo and bar" [
- [ "and" take-until-sequence* ]
- [ take-rest ] bi
- ] parse-sequence
-] unit-test
-
-[ { 1 2 } ]
-[ { 1 2 3 4 } <sequence-parser> { 3 4 } take-until-sequence ] unit-test
-
-[ f "aaaa" ]
-[
- "aaaa" <sequence-parser>
- [ "b" take-until-sequence ] [ take-rest ] bi
-] unit-test
-
-[ 6 ]
-[
- " foo " [ skip-whitespace n>> ] parse-sequence
-] unit-test
-
-[ { 1 2 } ]
-[ { 1 2 3 } <sequence-parser> [ current 3 = ] take-until ] unit-test
-
-[ "ab" ]
-[ "abcd" <sequence-parser> "ab" take-sequence ] unit-test
-
-[ f ]
-[ "abcd" <sequence-parser> "lol" take-sequence ] unit-test
-
-[ "ab" ]
-[
- "abcd" <sequence-parser>
- [ "lol" take-sequence drop ] [ "ab" take-sequence ] bi
-] unit-test
-
-[ "" ]
-[ "abcd" <sequence-parser> "" take-sequence ] unit-test
-
-[ "cd" ]
-[ "abcd" <sequence-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test
-
-[ f ]
-[ "" <sequence-parser> take-rest ] unit-test
-
-[ f ]
-[ "abc" <sequence-parser> dup "abc" take-sequence drop take-rest ] unit-test
-
-[ f ]
-[ "abc" <sequence-parser> "abcdefg" take-sequence ] unit-test
-
-[ "1234" ]
-[ "1234f" <sequence-parser> take-integer ] unit-test
-
-[ "yes" ]
-[
- "yes1234f" <sequence-parser>
- [ take-integer drop ] [ "yes" take-sequence ] bi
-] unit-test
-
-[ f ] [ "" <sequence-parser> 4 take-n ] unit-test
-[ "abcd" ] [ "abcd" <sequence-parser> 4 take-n ] unit-test
-[ "abcd" "efg" ] [ "abcdefg" <sequence-parser> [ 4 take-n ] [ take-rest ] bi ] unit-test
-
-[ f ]
-[ "\n" <sequence-parser> take-integer ] unit-test
-
-[ "\n" ] [ "\n" <sequence-parser> [ ] take-while ] unit-test
-[ f ] [ "\n" <sequence-parser> [ not ] take-while ] unit-test
+++ /dev/null
-! Copyright (C) 2005, 2009 Daniel Ehrenberg, Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors circular combinators.short-circuit fry io
-kernel locals math math.order sequences sorting.functor
-sorting.slots unicode.categories ;
-IN: sequence-parser
-
-TUPLE: sequence-parser sequence n ;
-
-: <sequence-parser> ( sequence -- sequence-parser )
- sequence-parser new
- swap >>sequence
- 0 >>n ;
-
-:: with-sequence-parser ( sequence-parser quot -- seq/f )
- sequence-parser n>> :> n
- sequence-parser quot call [
- n sequence-parser (>>n) f
- ] unless* ; inline
-
-: offset ( sequence-parser offset -- char/f )
- swap
- [ n>> + ] [ sequence>> ?nth ] bi ; inline
-
-: current ( sequence-parser -- char/f ) 0 offset ; inline
-
-: previous ( sequence-parser -- char/f ) -1 offset ; inline
-
-: peek-next ( sequence-parser -- char/f ) 1 offset ; inline
-
-: advance ( sequence-parser -- sequence-parser )
- [ 1 + ] change-n ; inline
-
-: advance* ( sequence-parser -- )
- advance drop ; inline
-
-: next ( sequence-parser -- obj ) [ current ] [ advance* ] bi ;
-
-: get+increment ( sequence-parser -- char/f )
- [ current ] [ advance drop ] bi ; inline
-
-:: skip-until ( sequence-parser quot: ( obj -- ? ) -- )
- sequence-parser current [
- sequence-parser quot call
- [ sequence-parser advance quot skip-until ] unless
- ] when ; inline recursive
-
-: sequence-parse-end? ( sequence-parser -- ? ) current not ;
-
-: take-until ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
- over sequence-parse-end? [
- 2drop f
- ] [
- [ drop n>> ]
- [ skip-until ]
- [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq f like
- ] if ; inline
-
-: take-while ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
- [ not ] compose take-until ; inline
-
-: <safe-slice> ( from to seq -- slice/f )
- 3dup {
- [ 2drop 0 < ]
- [ [ drop ] 2dip length > ]
- [ drop > ]
- } 3|| [ 3drop f ] [ slice boa ] if ; inline
-
-:: take-sequence ( sequence-parser sequence -- obj/f )
- sequence-parser [ n>> dup sequence length + ] [ sequence>> ] bi
- <safe-slice> sequence sequence= [
- sequence
- sequence-parser [ sequence length + ] change-n drop
- ] [
- f
- ] if ;
-
-: take-sequence* ( sequence-parser sequence -- )
- take-sequence drop ;
-
-:: take-until-sequence ( sequence-parser sequence -- sequence'/f )
- sequence-parser n>> :> saved
- sequence length <growing-circular> :> growing
- sequence-parser
- [
- current growing push-growing-circular
- sequence growing sequence=
- ] take-until :> found
- growing sequence sequence= [
- found dup length
- growing length 1 - - head
- sequence-parser [ growing length - 1 + ] change-n drop
- ! sequence-parser advance drop
- ] [
- saved sequence-parser (>>n)
- f
- ] if ;
-
-:: take-until-sequence* ( sequence-parser sequence -- sequence'/f )
- sequence-parser sequence take-until-sequence :> out
- out [
- sequence-parser [ sequence length + ] change-n drop
- ] when out ;
-
-: skip-whitespace ( sequence-parser -- sequence-parser )
- [ [ current blank? not ] take-until drop ] keep ;
-
-: skip-whitespace-eol ( sequence-parser -- sequence-parser )
- [ [ current " \t\r" member? not ] take-until drop ] keep ;
-
-: take-rest-slice ( sequence-parser -- sequence/f )
- [ sequence>> ] [ n>> ] bi
- 2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
-
-: take-rest ( sequence-parser -- sequence )
- [ take-rest-slice ] [ sequence>> like ] bi f like ;
-
-: take-until-object ( sequence-parser obj -- sequence )
- '[ current _ = ] take-until ;
-
-: parse-sequence ( sequence quot -- )
- [ <sequence-parser> ] dip call ; inline
-
-: take-integer ( sequence-parser -- n/f )
- [ current digit? ] take-while ;
-
-:: take-n ( sequence-parser n -- seq/f )
- n sequence-parser [ n>> + ] [ sequence>> length ] bi > [
- sequence-parser take-rest
- ] [
- sequence-parser n>> dup n + sequence-parser sequence>> subseq
- sequence-parser [ n + ] change-n drop
- ] if ;
-
-<< "length" [ length ] define-sorting >>
-
-: sort-tokens ( seq -- seq' )
- { length>=< <=> } sort-by ;
-
-: take-first-matching ( sequence-parser seq -- seq )
- swap
- '[ _ [ swap take-sequence ] with-sequence-parser ] find nip ;
-
-: take-longest ( sequence-parser seq -- seq )
- sort-tokens take-first-matching ;
-
-: write-full ( sequence-parser -- ) sequence>> write ;
-: write-rest ( sequence-parser -- ) take-rest write ;
starts.record_object_start_offset(obj);
return obj;
}
-
- cell next_object_after(cell scan)
- {
- cell size = ((object *)scan)->size();
- if(scan + size < here)
- return scan + size;
- else
- return 0;
- }
};
}
/* These algorithms were snarfed from various places. I did not come up with them myself */
-inline cell popcount(u64 x)
+inline cell popcount(cell x)
{
+#ifdef FACTOR_64
u64 k1 = 0x5555555555555555ll;
u64 k2 = 0x3333333333333333ll;
u64 k4 = 0x0f0f0f0f0f0f0f0fll;
u64 kf = 0x0101010101010101ll;
+ cell ks = 56;
+#else
+ u32 k1 = 0x55555555;
+ u32 k2 = 0x33333333;
+ u32 k4 = 0xf0f0f0f;
+ u32 kf = 0x1010101;
+ cell ks = 24;
+#endif
+
x = x - ((x >> 1) & k1); // put count of each 2 bits into those 2 bits
x = (x & k2) + ((x >> 2) & k2); // put count of each 4 bits into those 4 bits
x = (x + (x >> 4)) & k4 ; // put count of each 8 bits into those 8 bits
- x = (x * kf) >> 56; // returns 8 most significant bits of x + (x<<8) + (x<<16) + (x<<24) + ...
+ x = (x * kf) >> ks; // returns 8 most significant bits of x + (x<<8) + (x<<16) + (x<<24) + ...
return (cell)x;
}
-inline cell log2(u64 x)
+inline cell log2(cell x)
{
-#ifdef FACTOR_AMD64
+#if defined(FACTOR_X86)
+ cell n;
+ asm ("bsr %1, %0;":"=r"(n):"r"(x));
+#elif defined(FACTOR_AMD64)
cell n;
- asm ("bsr %1, %0;":"=r"(n):"r"((cell)x));
+ asm ("bsr %1, %0;":"=r"(n):"r"(x));
#else
cell n = 0;
+#ifdef FACTOR_64
if (x >= (u64)1 << 32) { x >>= 32; n += 32; }
- if (x >= (u64)1 << 16) { x >>= 16; n += 16; }
- if (x >= (u64)1 << 8) { x >>= 8; n += 8; }
- if (x >= (u64)1 << 4) { x >>= 4; n += 4; }
- if (x >= (u64)1 << 2) { x >>= 2; n += 2; }
- if (x >= (u64)1 << 1) { n += 1; }
#endif
- return n;
-}
-
-inline cell log2(u16 x)
-{
-#if defined(FACTOR_X86) || defined(FACTOR_AMD64)
- cell n;
- asm ("bsr %1, %0;":"=r"(n):"r"((cell)x));
-#else
- cell n = 0;
- if (x >= 1 << 8) { x >>= 8; n += 8; }
- if (x >= 1 << 4) { x >>= 4; n += 4; }
- if (x >= 1 << 2) { x >>= 2; n += 2; }
- if (x >= 1 << 1) { n += 1; }
+ if (x >= (u32)1 << 16) { x >>= 16; n += 16; }
+ if (x >= (u32)1 << 8) { x >>= 8; n += 8; }
+ if (x >= (u32)1 << 4) { x >>= 4; n += 4; }
+ if (x >= (u32)1 << 2) { x >>= 2; n += 2; }
+ if (x >= (u32)1 << 1) { n += 1; }
#endif
return n;
}
-inline cell rightmost_clear_bit(u64 x)
+inline cell rightmost_clear_bit(cell x)
{
return log2(~x & (x + 1));
}
-inline cell rightmost_set_bit(u64 x)
+inline cell rightmost_set_bit(cell x)
{
return log2(x & -x);
}
-inline cell rightmost_set_bit(u16 x)
-{
- return log2((u16)(x & -x));
-}
-
}
{
return end - here;
}
+
+ cell next_object_after(cell scan)
+ {
+ cell size = ((Block *)scan)->size();
+ if(scan + size < here)
+ return scan + size;
+ else
+ return 0;
+ }
+
+ cell first_object()
+ {
+ if(start != here)
+ return start;
+ else
+ return 0;
+ }
};
}
void factor_vm::update_code_heap_words_and_literals()
{
- current_gc->event->started_code_sweep();
word_and_literal_code_heap_updater updater(this);
- code->allocator->sweep(updater);
- current_gc->event->ended_code_sweep();
+ iterate_code_heap(updater);
}
/* After growing the heap, we have to perform a full relocation to update
}
};
-void factor_vm::relocate_code_heap()
-{
- code_heap_relocator relocator(this);
- code->allocator->sweep(relocator);
-}
-
void factor_vm::primitive_modify_code_heap()
{
data_root<array> alist(dpop(),this);
if(count == 0)
return;
- cell i;
- for(i = 0; i < count; i++)
+ for(cell i = 0; i < count; i++)
{
data_root<array> pair(array_nth(alist.untagged(),i),this);
explicit object_code_block_updater(code_block_visitor<forwarder<code_block> > *visitor_) :
visitor(visitor_) {}
- void operator()(cell obj)
+ void operator()(object *obj)
{
- visitor->visit_object_code_block(tagged<object>(obj).untagged());
+ visitor->visit_object_code_block(obj);
}
};
}
}
+void factor_vm::primitive_load_locals()
+{
+ fixnum count = untag_fixnum(dpop());
+ memcpy((cell *)(rs + sizeof(cell)),(cell *)(ds - sizeof(cell) * (count - 1)),sizeof(cell) * count);
+ ds -= sizeof(cell) * count;
+ rs += sizeof(cell) * count;
+}
+
}
return (tenured->free_space() <= nursery->size + aging->size);
}
+void data_heap::mark_all_cards()
+{
+ memset(cards,-1,cards_end - cards);
+ memset(decks,-1,decks_end - decks);
+}
+
void factor_vm::set_data_heap(data_heap *data_)
{
data = data_;
set_data_heap(new data_heap(young_size,aging_size,tenured_size));
}
-/* Size of the object pointed to by a tagged pointer */
-cell factor_vm::object_size(cell tagged)
-{
- if(immediate_p(tagged))
- return 0;
- else
- return untag<object>(tagged)->size();
-}
-
/* Size of the object pointed to by an untagged pointer */
cell object::size() const
{
}
}
-void factor_vm::primitive_size()
-{
- box_unsigned_cell(object_size(dpop()));
-}
-
data_heap_room factor_vm::data_room()
{
data_heap_room room;
dpush(tag<byte_array>(byte_array_from_value(&room)));
}
-/* Disables GC and activates next-object ( -- obj ) primitive */
-void factor_vm::begin_scan()
-{
- heap_scan_ptr = data->tenured->first_object();
- gc_off = true;
-}
-
-void factor_vm::end_scan()
-{
- gc_off = false;
-}
+struct object_accumulator {
+ cell type;
+ std::vector<cell> objects;
-void factor_vm::primitive_begin_scan()
-{
- begin_scan();
-}
-
-cell factor_vm::next_object()
-{
- if(!gc_off)
- general_error(ERROR_HEAP_SCAN,false_object,false_object,NULL);
+ explicit object_accumulator(cell type_) : type(type_) {}
- if(heap_scan_ptr)
+ void operator()(object *obj)
{
- cell current = heap_scan_ptr;
- heap_scan_ptr = data->tenured->next_object_after(heap_scan_ptr);
- return tag_dynamic((object *)current);
+ if(type == TYPE_COUNT || obj->h.hi_tag() == type)
+ objects.push_back(tag_dynamic(obj));
}
- else
- return false_object;
-}
+};
-/* Push object at heap scan cursor and advance; pushes f when done */
-void factor_vm::primitive_next_object()
+cell factor_vm::instances(cell type)
{
- dpush(next_object());
-}
+ object_accumulator accum(type);
+ each_object(accum);
+ cell object_count = accum.objects.size();
-/* Re-enables GC */
-void factor_vm::primitive_end_scan()
-{
+ gc_off = true;
+ array *objects = allot_array(object_count,false_object);
+ memcpy(objects->data(),&accum.objects[0],object_count * sizeof(cell));
gc_off = false;
-}
-
-struct word_counter {
- cell count;
-
- explicit word_counter() : count(0) {}
- void operator()(cell obj)
- {
- if(tagged<object>(obj).type_p(WORD_TYPE))
- count++;
- }
-};
-
-struct word_accumulator {
- growable_array words;
-
- explicit word_accumulator(int count,factor_vm *vm) : words(vm,count) {}
+ return tag<array>(objects);
+}
- void operator()(cell obj)
- {
- if(tagged<object>(obj).type_p(WORD_TYPE))
- words.add(obj);
- }
-};
+void factor_vm::primitive_all_instances()
+{
+ primitive_full_gc();
+ dpush(instances(TYPE_COUNT));
+}
cell factor_vm::find_all_words()
{
- word_counter counter;
- each_object(counter);
- word_accumulator accum(counter.count,this);
- each_object(accum);
- accum.words.trim();
- return accum.words.elements.value();
+ return instances(WORD_TYPE);
}
}
void reset_generation(aging_space *gen);
void reset_generation(tenured_space *gen);
bool low_memory_p();
+ void mark_all_cards();
};
struct data_heap_room {
explicit object_dumper(factor_vm *parent_, cell type_) :
parent(parent_), type(type_) {}
- void operator()(cell obj)
+ void operator()(object *obj)
{
- if(type == TYPE_COUNT || tagged<object>(obj).type_p(type))
+ if(type == TYPE_COUNT || obj->h.hi_tag() == type)
{
- std::cout << padded_address(obj) << " ";
- parent->print_nested_obj(obj,2);
+ std::cout << padded_address((cell)obj) << " ";
+ parent->print_nested_obj(tag_dynamic(obj),2);
std::cout << std::endl;
}
}
}
struct data_reference_slot_visitor {
- cell look_for, obj;
+ cell look_for;
+ object *obj;
factor_vm *parent;
- explicit data_reference_slot_visitor(cell look_for_, cell obj_, factor_vm *parent_) :
+ explicit data_reference_slot_visitor(cell look_for_, object *obj_, factor_vm *parent_) :
look_for(look_for_), obj(obj_), parent(parent_) { }
void operator()(cell *scan)
{
if(look_for == *scan)
{
- std::cout << padded_address(obj) << " ";
- parent->print_nested_obj(obj,2);
+ std::cout << padded_address((cell)obj) << " ";
+ parent->print_nested_obj(tag_dynamic(obj),2);
std::cout << std::endl;
}
}
explicit data_reference_object_visitor(cell look_for_, factor_vm *parent_) :
look_for(look_for_), parent(parent_) {}
- void operator()(cell obj)
+ void operator()(object *obj)
{
data_reference_slot_visitor visitor(look_for,obj,parent);
- parent->do_slots(UNTAG(obj),visitor);
+ parent->do_slots(obj,visitor);
}
};
ERROR_ARRAY_SIZE,
ERROR_C_STRING,
ERROR_FFI,
- ERROR_HEAP_SCAN,
ERROR_UNDEFINED_SYMBOL,
ERROR_DS_UNDERFLOW,
ERROR_DS_OVERFLOW,
fflush(stdout);
compile_all_words();
+ update_code_heap_words();
special_objects[OBJ_STAGE2] = true_object;
std::cout << "done\n";
cell largest_free_block();
cell free_block_count();
void sweep();
- template<typename Iterator> void sweep(Iterator &iter);
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> void iterate(Iterator &iter);
}
}
-template<typename Block>
-template<typename Iterator>
-void free_list_allocator<Block>::sweep(Iterator &iter)
-{
- free_blocks.clear_free_list();
-
- Block *prev = NULL;
- Block *scan = this->first_block();
- Block *end = this->last_block();
-
- while(scan != end)
- {
- cell size = scan->size();
-
- if(scan->free_p())
- {
- if(prev && prev->free_p())
- {
- free_heap_block *free_prev = (free_heap_block *)prev;
- free_prev->make_free(free_prev->size() + size);
- }
- else
- prev = scan;
- }
- else if(this->state.marked_p(scan))
- {
- if(prev && prev->free_p())
- free_blocks.add_to_free_list((free_heap_block *)prev);
- prev = scan;
- iter(scan,size);
- }
- else
- {
- if(prev && prev->free_p())
- {
- free_heap_block *free_prev = (free_heap_block *)prev;
- free_prev->make_free(free_prev->size() + size);
- }
- else
- {
- free_heap_block *free_block = (free_heap_block *)scan;
- free_block->make_free(size);
- prev = scan;
- }
- }
-
- scan = (Block *)((cell)scan + size);
- }
-
- if(prev && prev->free_p())
- free_blocks.add_to_free_list((free_heap_block *)prev);
-}
-
template<typename Block, typename Iterator> struct heap_compactor {
mark_bits<Block> *state;
char *address;
data->tenured->sweep();
update_code_roots_for_sweep();
current_gc->event->ended_data_sweep();
+
+ current_gc->event->started_code_sweep();
+ code->allocator->sweep();
+ current_gc->event->ended_code_sweep();
}
void factor_vm::collect_full(bool trace_contexts_p)
true /* trace contexts? */);
}
-/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this
- to coalesce equal but distinct quotations and wrappers. */
-void factor_vm::primitive_become()
-{
- array *new_objects = untag_check<array>(dpop());
- array *old_objects = untag_check<array>(dpop());
-
- cell capacity = array_capacity(new_objects);
- if(capacity != array_capacity(old_objects))
- critical_error("bad parameters to become",0);
-
- cell i;
-
- for(i = 0; i < capacity; i++)
- {
- tagged<object> old_obj(array_nth(old_objects,i));
- tagged<object> new_obj(array_nth(new_objects,i));
-
- if(old_obj != new_obj)
- old_obj->h.forward_to(new_obj.untagged());
- }
-
- primitive_full_gc();
-
- /* If a word's definition quotation was in old_objects and the
- quotation in new_objects is not compiled, we might leak memory
- by referencing the old quotation unless we recompile all
- unoptimized words. */
- compile_all_words();
-}
-
void factor_vm::inline_gc(cell *data_roots_base, cell data_roots_size)
{
for(cell i = 0; i < data_roots_size; i++)
/* Allows initialization code to store old->new pointers
without hitting the write barrier in the common case of
a nursery allocation */
- char *start = (char *)obj;
- for(cell offset = 0; offset < size; offset += card_size)
- write_barrier((cell *)(start + offset));
+ write_barrier(obj,size);
obj->h = header;
return obj;
else
{
object_fixupper fixupper(this,data_relocation_base);
- do_slots((cell)object,fixupper);
+ do_slots(object,fixupper);
switch(hi_tag)
{
{
const int block_granularity = 16;
-const int forwarding_granularity = 64;
+const int mark_bits_granularity = sizeof(cell) * 8;
+const int mark_bits_mask = sizeof(cell) * 8 - 1;
template<typename Block> struct mark_bits {
cell size;
cell start;
cell bits_size;
- u64 *marked;
+ cell *marked;
cell *forwarding;
void clear_mark_bits()
{
- memset(marked,0,bits_size * sizeof(u64));
+ memset(marked,0,bits_size * sizeof(cell));
}
void clear_forwarding()
explicit mark_bits(cell size_, cell start_) :
size(size_),
start(start_),
- bits_size(size / block_granularity / forwarding_granularity),
- marked(new u64[bits_size]),
+ bits_size(size / block_granularity / mark_bits_granularity),
+ marked(new cell[bits_size]),
forwarding(new cell[bits_size])
{
clear_mark_bits();
std::pair<cell,cell> bitmap_deref(Block *address)
{
cell line_number = block_line(address);
- cell word_index = (line_number >> 6);
- cell word_shift = (line_number & 63);
+ cell word_index = (line_number / mark_bits_granularity);
+ cell word_shift = (line_number & mark_bits_mask);
return std::make_pair(word_index,word_shift);
}
- bool bitmap_elt(u64 *bits, Block *address)
+ bool bitmap_elt(cell *bits, Block *address)
{
std::pair<cell,cell> position = bitmap_deref(address);
- return (bits[position.first] & ((u64)1 << position.second)) != 0;
+ return (bits[position.first] & ((cell)1 << position.second)) != 0;
}
Block *next_block_after(Block *block)
return (Block *)((cell)block + block->size());
}
- void set_bitmap_range(u64 *bits, Block *address)
+ void set_bitmap_range(cell *bits, Block *address)
{
std::pair<cell,cell> start = bitmap_deref(address);
std::pair<cell,cell> end = bitmap_deref(next_block_after(address));
- u64 start_mask = ((u64)1 << start.second) - 1;
- u64 end_mask = ((u64)1 << end.second) - 1;
+ cell start_mask = ((cell)1 << start.second) - 1;
+ cell end_mask = ((cell)1 << end.second) - 1;
if(start.first == end.first)
bits[start.first] |= start_mask ^ end_mask;
bits[start.first] |= ~start_mask;
for(cell index = start.first + 1; index < end.first; index++)
- bits[index] = (u64)-1;
+ bits[index] = (cell)-1;
if(end_mask != 0)
{
}
}
- /* We have the popcount for every 64 entries; look up and compute the rest */
+ /* We have the popcount for every mark_bits_granularity entries; look
+ up and compute the rest */
Block *forward_block(Block *original)
{
#ifdef FACTOR_DEBUG
std::pair<cell,cell> position = bitmap_deref(original);
cell approx_popcount = forwarding[position.first];
- u64 mask = ((u64)1 << position.second) - 1;
+ cell mask = ((cell)1 << position.second) - 1;
cell new_line_number = approx_popcount + popcount(marked[position.first] & mask);
Block *new_block = line_block(new_line_number);
for(cell index = position.first; index < bits_size; index++)
{
- u64 mask = ((s64)marked[index] >> bit_index);
+ cell mask = ((fixnum)marked[index] >> bit_index);
if(~mask)
{
/* Found an unmarked block on this page.
Stop, it's hammer time */
cell clear_bit = rightmost_clear_bit(mask);
- return line_block(index * 64 + bit_index + clear_bit);
+ return line_block(index * mark_bits_granularity + bit_index + clear_bit);
}
else
{
for(cell index = position.first; index < bits_size; index++)
{
- u64 mask = (marked[index] >> bit_index);
+ cell mask = (marked[index] >> bit_index);
if(mask)
{
/* Found an marked block on this page.
Stop, it's hammer time */
cell set_bit = rightmost_set_bit(mask);
- return line_block(index * 64 + bit_index + set_bit);
+ return line_block(index * mark_bits_granularity + bit_index + set_bit);
}
else
{
#include "segments.hpp"
#include "contexts.hpp"
#include "run.hpp"
+#include "objects.hpp"
#include "profiler.hpp"
#include "errors.hpp"
#include "bignumint.hpp"
{
for(cell index = 0; index < state->bits_size; index++)
{
- u64 mask = state->marked[index];
+ cell mask = state->marked[index];
+#ifdef FACTOR_64
update_card_for_sweep(index * 4, mask & 0xffff);
update_card_for_sweep(index * 4 + 1, (mask >> 16) & 0xffff);
update_card_for_sweep(index * 4 + 2, (mask >> 32) & 0xffff);
update_card_for_sweep(index * 4 + 3, (mask >> 48) & 0xffff);
+#else
+ update_card_for_sweep(index * 2, mask & 0xffff);
+ update_card_for_sweep(index * 2 + 1, (mask >> 16) & 0xffff);
+#endif
}
}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+void factor_vm::primitive_special_object()
+{
+ fixnum e = untag_fixnum(dpeek());
+ drepl(special_objects[e]);
+}
+
+void factor_vm::primitive_set_special_object()
+{
+ fixnum e = untag_fixnum(dpop());
+ cell value = dpop();
+ special_objects[e] = value;
+}
+
+void factor_vm::primitive_set_slot()
+{
+ fixnum slot = untag_fixnum(dpop());
+ object *obj = untag<object>(dpop());
+ cell value = dpop();
+
+ cell *slot_ptr = &obj->slots()[slot];
+ *slot_ptr = value;
+ write_barrier(slot_ptr);
+}
+
+cell factor_vm::clone_object(cell obj_)
+{
+ data_root<object> obj(obj_,this);
+
+ if(immediate_p(obj.value()))
+ return obj.value();
+ else
+ {
+ cell size = object_size(obj.value());
+ object *new_obj = allot_object(header(obj.type()),size);
+ memcpy(new_obj,obj.untagged(),size);
+ return tag_dynamic(new_obj);
+ }
+}
+
+void factor_vm::primitive_clone()
+{
+ drepl(clone_object(dpeek()));
+}
+
+/* Size of the object pointed to by a tagged pointer */
+cell factor_vm::object_size(cell tagged)
+{
+ if(immediate_p(tagged))
+ return 0;
+ else
+ return untag<object>(tagged)->size();
+}
+
+void factor_vm::primitive_size()
+{
+ box_unsigned_cell(object_size(dpop()));
+}
+
+struct slot_become_visitor {
+ std::map<object *,object *> *become_map;
+
+ explicit slot_become_visitor(std::map<object *,object *> *become_map_) :
+ become_map(become_map_) {}
+
+ object *operator()(object *old)
+ {
+ std::map<object *,object *>::const_iterator iter = become_map->find(old);
+ if(iter != become_map->end())
+ return iter->second;
+ else
+ return old;
+ }
+};
+
+struct object_become_visitor {
+ slot_visitor<slot_become_visitor> *workhorse;
+
+ explicit object_become_visitor(slot_visitor<slot_become_visitor> *workhorse_) :
+ workhorse(workhorse_) {}
+
+ void operator()(object *obj)
+ {
+ workhorse->visit_slots(obj);
+ }
+};
+
+/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this
+ to coalesce equal but distinct quotations and wrappers. */
+void factor_vm::primitive_become()
+{
+ array *new_objects = untag_check<array>(dpop());
+ array *old_objects = untag_check<array>(dpop());
+
+ cell capacity = array_capacity(new_objects);
+ if(capacity != array_capacity(old_objects))
+ critical_error("bad parameters to become",0);
+
+ /* Build the forwarding map */
+ std::map<object *,object *> become_map;
+
+ for(cell i = 0; i < capacity; i++)
+ {
+ tagged<object> old_obj(array_nth(old_objects,i));
+ tagged<object> new_obj(array_nth(new_objects,i));
+
+ if(old_obj != new_obj)
+ become_map[old_obj.untagged()] = new_obj.untagged();
+ }
+
+ /* Update all references to old objects to point to new objects */
+ slot_visitor<slot_become_visitor> workhorse(this,slot_become_visitor(&become_map));
+ workhorse.visit_roots();
+ workhorse.visit_contexts();
+
+ object_become_visitor object_visitor(&workhorse);
+ each_object(object_visitor);
+
+ /* Since we may have introduced old->new references, need to revisit
+ all objects on a minor GC. */
+ data->mark_all_cards();
+ primitive_minor_gc();
+
+ /* If a word's definition quotation was in old_objects and the
+ quotation in new_objects is not compiled, we might leak memory
+ by referencing the old quotation unless we recompile all
+ unoptimized words. */
+ compile_all_words();
+
+ /* Update references to old objects in the code heap */
+ update_code_heap_words_and_literals();
+}
+
+}
--- /dev/null
+namespace factor
+{
+
+static const cell special_object_count = 70;
+
+enum special_object {
+ OBJ_NAMESTACK, /* used by library only */
+ OBJ_CATCHSTACK, /* used by library only, per-callback */
+
+ OBJ_CURRENT_CALLBACK = 2, /* used by library only, per-callback */
+ OBJ_WALKER_HOOK, /* non-local exit hook, used by library only */
+ OBJ_CALLCC_1, /* used to pass the value in callcc1 */
+
+ OBJ_BREAK = 5, /* quotation called by throw primitive */
+ OBJ_ERROR, /* a marker consed onto kernel errors */
+
+ OBJ_CELL_SIZE = 7, /* sizeof(cell) */
+ OBJ_CPU, /* CPU architecture */
+ OBJ_OS, /* operating system name */
+
+ OBJ_ARGS = 10, /* command line arguments */
+ OBJ_STDIN, /* stdin FILE* handle */
+ OBJ_STDOUT, /* stdout FILE* handle */
+
+ OBJ_IMAGE = 13, /* image path name */
+ OBJ_EXECUTABLE, /* runtime executable path name */
+
+ OBJ_EMBEDDED = 15, /* are we embedded in another app? */
+ OBJ_EVAL_CALLBACK, /* used when Factor is embedded in a C app */
+ OBJ_YIELD_CALLBACK, /* used when Factor is embedded in a C app */
+ OBJ_SLEEP_CALLBACK, /* used when Factor is embedded in a C app */
+
+ OBJ_COCOA_EXCEPTION = 19, /* Cocoa exception handler quotation */
+
+ OBJ_BOOT = 20, /* boot quotation */
+ OBJ_GLOBAL, /* global namespace */
+
+ /* Quotation compilation in quotations.c */
+ JIT_PROLOG = 23,
+ JIT_PRIMITIVE_WORD,
+ JIT_PRIMITIVE,
+ JIT_WORD_JUMP,
+ JIT_WORD_CALL,
+ JIT_WORD_SPECIAL,
+ JIT_IF_WORD,
+ JIT_IF,
+ JIT_EPILOG,
+ JIT_RETURN,
+ JIT_PROFILING,
+ JIT_PUSH_IMMEDIATE,
+ JIT_DIP_WORD,
+ JIT_DIP,
+ JIT_2DIP_WORD,
+ JIT_2DIP,
+ JIT_3DIP_WORD,
+ JIT_3DIP,
+ JIT_EXECUTE_WORD,
+ JIT_EXECUTE_JUMP,
+ JIT_EXECUTE_CALL,
+ JIT_DECLARE_WORD,
+
+ /* Callback stub generation in callbacks.c */
+ CALLBACK_STUB = 45,
+
+ /* Polymorphic inline cache generation in inline_cache.c */
+ PIC_LOAD = 47,
+ PIC_TAG,
+ PIC_TUPLE,
+ PIC_CHECK_TAG,
+ PIC_CHECK_TUPLE,
+ PIC_HIT,
+ PIC_MISS_WORD,
+ PIC_MISS_TAIL_WORD,
+
+ /* Megamorphic cache generation in dispatch.c */
+ MEGA_LOOKUP = 57,
+ MEGA_LOOKUP_WORD,
+ MEGA_MISS_WORD,
+
+ OBJ_UNDEFINED = 60, /* default quotation for undefined words */
+
+ OBJ_STDERR = 61, /* stderr FILE* handle */
+
+ OBJ_STAGE2 = 62, /* have we bootstrapped? */
+
+ OBJ_CURRENT_THREAD = 63,
+
+ OBJ_THREADS = 64,
+ OBJ_RUN_QUEUE = 65,
+ OBJ_SLEEP_QUEUE = 66,
+};
+
+#define OBJ_FIRST_SAVE OBJ_BOOT
+#define OBJ_LAST_SAVE OBJ_STAGE2
+
+inline static bool save_env_p(cell i)
+{
+ return (i >= OBJ_FIRST_SAVE && i <= OBJ_LAST_SAVE);
+}
+
+}
PRIMITIVE_FORWARD(float_greatereq)
PRIMITIVE_FORWARD(word)
PRIMITIVE_FORWARD(word_xt)
-PRIMITIVE_FORWARD(getenv)
-PRIMITIVE_FORWARD(setenv)
+PRIMITIVE_FORWARD(special_object)
+PRIMITIVE_FORWARD(set_special_object)
PRIMITIVE_FORWARD(existsp)
PRIMITIVE_FORWARD(minor_gc)
PRIMITIVE_FORWARD(full_gc)
PRIMITIVE_FORWARD(resize_array)
PRIMITIVE_FORWARD(resize_string)
PRIMITIVE_FORWARD(array)
-PRIMITIVE_FORWARD(begin_scan)
-PRIMITIVE_FORWARD(next_object)
-PRIMITIVE_FORWARD(end_scan)
+PRIMITIVE_FORWARD(all_instances)
PRIMITIVE_FORWARD(size)
PRIMITIVE_FORWARD(die)
PRIMITIVE_FORWARD(fopen)
primitive_float_greatereq,
primitive_word,
primitive_word_xt,
- primitive_getenv,
- primitive_setenv,
+ primitive_special_object,
+ primitive_set_special_object,
primitive_existsp,
primitive_minor_gc,
primitive_full_gc,
primitive_resize_array,
primitive_resize_string,
primitive_array,
- primitive_begin_scan,
- primitive_next_object,
- primitive_end_scan,
+ primitive_all_instances,
primitive_size,
primitive_die,
primitive_fopen,
update_word_xt(word.untagged());
}
-
- update_code_heap_words();
}
/* Allocates memory */
namespace factor
{
-void factor_vm::primitive_getenv()
-{
- fixnum e = untag_fixnum(dpeek());
- drepl(special_objects[e]);
-}
-
-void factor_vm::primitive_setenv()
-{
- fixnum e = untag_fixnum(dpop());
- cell value = dpop();
- special_objects[e] = value;
-}
-
void factor_vm::primitive_exit()
{
exit(to_fixnum(dpop()));
sleep_micros(to_cell(dpop()));
}
-void factor_vm::primitive_set_slot()
-{
- fixnum slot = untag_fixnum(dpop());
- object *obj = untag<object>(dpop());
- cell value = dpop();
-
- cell *slot_ptr = &obj->slots()[slot];
- *slot_ptr = value;
- write_barrier(slot_ptr);
-}
-
-void factor_vm::primitive_load_locals()
-{
- fixnum count = untag_fixnum(dpop());
- memcpy((cell *)(rs + sizeof(cell)),(cell *)(ds - sizeof(cell) * (count - 1)),sizeof(cell) * count);
- ds -= sizeof(cell) * count;
- rs += sizeof(cell) * count;
-}
-
-cell factor_vm::clone_object(cell obj_)
-{
- data_root<object> obj(obj_,this);
-
- if(immediate_p(obj.value()))
- return obj.value();
- else
- {
- cell size = object_size(obj.value());
- object *new_obj = allot_object(header(obj.type()),size);
- memcpy(new_obj,obj.untagged(),size);
- return tag_dynamic(new_obj);
- }
-}
-
-void factor_vm::primitive_clone()
-{
- drepl(clone_object(dpeek()));
-}
-
}
namespace factor
{
-static const cell special_object_count = 70;
-
-enum special_object {
- OBJ_NAMESTACK, /* used by library only */
- OBJ_CATCHSTACK, /* used by library only, per-callback */
-
- OBJ_CURRENT_CALLBACK = 2, /* used by library only, per-callback */
- OBJ_WALKER_HOOK, /* non-local exit hook, used by library only */
- OBJ_CALLCC_1, /* used to pass the value in callcc1 */
-
- OBJ_BREAK = 5, /* quotation called by throw primitive */
- OBJ_ERROR, /* a marker consed onto kernel errors */
-
- OBJ_CELL_SIZE = 7, /* sizeof(cell) */
- OBJ_CPU, /* CPU architecture */
- OBJ_OS, /* operating system name */
-
- OBJ_ARGS = 10, /* command line arguments */
- OBJ_STDIN, /* stdin FILE* handle */
- OBJ_STDOUT, /* stdout FILE* handle */
-
- OBJ_IMAGE = 13, /* image path name */
- OBJ_EXECUTABLE, /* runtime executable path name */
-
- OBJ_EMBEDDED = 15, /* are we embedded in another app? */
- OBJ_EVAL_CALLBACK, /* used when Factor is embedded in a C app */
- OBJ_YIELD_CALLBACK, /* used when Factor is embedded in a C app */
- OBJ_SLEEP_CALLBACK, /* used when Factor is embedded in a C app */
-
- OBJ_COCOA_EXCEPTION = 19, /* Cocoa exception handler quotation */
-
- OBJ_BOOT = 20, /* boot quotation */
- OBJ_GLOBAL, /* global namespace */
-
- /* Quotation compilation in quotations.c */
- JIT_PROLOG = 23,
- JIT_PRIMITIVE_WORD,
- JIT_PRIMITIVE,
- JIT_WORD_JUMP,
- JIT_WORD_CALL,
- JIT_WORD_SPECIAL,
- JIT_IF_WORD,
- JIT_IF,
- JIT_EPILOG,
- JIT_RETURN,
- JIT_PROFILING,
- JIT_PUSH_IMMEDIATE,
- JIT_DIP_WORD,
- JIT_DIP,
- JIT_2DIP_WORD,
- JIT_2DIP,
- JIT_3DIP_WORD,
- JIT_3DIP,
- JIT_EXECUTE_WORD,
- JIT_EXECUTE_JUMP,
- JIT_EXECUTE_CALL,
- JIT_DECLARE_WORD,
-
- /* Callback stub generation in callbacks.c */
- CALLBACK_STUB = 45,
-
- /* Polymorphic inline cache generation in inline_cache.c */
- PIC_LOAD = 47,
- PIC_TAG,
- PIC_TUPLE,
- PIC_CHECK_TAG,
- PIC_CHECK_TUPLE,
- PIC_HIT,
- PIC_MISS_WORD,
- PIC_MISS_TAIL_WORD,
-
- /* Megamorphic cache generation in dispatch.c */
- MEGA_LOOKUP = 57,
- MEGA_LOOKUP_WORD,
- MEGA_MISS_WORD,
-
- OBJ_UNDEFINED = 60, /* default quotation for undefined words */
-
- OBJ_STDERR = 61, /* stderr FILE* handle */
-
- OBJ_STAGE2 = 62, /* have we bootstrapped? */
-
- OBJ_CURRENT_THREAD = 63,
-
- OBJ_THREADS = 64,
- OBJ_RUN_QUEUE = 65,
- OBJ_SLEEP_QUEUE = 66,
-};
-
-#define OBJ_FIRST_SAVE OBJ_BOOT
-#define OBJ_LAST_SAVE OBJ_STAGE2
-
-inline static bool save_env_p(cell i)
-{
- return (i >= OBJ_FIRST_SAVE && i <= OBJ_LAST_SAVE);
}
-
-}
-
-
unsigned int signal_fpu_status;
stack_frame *signal_callstack_top;
- /* A heap walk allows useful things to be done, like finding all
- references to an object for debugging purposes. */
- cell heap_scan_ptr;
-
/* GC is off during heap walking */
bool gc_off;
void primitive_set_datastack();
void primitive_set_retainstack();
void primitive_check_datastack();
+ void primitive_load_locals();
template<typename Iterator> void iterate_active_frames(Iterator &iter)
{
}
// run
- void primitive_getenv();
- void primitive_setenv();
void primitive_exit();
void primitive_micros();
void primitive_sleep();
void primitive_set_slot();
- void primitive_load_locals();
+
+ // objects
+ void primitive_special_object();
+ void primitive_set_special_object();
+ cell object_size(cell tagged);
cell clone_object(cell obj_);
void primitive_clone();
+ void primitive_become();
// profiler
void init_profiler();
void primitive_data_room();
void begin_scan();
void end_scan();
- void primitive_begin_scan();
- cell next_object();
- void primitive_next_object();
- void primitive_end_scan();
+ cell instances(cell type);
+ void primitive_all_instances();
cell find_all_words();
- cell object_size(cell tagged);
+
+ template<typename Generation, typename Iterator>
+ inline void each_object(Generation *gen, Iterator &iterator)
+ {
+ cell obj = gen->first_object();
+ while(obj)
+ {
+ iterator((object *)obj);
+ obj = gen->next_object_after(obj);
+ }
+ }
template<typename Iterator> inline void each_object(Iterator &iterator)
{
- begin_scan();
- cell obj;
- while(to_boolean(obj = next_object()))
- iterator(obj);
- end_scan();
+ gc_off = true;
+
+ each_object(data->tenured,iterator);
+ each_object(data->aging,iterator);
+ each_object(data->nursery,iterator);
+
+ gc_off = false;
}
/* the write barrier must be called any time we are potentially storing a
*(char *)(decks_offset + ((cell)slot_ptr >> deck_bits)) = card_mark_mask;
}
+ inline void write_barrier(object *obj, cell size)
+ {
+ char *start = (char *)obj;
+ for(cell offset = 0; offset < size; offset += card_size)
+ write_barrier((cell *)(start + offset));
+ }
+
// gc
void end_gc();
void start_gc_again();
void primitive_minor_gc();
void primitive_full_gc();
void primitive_compact_gc();
- void primitive_become();
void inline_gc(cell *data_roots_base, cell data_roots_size);
void primitive_enable_gc_events();
void primitive_disable_gc_events();
void jit_compile_word(cell word_, cell def_, bool relocate);
void update_code_heap_words();
void update_code_heap_words_and_literals();
- void relocate_code_heap();
void primitive_modify_code_heap();
code_heap_room code_room();
void primitive_code_room();
/* Every object has a regular representation in the runtime, which makes GC
much simpler. Every slot of the object until binary_payload_start is a pointer
to some other object. */
- template<typename Iterator> void do_slots(cell obj, Iterator &iter)
+ template<typename Iterator> void do_slots(object *obj, Iterator &iter)
{
- cell scan = obj;
- cell payload_start = ((object *)obj)->binary_payload_start();
- cell end = obj + payload_start;
+ cell scan = (cell)obj;
+ cell payload_start = obj->binary_payload_start();
+ cell end = scan + payload_start;
scan += sizeof(cell);
projects / factor.git / commitdiff