steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
John Benediktsson 2009-01-25 21:27:56 -08:00
parent 5713430615 3458f8bbef
commit 394447ec86
55 changed files with 1810 additions and 1730 deletions

18
Makefile
View File

@ -25,23 +25,25 @@ ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/alien.o \
vm/bignum.o \
vm/callstack.o \
vm/code_block.o \
vm/code_gc.o \
vm/code_heap.o \
vm/data_gc.o \
vm/data_heap.o \
vm/debug.o \
vm/errors.o \
vm/factor.o \
vm/ffi_test.o \
vm/image.o \
vm/io.o \
vm/math.o \
vm/data_gc.o \
vm/code_gc.o \
vm/primitives.o \
vm/run.o \
vm/callstack.o \
vm/types.o \
vm/profiler.o \
vm/quotations.o \
vm/utilities.o \
vm/errors.o \
vm/profiler.o
vm/run.o \
vm/types.o \
vm/utilities.o
EXE_OBJS = $(PLAF_EXE_OBJS)

11
basis/ascii/ascii-docs.factor
View File

@ -57,8 +57,10 @@ HELP: >upper
{ $values { "str" "a string" } { "upper" "a string" } }
{ $description "Converts an ASCII string to upper case." } ;
ARTICLE: "ascii" "ASCII character classes"
"The " { $vocab-link "ascii" } " vocabulary implements traditional ASCII character classes:"
ARTICLE: "ascii" "ASCII"
"The " { $vocab-link "ascii" } " vocabulary implements support for the legacy ASCII character set. Most applications should use " { $link "unicode" } " instead."
$nl
"ASCII character classes:"
{ $subsection blank? }
{ $subsection letter? }
{ $subsection LETTER? }
@ -67,11 +69,10 @@ ARTICLE: "ascii" "ASCII character classes"
{ $subsection control? }
{ $subsection quotable? }
{ $subsection ascii? }
"ASCII case conversion is also implemented:"
"ASCII case conversion:"
{ $subsection ch>lower }
{ $subsection ch>upper }
{ $subsection >lower }
{ $subsection >upper }
"Modern applications should use Unicode 5.1 instead (" { $vocab-link "unicode.categories" } ")." ;
{ $subsection >upper } ;
ABOUT: "ascii"

44
basis/ascii/ascii.factor
View File

@ -1,41 +1,23 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order sequences
combinators.short-circuit ;
USING: kernel math math.order sequences strings
combinators.short-circuit hints ;
IN: ascii
: ascii? ( ch -- ? ) 0 127 between? ; inline
: blank? ( ch -- ? ) " \t\n\r" member? ; inline
: letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline
: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline
: digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline
: printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline
: control? ( ch -- ? ) "\0\e\r\n\t\u000008\u00007f" member? ; inline
: quotable? ( ch -- ? ) { [ printable? ] [ "\"\\" member? not ] } 1&& ; inline
: Letter? ( ch -- ? ) { [ letter? ] [ LETTER? ] } 1|| ; inline
: alpha? ( ch -- ? ) { [ Letter? ] [ digit? ] } 1|| ; inline
: ch>lower ( ch -- lower ) dup LETTER? [ HEX: 20 + ] when ; inline
: >lower ( str -- lower ) [ ch>lower ] map ;
: ch>upper ( ch -- upper ) dup letter? [ HEX: 20 - ] when ; inline
: >upper ( str -- upper ) [ ch>upper ] map ;
: control? ( ch -- ? )
"\0\e\r\n\t\u000008\u00007f" member? ; inline
: quotable? ( ch -- ? )
dup printable? [ "\"\\" member? not ] [ drop f ] if ; inline
: Letter? ( ch -- ? )
[ [ letter? ] [ LETTER? ] ] 1|| ;
: alpha? ( ch -- ? )
[ [ Letter? ] [ digit? ] ] 1|| ;
: ch>lower ( ch -- lower )
dup CHAR: A CHAR: Z between? [ HEX: 20 + ] when ;
: >lower ( str -- lower )
[ ch>lower ] map ;
: ch>upper ( ch -- upper )
dup CHAR: a CHAR: z between? [ HEX: 20 - ] when ;
: >upper ( str -- upper )
[ ch>upper ] map ;
HINTS: >lower string ;
HINTS: >upper string ;

18
basis/bootstrap/image/image.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays byte-arrays generic assocs hashtables assocs
hashtables.private io io.binary io.files io.encodings.binary
@ -8,9 +8,9 @@ vectors words quotations assocs system layouts splitting
grouping growable classes classes.builtin classes.tuple
classes.tuple.private words.private vocabs
vocabs.loader source-files definitions debugger
quotations.private sequences.private combinators
quotations.private sequences.private combinators combinators.smart
math.order math.private accessors
slots.private compiler.units ;
slots.private compiler.units fry ;
IN: bootstrap.image
: arch ( os cpu -- arch )
@ -73,7 +73,7 @@ SYMBOL: objects
: put-object ( n obj -- ) (objects) set-at ;
: cache-object ( obj quot -- value )
[ (objects) ] dip [ obj>> ] prepose cache ; inline
[ (objects) ] dip '[ obj>> @ ] cache ; inline
! Constants
@ -95,7 +95,7 @@ SYMBOL: objects
SYMBOL: sub-primitives
: make-jit ( quot rc rt offset -- quad )
{ [ { } make ] [ ] [ ] [ ] } spread 4array ; inline
[ [ { } make ] 3dip ] output>array ; inline
: jit-define ( quot rc rt offset name -- )
[ make-jit ] dip set ; inline
@ -524,11 +524,9 @@ M: quotation '
! Image output
: (write-image) ( image -- )
bootstrap-cell big-endian get [
[ >be write ] curry each
] [
[ >le write ] curry each
] if ;
bootstrap-cell big-endian get
[ '[ _ >be write ] each ]
[ '[ _ >le write ] each ] if ;
: write-image ( image -- )
"Writing image to " write

1
basis/bootstrap/unicode/unicode.factor
View File

@ -0,0 +1 @@
USE: unicode

2
basis/compiler/compiler.factor
View File

@ -110,7 +110,7 @@ t compile-dependencies? set-global
[ (compile) yield-hook get call ] slurp-deque ;
: decompile ( word -- )
f 2array 1array t modify-code-heap ;
f 2array 1array modify-code-heap ;
: optimized-recompile-hook ( words -- alist )
[

9
basis/deques/deques.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences math ;
USING: kernel sequences math fry ;
IN: deques
GENERIC: push-front* ( obj deque -- node )
@ -34,7 +34,8 @@ GENERIC: deque-empty? ( deque -- ? )
[ peek-back ] [ pop-back* ] bi ;
: slurp-deque ( deque quot -- )
[ drop [ deque-empty? not ] curry ]
[ [ pop-back ] prepose curry ] 2bi [ ] while ; inline
[ drop '[ _ deque-empty? not ] ]
[ '[ _ pop-back @ ] ]
2bi [ ] while ; inline
MIXIN: deque

17
basis/dlists/dlists.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman,
! Copyright (C) 2007, 2009 Mackenzie Straight, Doug Coleman,
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel math sequences accessors deques
search-deques summary hashtables ;
search-deques summary hashtables fry ;
IN: dlists
<PRIVATE
@ -64,7 +64,7 @@ M: dlist-node node-value obj>> ;
[ front>> ] dip (dlist-find-node) ; inline
: dlist-each-node ( dlist quot -- )
[ f ] compose dlist-find-node 2drop ; inline
'[ @ f ] dlist-find-node 2drop ; inline
: unlink-node ( dlist-node -- )
dup prev>> over next>> set-prev-when
@ -115,8 +115,7 @@ M: dlist pop-back* ( dlist -- )
normalize-front ;
: dlist-find ( dlist quot -- obj/f ? )
[ obj>> ] prepose
dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
'[ obj>> @ ] dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
: dlist-contains? ( dlist quot -- ? )
dlist-find nip ; inline
@ -143,7 +142,7 @@ M: dlist delete-node ( dlist-node dlist -- )
] if ; inline
: delete-node-if ( dlist quot -- obj/f )
[ obj>> ] prepose delete-node-if* drop ; inline
'[ obj>> @ ] delete-node-if* drop ; inline
M: dlist clear-deque ( dlist -- )
f >>front
@ -151,7 +150,7 @@ M: dlist clear-deque ( dlist -- )
drop ;
: dlist-each ( dlist quot -- )
[ obj>> ] prepose dlist-each-node ; inline
'[ obj>> @ ] dlist-each-node ; inline
: dlist>seq ( dlist -- seq )
[ ] accumulator [ dlist-each ] dip ;
@ -159,8 +158,6 @@ M: dlist clear-deque ( dlist -- )
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
M: dlist clone
<dlist> [
[ push-back ] curry dlist-each
] keep ;
<dlist> [ '[ _ push-back ] dlist-each ] keep ;
INSTANCE: dlist deque

4
basis/grouping/grouping.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order strings arrays vectors sequences
sequences.private accessors ;
sequences.private accessors fry ;
IN: grouping
<PRIVATE
@ -94,7 +94,7 @@ INSTANCE: sliced-clumps slice-chunking
[ first2-unsafe ] dip call
] [
[ 2 <sliced-clumps> ] dip
[ first2-unsafe ] prepose all?
'[ first2-unsafe @ ] all?
] if
] if ; inline

29
basis/interpolate/interpolate.factor
View File

@ -1,9 +1,11 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel macros make multiline namespaces parser
present sequences strings splitting fry accessors ;
IN: interpolate
<PRIVATE
TUPLE: interpolate-var name ;
: (parse-interpolate) ( string -- )
@ -20,21 +22,22 @@ TUPLE: interpolate-var name ;
: parse-interpolate ( string -- seq )
[ (parse-interpolate) ] { } make ;
MACRO: interpolate ( string -- )
parse-interpolate [
: (interpolate) ( string quot -- quot' )
[ parse-interpolate ] dip '[
dup interpolate-var?
[ name>> '[ _ get present write ] ]
[ name>> @ '[ _ @ present write ] ]
[ '[ _ write ] ]
if
] map [ ] join ;
] map [ ] join ; inline
: interpolate-locals ( string -- quot )
parse-interpolate [
dup interpolate-var?
[ name>> search '[ _ present write ] ]
[ '[ _ write ] ]
if
] map [ ] join ;
[ search [ ] ] (interpolate) ;
: I[ "]I" parse-multiline-string
interpolate-locals parsed \ call parsed ; parsing
PRIVATE>
MACRO: interpolate ( string -- )
[ [ get ] ] (interpolate) ;
: I[
"]I" parse-multiline-string
interpolate-locals over push-all ; parsing

6
basis/locals/locals-tests.factor
View File

@ -490,4 +490,8 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ 10 ] [
[| | 0 '[ [let | A [ 10 ] | A _ + ] ] call ] call
] unit-test
] unit-test
! Discovered by littledan
[ "bar" ] [ [let | a [ [let | foo [ "bar" ] | foo ] ] | a ] ] unit-test
[ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test

32
basis/locals/parser/parser.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators effects.parser
generic.parser kernel lexer locals.errors
generic.parser kernel lexer locals.errors fry
locals.rewrite.closures locals.types make namespaces parser
quotations sequences splitting words vocabs.parser ;
IN: locals.parser
@ -56,19 +56,21 @@ SYMBOL: in-lambda?
(parse-bindings)
] [ 2drop ] if ;
: with-bindings ( quot -- words assoc )
'[
in-lambda? on
_ H{ } make-assoc
] { } make swap ; inline
: parse-bindings ( end -- bindings vars )
[
[ (parse-bindings) ] H{ } make-assoc
] { } make swap ;
[ (parse-bindings) ] with-bindings ;
: parse-bindings* ( end -- words assoc )
[
[
namespace push-locals
(parse-bindings)
namespace pop-locals
] { } make-assoc
] { } make swap ;
namespace push-locals
(parse-bindings)
namespace pop-locals
] with-bindings ;
: (parse-wbindings) ( end -- )
dup parse-binding dup [
@ -77,9 +79,7 @@ SYMBOL: in-lambda?
] [ 2drop ] if ;
: parse-wbindings ( end -- bindings vars )
[
[ (parse-wbindings) ] H{ } make-assoc
] { } make swap ;
[ (parse-wbindings) ] with-bindings ;
: parse-locals ( -- vars assoc )
"(" expect ")" parse-effect
@ -88,8 +88,8 @@ SYMBOL: in-lambda?
: parse-locals-definition ( word -- word quot )
parse-locals \ ; (parse-lambda) <lambda>
2dup "lambda" set-word-prop
rewrite-closures dup length 1 = [ first ] [ bad-lambda-rewrite ] if ;
[ "lambda" set-word-prop ]
[ rewrite-closures dup length 1 = [ first ] [ bad-lambda-rewrite ] if ] 2bi ;
: (::) ( -- word def ) CREATE-WORD parse-locals-definition ;

14
basis/regexp/regexp-tests.factor
View File

@ -287,9 +287,13 @@ IN: regexp-tests
[ { "1" "2" "3" "4" } ]
[ "1ABC2DEF3GHI4" R/ [A-Z]+/ re-split [ >string ] map ] unit-test
[ { "1" "2" "3" "4" } ]
[ { "1" "2" "3" "4" "" } ]
[ "1ABC2DEF3GHI4JK" R/ [A-Z]+/ re-split [ >string ] map ] unit-test
[ { "" } ] [ "" R/ =/ re-split [ >string ] map ] unit-test
[ { "a" "" } ] [ "a=" R/ =/ re-split [ >string ] map ] unit-test
[ { "ABC" "DEF" "GHI" } ]
[ "1ABC2DEF3GHI4" R/ [A-Z]+/ all-matches [ >string ] map ] unit-test
@ -299,14 +303,16 @@ IN: regexp-tests
[ 0 ]
[ "123" R/ [A-Z]+/ count-matches ] unit-test
[ "1.2.3.4" ]
[ "1.2.3.4." ]
[ "1ABC2DEF3GHI4JK" R/ [A-Z]+/ "." re-replace ] unit-test
[ "-- title --" ] [ "== title ==" R/ =/ "-" re-replace ] unit-test
/*
! FIXME
[ f ] [ "ab" "a(?!b)" <regexp> first-match ] unit-test
[ "a" ] [ "ac" "a(?!b)" <regexp> first-match >string ] unit-test
! [ t ] [ "fxxbar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
[ t ] [ "fxxbar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
[ f ] [ "foobar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
[ "a" ] [ "ab" "a(?=b)(?=b)" <regexp> first-match >string ] unit-test
[ "a" ] [ "ba" "a(?<=b)(?<=b)" <regexp> first-match >string ] unit-test
@ -317,7 +323,7 @@ IN: regexp-tests
*/
! Bug in parsing word
[ t ] [ "a" R' a' matches? ] unit-test
[ t ] [ "a" R' a' matches? ] unit-test
! Convert to lowercase until E
[ f ] [ "AA" R/ \LAA\E/ matches? ] unit-test

5
basis/regexp/regexp.factor
View File

@ -61,8 +61,11 @@ IN: regexp
dupd first-match
[ split1-slice swap ] [ "" like f swap ] if* ;
: (re-split) ( string regexp -- )
over [ [ re-cut , ] keep (re-split) ] [ 2drop ] if ;
: re-split ( string regexp -- seq )
[ dup length 0 > ] swap '[ _ re-cut ] [ ] produce nip ;
[ (re-split) ] { } make ;
: re-replace ( string regexp replacement -- result )
[ re-split ] dip join ;

2
basis/stack-checker/known-words/known-words.factor
View File

@ -643,7 +643,7 @@ M: object infer-call*
\ dll-valid? { object } { object } define-primitive
\ modify-code-heap { array object } { } define-primitive
\ modify-code-heap { array } { } define-primitive
\ unimplemented { } { } define-primitive

2
basis/ui/gadgets/gadgets.factor
View File

@ -315,7 +315,7 @@ SYMBOL: in-layout?
: (screen-rect) ( gadget -- loc ext )
dup parent>> [
[ rect-extent ] dip (screen-rect)
[ [ nip ] [ v+ ] 2bi ] dip [ vmin ] [ v+ ] 2bi*
[ [ nip ] [ v+ ] 2bi ] dip [ v+ ] [ vmin ] 2bi*
] [
rect-extent
] if* ;

36
basis/unicode/categories/categories-docs.factor
View File

@ -1,49 +1,59 @@
! Copyright (C) 2009 Your name.
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel ;
IN: unicode.categories
HELP: LETTER
{ $class-description "The class of upper cased letters" } ;
{ $class-description "The class of upper cased letters." } ;
HELP: Letter
{ $class-description "The class of letters" } ;
{ $class-description "The class of letters." } ;
HELP: alpha
{ $class-description "The class of code points which are alphanumeric" } ;
{ $class-description "The class of alphanumeric characters." } ;
HELP: blank
{ $class-description "The class of code points which are whitespace" } ;
{ $class-description "The class of whitespace characters." } ;
HELP: character
{ $class-description "The class of numbers which are pre-defined Unicode code points" } ;
{ $class-description "The class of pre-defined Unicode code points." } ;
HELP: control
{ $class-description "The class of control characters" } ;
{ $class-description "The class of control characters." } ;
HELP: digit
{ $class-description "The class of code coints which are digits" } ;
{ $class-description "The class of digits." } ;
HELP: letter
{ $class-description "The class of code points which are lower-cased letters" } ;
{ $class-description "The class of lower-cased letters." } ;
HELP: printable
{ $class-description "The class of characters which are printable, as opposed to being control or formatting characters" } ;
{ $class-description "The class of characters which are printable, as opposed to being control or formatting characters." } ;
HELP: uncased
{ $class-description "The class of letters which don't have a case" } ;
{ $class-description "The class of letters which don't have a case." } ;
ARTICLE: "unicode.categories" "Character classes"
{ $vocab-link "unicode.categories" } " is a vocabulary which provides predicates for determining if a code point has a particular property, for example being a lower cased letter. These should be used in preference to the " { $vocab-link "ascii" } " equivalents in most cases. Below are links to classes of characters, but note that each of these also has a predicate defined, which is usually more useful."
"The " { $vocab-link "unicode.categories" } " vocabulary implements predicates for determining if a code point has a particular property, for example being a lower cased letter. These should be used in preference to the " { $vocab-link "ascii" } " equivalents in most cases. Each character class has an associated predicate word."
{ $subsection blank }
{ $subsection blank? }
{ $subsection letter }
{ $subsection letter? }
{ $subsection LETTER }
{ $subsection LETTER? }
{ $subsection Letter }
{ $subsection Letter? }
{ $subsection digit }
{ $subsection digit? }
{ $subsection printable }
{ $subsection printable? }
{ $subsection alpha }
{ $subsection alpha? }
{ $subsection control }
{ $subsection control? }
{ $subsection uncased }
{ $subsection character } ;
{ $subsection uncased? }
{ $subsection character }
{ $subsection character? } ;
ABOUT: "unicode.categories"

16
basis/unicode/normalize/normalize-docs.factor
View File

@ -4,7 +4,13 @@ IN: unicode.normalize
ABOUT: "unicode.normalize"
ARTICLE: "unicode.normalize" "Unicode normalization"
"The " { $vocab-link "unicode.normalize" "unicode.normalize" } " vocabulary defines words for normalizing Unicode strings. In Unicode, it is often possible to have multiple sequences of characters which really represent exactly the same thing. For example, to represent e with an acute accent above, there are two possible strings: \"e\\u000301\" (the e character, followed by the combining acute accent character) and \"\\u0000e9\" (a single character, e with an acute accent). There are four normalization forms: NFD, NFC, NFKD, and NFKC. Basically, in NFD and NFKD, everything is expanded, whereas in NFC and NFKC, everything is contracted. In NFKD and NFKC, more things are expanded and contracted. This is a process which loses some information, so it should be done only with care. Most of the world uses NFC to communicate, but for many purposes, NFD/NFKD is easier to process. For more information, see Unicode Standard Annex #15 and section 3 of the Unicode standard."
"The " { $vocab-link "unicode.normalize" "unicode.normalize" } " vocabulary defines words for normalizing Unicode strings."
$nl
"In Unicode, it is often possible to have multiple sequences of characters which really represent exactly the same thing. For example, to represent e with an acute accent above, there are two possible strings: " { $snippet "\"e\\u000301\"" } " (the e character, followed by the combining acute accent character) and " { $snippet "\"\\u0000e9\"" } " (a single character, e with an acute accent)."
$nl
"There are four normalization forms: NFD, NFC, NFKD, and NFKC. Basically, in NFD and NFKD, everything is expanded, whereas in NFC and NFKC, everything is contracted. In NFKD and NFKC, more things are expanded and contracted. This is a process which loses some information, so it should be done only with care."
$nl
"Most of the world uses NFC to communicate, but for many purposes, NFD/NFKD is easier to process. For more information, see Unicode Standard Annex #15 and section 3 of the Unicode standard."
{ $subsection nfc }
{ $subsection nfd }
{ $subsection nfkc }
@ -12,16 +18,16 @@ ARTICLE: "unicode.normalize" "Unicode normalization"
HELP: nfc
{ $values { "string" string } { "nfc" "a string in NFC" } }
{ $description "Converts a string to Normalization Form C" } ;
{ $description "Converts a string to Normalization Form C." } ;
HELP: nfd
{ $values { "string" string } { "nfd" "a string in NFD" } }
{ $description "Converts a string to Normalization Form D" } ;
{ $description "Converts a string to Normalization Form D." } ;
HELP: nfkc
{ $values { "string" string } { "nfkc" "a string in NFKC" } }
{ $description "Converts a string to Normalization Form KC" } ;
{ $description "Converts a string to Normalization Form KC." } ;
HELP: nfkd
{ $values { "string" string } { "nfkd" "a string in NFKD" } }
{ $description "Converts a string to Normalization Form KD" } ;
{ $description "Converts a string to Normalization Form KD." } ;

12
basis/unicode/unicode-docs.factor
View File

@ -1,8 +1,14 @@
USING: help.markup help.syntax ;
USING: help.markup help.syntax strings ;
IN: unicode
ARTICLE: "unicode" "Unicode"
"Unicode is a set of characters, or " { $emphasis "code points" } " covering what's used in most world writing systems. Any Factor string can hold any of these code points transparently; a factor string is a sequence of Unicode code points. Unicode is accompanied by several standard algorithms for common operations like encoding in files, capitalizing a string, finding the boundaries between words, etc. When a programmer is faced with a string manipulation problem, where the string represents human language, a Unicode algorithm is often much better than the naive one. This is not in terms of efficiency, but rather internationalization. Even English text that remains in ASCII is better served by the Unicode collation algorithm than a naive algorithm. The Unicode algorithms implemented here are:"
"The " { $vocab-link "unicode" } " vocabulary and its sub-vocabularies implement support for the Unicode 5.1 character set."
$nl
"The Unicode character set contains most of the world's writing systems. Unicode is intended as a replacement for, and is a superset of, such legacy character sets as ASCII, Latin1, MacRoman, and so on. Unicode characters are called " { $emphasis "code points" } "; Factor's " { $link "strings" } " are sequences of code points."
$nl
"The Unicode character set is accompanied by several standard algorithms for common operations like encoding text in files, capitalizing a string, finding the boundaries between words, and so on."
$nl
"The Unicode algorithms implemented by the " { $vocab-link "unicode" } " vocabulary are:"
{ $vocab-subsection "Case mapping" "unicode.case" }
{ $vocab-subsection "Collation and weak comparison" "unicode.collation" }
{ $vocab-subsection "Character classes" "unicode.categories" }
@ -11,6 +17,6 @@ ARTICLE: "unicode" "Unicode"
"The following are mostly for internal use:"
{ $vocab-subsection "Unicode syntax" "unicode.syntax" }
{ $vocab-subsection "Unicode data tables" "unicode.data" }
{ $see-also "io.encodings" } ;
{ $see-also "ascii" "io.encodings" } ;
ABOUT: "unicode"

4
basis/unix/process/process.factor
View File

@ -1,6 +1,6 @@
USING: kernel alien.c-types alien.strings sequences math alien.syntax unix
vectors kernel namespaces continuations threads assocs vectors
io.backend.unix io.encodings.utf8 unix.utilities ;
io.backend.unix io.encodings.utf8 unix.utilities fry ;
IN: unix.process
! Low-level Unix process launching utilities. These are used
@ -36,7 +36,7 @@ FUNCTION: int execve ( char* path, char** argv, char** envp ) ;
[ [ first ] [ ] bi ] dip exec-with-env ;
: with-fork ( child parent -- )
[ [ fork-process dup zero? ] dip [ drop ] prepose ] dip
[ [ fork-process dup zero? ] dip '[ drop @ ] ] dip
if ; inline
CONSTANT: SIGKILL 9

1
core/bootstrap/stage1.factor
View File

@ -21,6 +21,7 @@ load-help? off
! 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

2
core/compiler/units/units-tests.factor
View File

@ -11,7 +11,7 @@ accessors namespaces fry ;
! Non-optimizing compiler bugs
[ 1 1 ] [
"A" "B" <word> [ [ 1 ] dip ] >>def dup f 2array 1array f modify-code-heap
"A" "B" <word> [ [ 1 ] dip ] >>def dup f 2array 1array modify-code-heap
1 swap execute
] unit-test

6
core/compiler/units/units.factor
View File

@ -66,9 +66,7 @@ GENERIC: definitions-changed ( assoc obj -- )
dup dup changed-vocabs update ;
: compile ( words -- )
recompile-hook get call
dup [ drop crossref? ] assoc-contains?
modify-code-heap ;
recompile-hook get call modify-code-heap ;
SYMBOL: outdated-tuples
SYMBOL: update-tuples-hook
@ -145,7 +143,7 @@ SYMBOL: remake-generics-hook
call-recompile-hook
call-update-tuples-hook
unxref-forgotten-definitions
dup [ drop crossref? ] assoc-contains? modify-code-heap ;
modify-code-heap ;
: with-nested-compilation-unit ( quot -- )
[

2
core/memory/memory-docs.factor
View File

@ -3,7 +3,7 @@ quotations math ;
IN: memory
HELP: begin-scan ( -- )
{ $description "Moves all objects to tenured space, 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."
{ $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." } ;

2
core/memory/memory.factor
View File

@ -9,7 +9,7 @@ IN: memory
] [ 2drop ] if ; inline recursive
: each-object ( quot -- )
begin-scan [ (each-object) ] [ end-scan ] [ ] cleanup ; inline
gc begin-scan [ (each-object) ] [ end-scan ] [ ] cleanup ; inline
: count-instances ( quot -- n )
0 swap [ 1 0 ? + ] compose each-object ; inline

5
core/strings/strings-docs.factor
View File

@ -22,9 +22,8 @@ $nl
{ $subsection 1string }
"Since strings are sequences, basic string manipulation can be performed using sequence operations (" { $link "sequences" } "). More advanced functionality can be found in other vocabularies, including but not limited to:"
{ $list
{ { $vocab-link "ascii" } " - traditional ASCII character classes" }
{ { $vocab-link "unicode.categories" } " - Unicode character classes" }
{ { $vocab-link "unicode.case" } " - Unicode case conversion" }
{ { $link "ascii" } " - ASCII algorithms for interoperability with legacy applications" }
{ { $link "unicode" } " - Unicode algorithms for modern multilingual applications" }
{ { $vocab-link "regexp" } " - regular expressions" }
{ { $vocab-link "peg" } " - parser expression grammars" }
} ;

205
misc/fuel/README
View File

@ -1,4 +1,4 @@
FUEL, Factor's Ultimate Emacs Library -*- org -*-
FUEL, Factor's Ultimate Emacs Library
-------------------------------------
FUEL provides a complete environment for your Factor coding pleasure
@ -29,47 +29,46 @@ beast.
* Basic usage
*** Running the listener
If you're using the default factor binary and images locations inside
the Factor's source tree, that should be enough to start using FUEL.
Editing any file with the extension .factor will put you in
factor-mode; try C-hm for a summary of available commands.
If you're using the default factor binary and images locations inside
the Factor's source tree, that should be enough to start using FUEL.
Editing any file with the extension .factor will put you in
factor-mode; try C-hm for a summary of available commands.
To start the listener, try M-x run-factor.
To start the listener, try M-x run-factor.
By default, FUEL will try to use the binary and image files in the
factor installation directory. You can customize them with:
By default, FUEL will try to use the binary and image files in the
factor installation directory. You can customize them with:
(setq fuel-listener-factor-binary <full path to factor>)
(setq fuel-listener-factor-image <full path to factor image>)
Many aspects of the environment can be customized:
M-x customize-group fuel will show you how many.
Many aspects of the environment can be customized:
M-x customize-group fuel will show you how many.
*** Faster listener startup
On startup, run-factor loads the fuel vocabulary, which can take a
while. If you want to speedup the load process, type 'save' in the
listener prompt just after invoking run-factor. This will save a
factor image (overwriting the current one) with all the needed
vocabs.
On startup, run-factor loads the fuel vocabulary, which can take a
while. If you want to speedup the load process, type 'save' in the
listener prompt just after invoking run-factor. This will save a
factor image (overwriting the current one) with all the needed
vocabs.
*** Connecting to a running Factor
'run-factor' starts a new factor listener process managed by Emacs.
If you prefer to start Factor externally, you can also connect
remotely from Emacs. Here's how to proceed:
'run-factor' starts a new factor listener process managed by Emacs.
If you prefer to start Factor externally, you can also connect
remotely from Emacs. Here's how to proceed:
- In the factor listener, run FUEL:
"fuel" run
This will start a server listener in port 9000.
- Switch to Emacs and issue the command 'M-x connect-to-factor'.
- In the factor listener, run FUEL: "fuel" run
This will start a server listener in port 9000.
- Switch to Emacs and issue the command 'M-x connect-to-factor'.
That's it; you should be up and running. See the help for
'connect-to-factor' for how to use a different port.
*** Vocabulary creation
FUEL offers a basic interface with Factor's scaffolding utilities.
FUEL offers a basic interface to Factor's scaffolding utilities.
To create a new vocabulary directory and associated files:
M-x fuel-scaffold-vocab
@ -81,91 +80,107 @@ beast.
* Quick key reference
(Triple chords ending in a single letter <x> accept also C-<x> (e.g.
C-cC-eC-r is the same as C-cC-er)).
Triple chords ending in a single letter <x> accept also C-<x> (e.g.
C-cC-eC-r is the same as C-cC-er).
*** In factor source files:
- C-cz : switch to listener
- C-co : cycle between code, tests and docs factor files
- C-cs : switch to other factor buffer (M-x fuel-switch-to-buffer)
- C-cr : switch to listener and refresh all loaded vocabs
- C-x4s : switch to other factor buffer in other window
- C-x5s : switch to other factor buffer in other frame
Commands in parenthesis can be invoked interactively with
M-x <command>, not necessarily in a factor buffer.
- M-. : edit word at point in Emacs (see fuel-edit-word-method custom var)
- M-, : go back to where M-. was last invoked
- M-TAB : complete word at point
- C-cC-eu : update USING: line
- C-cC-ev : edit vocabulary (M-x fuel-edit-vocabulary)
- C-cC-ew : edit word (M-x fuel-edit-word-at-point)
- C-cC-ed : edit word's doc (M-x fuel-edit-word-at-point)
- C-cC-er : eval region
- C-M-r, C-cC-ee : eval region, extending it to definition boundaries
- C-M-x, C-cC-ex : eval definition around point
- C-ck, C-cC-ek : run file
- C-cC-da : toggle autodoc mode
- C-cC-dd : help for word at point
- C-cC-ds : short help word at point
- C-cC-de : show stack effect of current sexp (with prefix, region)
- C-cC-dp : find words containing given substring (M-x fuel-apropos)
- C-cC-dv : show words in current file (with prefix, ask for vocab)
- C-cM-<, C-cC-d< : show callers of word or vocabulary at point
(M-x fuel-show-callers, M-x fuel-vocab-usage)
- C-cM->, C-cC-d> : show callees of word or vocabulary at point
(M-x fuel-show-callees, M-x fuel-vocab-uses)
- C-cC-xs : extract innermost sexp (up to point) as a separate word
- C-cC-xr : extract region as a separate word
- C-cC-xi : replace word at point by its definition
- C-cC-xv : extract region as a separate vocabulary
- C-cC-xw : rename all uses of a word
|-----------------+------------------------------------------------------------|
| C-cz | switch to listener (run-factor) |
| C-co | cycle between code, tests and docs files |
| C-cr | switch to listener and refresh all loaded vocabs |
| C-cs | switch to other factor buffer (fuel-switch-to-buffer) |
| C-x4s | switch to other factor buffer in other window |
| C-x5s | switch to other factor buffer in other frame |
|-----------------+------------------------------------------------------------|
| M-. | edit word at point in Emacs (fuel-edit-word) |
| M-, | go back to where M-. was last invoked |
| M-TAB | complete word at point |
| C-cC-eu | update USING: line (fuel-update-usings) |
| C-cC-ev | edit vocabulary (fuel-edit-vocabulary) |
| C-cC-ew | edit word (fuel-edit-word-at-point) |
| C-cC-ed | edit word's doc (C-u M-x fuel-edit-word-doc-at-point) |
|-----------------+------------------------------------------------------------|
| C-cC-er | eval region |
| C-M-r, C-cC-ee | eval region, extending it to definition boundaries |
| C-M-x, C-cC-ex | eval definition around point |
| C-ck, C-cC-ek | run file (fuel-run-file) |
|-----------------+------------------------------------------------------------|
| C-cC-da | toggle autodoc mode (fuel-autodoc-mode) |
| C-cC-dd | help for word at point (fuel-help) |
| C-cC-ds | short help word at point (fuel-help-short) |
| C-cC-de | show stack effect of current sexp (with prefix, region) |
| C-cC-dp | find words containing given substring (fuel-apropos) |
| C-cC-dv | show words in current file (with prefix, ask for vocab) |
|-----------------+------------------------------------------------------------|
| C-cM-<, C-cC-d< | show callers of word or vocabulary at point |
| | (fuel-show-callers, fuel-vocab-usage) |
| C-cM->, C-cC-d> | show callees of word or vocabulary at point |
| | (fuel-show-callees, fuel-vocab-uses) |
|-----------------+------------------------------------------------------------|
| C-cC-xs | extract innermost sexp (up to point) as a separate word |
| | (fuel-refactor-extract-sexp) |
| C-cC-xr | extract region as a separate word |
| | (fuel-refactor-extract-region) |
| C-cC-xv | extract region as a separate vocabulary |
| | (fuel-refactor-extract-vocab) |
| C-cC-xi | replace word by its definition (fuel-refactor-inline-word) |
| C-cC-xw | rename all uses of a word (fuel-refactor-rename-word) |
|-----------------+------------------------------------------------------------|
*** In the listener:
- TAB : complete word at point
- M-. : edit word at point in Emacs
- C-cr : refresh all loaded vocabs
- C-ca : toggle autodoc mode
- C-cp : find words containing given substring (M-x fuel-apropos)
- C-cs : toggle stack mode
- C-cv : edit vocabulary
- C-ch : help for word at point
- C-ck : run file
|------+----------------------------------------------------------|
| TAB | complete word at point |
| M-. | edit word at point in Emacs |
| C-cr | refresh all loaded vocabs |
| C-ca | toggle autodoc mode |
| C-cp | find words containing given substring (M-x fuel-apropos) |
| C-cs | toggle stack mode |
| C-cv | edit vocabulary |
| C-ch | help for word at point |
| C-ck | run file |
|------+----------------------------------------------------------|
*** In the debugger (it pops up upon eval/compilation errors):
- g : go to error
- <digit> : invoke nth restart
- w/e/l : invoke :warnings, :errors, :linkage
- q : bury buffer
|---------+-------------------------------------|
| g | go to error |
| <digit> | invoke nth restart |
| w/e/l | invoke :warnings, :errors, :linkage |
| q | bury buffer |
|---------+-------------------------------------|
*** In the help browser:
- h : help for word at point
- v : help for a vocabulary
- a : find words containing given substring (M-x fuel-apropos)
- e : edit current article
- ba : bookmark current page
- bb : display bookmarks
- bd : delete bookmark at point
- n/p : next/previous page
- l : previous page
- SPC/S-SPC : scroll up/down
- TAB/S-TAB : next/previous link
- k : kill current page and go to previous or next
- r : refresh page
- c : clean browsing history
- M-. : edit word at point in Emacs
- C-cz : switch to listener
- q : bury buffer
|-----------+----------------------------------------------------------|
| h | help for word at point |
| v | help for a vocabulary |
| a | find words containing given substring (M-x fuel-apropos) |
| e | edit current article |
| ba | bookmark current page |
| bb | display bookmarks |
| bd | delete bookmark at point |
| n/p | next/previous page |
| l | previous page |
| SPC/S-SPC | scroll up/down |
| TAB/S-TAB | next/previous link |
| k | kill current page and go to previous or next |
| r | refresh page |
| c | clean browsing history |
| M-. | edit word at point in Emacs |
| C-cz | switch to listener |
| q | bury buffer |
|-----------+----------------------------------------------------------|
*** In crossref buffers
- TAB/BACKTAB : navigate links
- RET/mouse click : follow link
- h : show help for word at point
- q : bury buffer
|-----------------+-----------------------------|
| TAB/BACKTAB | navigate links |
| RET/mouse click | follow link |
| h | show help for word at point |
| q | bury buffer |
|-----------------+-----------------------------|

1
misc/fuel/fuel-eval.el
View File

@ -32,6 +32,7 @@
(case (car sexp)
(:array (factor--seq 'V{ '} (cdr sexp)))
(:seq (factor--seq '{ '} (cdr sexp)))
(:tuple (factor--seq 'T{ '} (cdr sexp)))
(:quote (format "\\ %s" (factor `(:factor ,(cadr sexp)))))
(:quotation (factor--seq '\[ '\] (cdr sexp)))
(:using (factor `(USING: ,@(cdr sexp) :end)))

12
misc/fuel/fuel-font-lock.el
View File

@ -79,11 +79,15 @@
(save-excursion
(goto-char (nth 8 state))
(beginning-of-line)
(cond ((looking-at "USING: ") 'factor-font-lock-vocabulary-name)
(cond ((looking-at "USING: ")
'factor-font-lock-vocabulary-name)
((looking-at "\\(TUPLE\\|SYMBOLS\\|VARS\\): ")
'factor-font-lock-symbol)
((looking-at "C-ENUM:\\( \\|\n\\)")
'factor-font-lock-constant)
(t 'default))))
((char-equal c ?U) 'factor-font-lock-parsing-word)
((or (char-equal c ?U) (char-equal c ?C))
'factor-font-lock-parsing-word)
((char-equal c ?\() 'factor-font-lock-stack-effect)
((char-equal c ?\") 'factor-font-lock-string)
(t 'factor-font-lock-comment)))))
@ -91,6 +95,8 @@
(defconst fuel-font-lock--font-lock-keywords
`((,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect)
(,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--vocab-ref-regexp 2 'factor-font-lock-vocabulary-name)
(,fuel-syntax--constructor-decl-regex (1 'factor-font-lock-word)
(2 'factor-font-lock-type-name)
@ -119,7 +125,7 @@
(,fuel-syntax--getter-regex . 'factor-font-lock-getter-word)
(,fuel-syntax--symbol-definition-regex 2 'factor-font-lock-symbol)
(,fuel-syntax--bad-string-regex . 'factor-font-lock-invalid-syntax)
("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word)
("\\_<\\(P\\|SBUF\\|DLL\\)\"" 1 'factor-font-lock-parsing-word)
(,fuel-syntax--parsing-words-regex . 'factor-font-lock-parsing-word)))
(defun fuel-font-lock--font-lock-setup (&optional keywords no-syntax)

12
misc/fuel/fuel-markup.el
View File

@ -156,7 +156,7 @@
(defvar fuel-markup--maybe-nl nil))
(defun fuel-markup--print (e)
(cond ((null e))
(cond ((null e) (insert "f"))
((stringp e) (fuel-markup--insert-string e))
((and (listp e) (symbolp (car e))
(assoc (car e) fuel-markup--printers))
@ -253,8 +253,12 @@
(insert (cadr e))))
(defun fuel-markup--snippet (e)
(let ((snip (format "%s" (cadr e))))
(insert (fuel-font-lock--factor-str snip))))
(insert (mapconcat '(lambda (s)
(if (stringp s)
(fuel-font-lock--factor-str s)
(fuel-markup--print-str s)))
(cdr e)
" ")))
(defun fuel-markup--code (e)
(fuel-markup--insert-nl-if-nb)
@ -285,7 +289,7 @@
(fuel-markup--snippet (cons '$snippet (cdr e))))
(defun fuel-markup--link (e)
(let* ((link (nth 1 e))
(let* ((link (or (nth 1 e) 'f))
(type (or (nth 3 e) (if (symbolp link) 'word 'article)))
(label (or (nth 2 e)
(and (eq type 'article)

29
misc/fuel/fuel-syntax.el
View File

@ -43,16 +43,17 @@
;;; Regexps galore:
(defconst fuel-syntax--parsing-words
'(":" "::" ";" "<<" "<PRIVATE" ">>"
"ABOUT:" "ALIAS:" "ARTICLE:"
'(":" "::" ";" "&:" "<<" "<PRIVATE" ">>"
"ABOUT:" "ALIAS:" "ALIEN:" "ARTICLE:"
"B" "BIN:"
"C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CONSTANT:" "call-next-method"
"C:" "C-ENUM:" "C-STRUCT:" "C-UNION:" "CHAR:" "CONSTANT:" "call-next-method"
"DEFER:"
"ERROR:" "EXCLUDE:"
"f" "FORGET:" "FROM:"
"f" "FORGET:" "FROM:" "FUNCTION:"
"GENERIC#" "GENERIC:"
"HELP:" "HEX:" "HOOK:"
"IN:" "initial:" "INSTANCE:" "INTERSECTION:"
"LIBRARY:"
"M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "MEMO:" "MEMO:" "METHOD:" "MIXIN:"
"OCT:"
"POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
@ -117,10 +118,11 @@
'("IN:" "USE:" "FROM:" "EXCLUDE:" "QUALIFIED:" "QUALIFIED-WITH:")))
(defconst fuel-syntax--int-constant-def-regex
(fuel-syntax--second-word-regex '("CHAR:" "BIN:" "HEX:" "OCT:")))
(fuel-syntax--second-word-regex '("ALIEN:" "CHAR:" "BIN:" "HEX:" "OCT:")))
(defconst fuel-syntax--type-definition-regex
(fuel-syntax--second-word-regex '("MIXIN:" "TUPLE:" "SINGLETON:" "UNION:")))
(fuel-syntax--second-word-regex
'("C-STRUCT:" "C-UNION:" "MIXIN:" "TUPLE:" "SINGLETON:" "UNION:")))
(defconst fuel-syntax--tuple-decl-regex
"^TUPLE: +\\([^ \n]+\\) +< +\\([^ \n]+\\)\\_>")
@ -131,7 +133,7 @@
(defconst fuel-syntax--setter-regex "\\_<>>.+?\\_>")
(defconst fuel-syntax--symbol-definition-regex
(fuel-syntax--second-word-regex '("SYMBOL:" "VAR:")))
(fuel-syntax--second-word-regex '("&:" "SYMBOL:" "VAR:")))
(defconst fuel-syntax--stack-effect-regex
"\\( ( .* )\\)\\|\\( (( .* ))\\)")
@ -144,8 +146,12 @@
(defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$")
(defconst fuel-syntax--alien-function-regex
"\\_<FUNCTION: \\(\\w+\\) \\(\\w+\\)")
(defconst fuel-syntax--indent-def-starts '("" ":"
"FROM"
"C-ENUM" "C-STRUCT" "C-UNION"
"FROM" "FUNCTION:"
"INTERSECTION:"
"M" "MACRO" "MACRO:"
"MEMO" "MEMO:" "METHOD"
@ -158,7 +164,7 @@
"VARS"))
(defconst fuel-syntax--indent-def-start-regex
(format "^\\(%s:\\) " (regexp-opt fuel-syntax--indent-def-starts)))
(format "^\\(%s:\\)\\( \\|\n\\)" (regexp-opt fuel-syntax--indent-def-starts)))
(defconst fuel-syntax--no-indent-def-start-regex
(format "^\\(%s:\\) " (regexp-opt fuel-syntax--no-indent-def-starts)))
@ -181,6 +187,7 @@
"GENERIC:" "GENERIC#"
"HELP:" "HEX:" "HOOK:"
"IN:" "INSTANCE:"
"LIBRARY:"
"MAIN:" "MATH:" "MIXIN:"
"OCT:"
"POSTPONE:" "PRIVATE>" "<PRIVATE"
@ -247,12 +254,16 @@
(" \\((\\)( \\([^\n]*\\) )\\()\\)\\( \\|\n\\)" (1 "<b") (2 "w") (3 ">b"))
(" \\((\\) \\([^\n]*\\) \\()\\)\\( \\|\n\\)" (1 "<b") (2 "w") (3 ">b"))
;; Strings
("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)\\(\"\\)[^\n\r\f]*\\(\"\\)\\( \\|\n\\)"
(3 "\"") (4 "\""))
("\\( \\|^\\)\\(\"\\)[^\n\r\f]*\\(\"\\)\\( \\|\n\\)" (2 "\"") (3 "\""))
("\\_<<\\(\"\\)\\_>" (1 "<b"))
("\\_<\\(\"\\)>\\_>" (1 ">b"))
;; Multiline constructs
("\\_<\\(U\\)SING: \\(;\\)" (1 "<b") (2 ">b"))
("\\_<USING:\\( \\)" (1 "<b"))
("\\_<\\(C\\)-ENUM: \\(;\\)" (1 "<b") (2 ">b"))
("\\_<C-ENUM:\\( \\|\n\\)" (1 "<b"))
("\\_<TUPLE: +\\w+? +< +\\w+? *\\( \\|\n\\)\\([^;]\\|$\\)" (1 "<b"))
("\\_<\\(TUPLE\\|SYMBOLS\\|VARS\\): +\\w+? *\\( \\|\n\\)\\([^;<\n]\\|\\_>\\)"
(2 "<b"))

17
vm/callstack.c
View File

@ -90,9 +90,9 @@ void primitive_set_callstack(void)
critical_error("Bug in set_callstack()",0);
}
F_COMPILED *frame_code(F_STACK_FRAME *frame)
F_CODE_BLOCK *frame_code(F_STACK_FRAME *frame)
{
return (F_COMPILED *)frame->xt - 1;
return (F_CODE_BLOCK *)frame->xt - 1;
}
CELL frame_type(F_STACK_FRAME *frame)
@ -102,11 +102,14 @@ CELL frame_type(F_STACK_FRAME *frame)
CELL frame_executing(F_STACK_FRAME *frame)
{
F_COMPILED *compiled = frame_code(frame);
CELL code_start = (CELL)(compiled + 1);
CELL literal_start = code_start + compiled->code_length;
return get(literal_start);
F_CODE_BLOCK *compiled = frame_code(frame);
if(compiled->literals == F)
return F;
else
{
F_ARRAY *array = untag_object(compiled->literals);
return array_nth(array,0);
}
}
F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame)

2
vm/callstack.h
View File

@ -8,7 +8,7 @@ F_STACK_FRAME *fix_callstack_top(F_STACK_FRAME *top, F_STACK_FRAME *bottom);
void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator);
void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator);
F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame);
F_COMPILED *frame_code(F_STACK_FRAME *frame);
F_CODE_BLOCK *frame_code(F_STACK_FRAME *frame);
CELL frame_executing(F_STACK_FRAME *frame);
CELL frame_scan(F_STACK_FRAME *frame);
CELL frame_type(F_STACK_FRAME *frame);

433
vm/code_block.c Normal file
View File

@ -0,0 +1,433 @@
#include "master.h"
void flush_icache_for(F_CODE_BLOCK *compiled)
{
CELL start = (CELL)(compiled + 1);
flush_icache(start,compiled->code_length);
}
void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter)
{
if(compiled->relocation != F)
{
F_BYTE_ARRAY *relocation = untag_object(compiled->relocation);
F_REL *rel = (F_REL *)(relocation + 1);
F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation));
while(rel < rel_end)
{
iter(rel,compiled);
rel++;
}
}
}
/* Store a 32-bit value into a PowerPC LIS/ORI sequence */
INLINE void store_address_2_2(CELL cell, CELL value)
{
put(cell - CELLS,((get(cell - CELLS) & ~0xffff) | ((value >> 16) & 0xffff)));
put(cell,((get(cell) & ~0xffff) | (value & 0xffff)));
}
/* Store a value into a bitfield of a PowerPC instruction */
INLINE void store_address_masked(CELL cell, F_FIXNUM value, CELL mask, F_FIXNUM shift)
{
/* This is unaccurate but good enough */
F_FIXNUM test = (F_FIXNUM)mask >> 1;
if(value <= -test || value >= test)
critical_error("Value does not fit inside relocation",0);
u32 original = *(u32*)cell;
original &= ~mask;
*(u32*)cell = (original | ((value >> shift) & mask));
}
/* Perform a fixup on a code block */
void store_address_in_code_block(CELL class, CELL offset, F_FIXNUM absolute_value)
{
F_FIXNUM relative_value = absolute_value - offset;
switch(class)
{
case RC_ABSOLUTE_CELL:
put(offset,absolute_value);
break;
case RC_ABSOLUTE:
*(u32*)offset = absolute_value;
break;
case RC_RELATIVE:
*(u32*)offset = relative_value - sizeof(u32);
break;
case RC_ABSOLUTE_PPC_2_2:
store_address_2_2(offset,absolute_value);
break;
case RC_RELATIVE_PPC_2:
store_address_masked(offset,relative_value,REL_RELATIVE_PPC_2_MASK,0);
break;
case RC_RELATIVE_PPC_3:
store_address_masked(offset,relative_value,REL_RELATIVE_PPC_3_MASK,0);
break;
case RC_RELATIVE_ARM_3:
store_address_masked(offset,relative_value - CELLS * 2,
REL_RELATIVE_ARM_3_MASK,2);
break;
case RC_INDIRECT_ARM:
store_address_masked(offset,relative_value - CELLS,
REL_INDIRECT_ARM_MASK,0);
break;
case RC_INDIRECT_ARM_PC:
store_address_masked(offset,relative_value - CELLS * 2,
REL_INDIRECT_ARM_MASK,0);
break;
default:
critical_error("Bad rel class",class);
break;
}
}
void update_literal_references_step(F_REL *rel, F_CODE_BLOCK *compiled)
{
if(REL_TYPE(rel) == RT_IMMEDIATE)
{
CELL offset = rel->offset + (CELL)(compiled + 1);
F_ARRAY *literals = untag_object(compiled->literals);
F_FIXNUM absolute_value = array_nth(literals,REL_ARGUMENT(rel));
store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
}
}
/* Update pointers to literals from compiled code. */
void update_literal_references(F_CODE_BLOCK *compiled)
{
iterate_relocations(compiled,update_literal_references_step);
flush_icache_for(compiled);
}
/* Copy all literals referenced from a code block to newspace. Only for
aging and nursery collections */
void copy_literal_references(F_CODE_BLOCK *compiled)
{
if(collecting_gen >= compiled->last_scan)
{
if(collecting_accumulation_gen_p())
compiled->last_scan = collecting_gen;
else
compiled->last_scan = collecting_gen + 1;
/* initialize chase pointer */
CELL scan = newspace->here;
copy_handle(&compiled->literals);
copy_handle(&compiled->relocation);
/* do some tracing so that all reachable literals are now
at their final address */
copy_reachable_objects(scan,&newspace->here);
update_literal_references(compiled);
}
}
CELL object_xt(CELL obj)
{
if(type_of(obj) == WORD_TYPE)
return (CELL)untag_word(obj)->xt;
else
return (CELL)untag_quotation(obj)->xt;
}
void update_word_references_step(F_REL *rel, F_CODE_BLOCK *compiled)
{
if(REL_TYPE(rel) == RT_XT)
{
CELL offset = rel->offset + (CELL)(compiled + 1);
F_ARRAY *literals = untag_object(compiled->literals);
CELL xt = object_xt(array_nth(literals,REL_ARGUMENT(rel)));
store_address_in_code_block(REL_CLASS(rel),offset,xt);
}
}
/* Relocate new code blocks completely; updating references to literals,
dlsyms, and words. For all other words in the code heap, we only need
to update references to other words, without worrying about literals
or dlsyms. */
void update_word_references(F_CODE_BLOCK *compiled)
{
if(compiled->needs_fixup)
relocate_code_block(compiled);
else
{
iterate_relocations(compiled,update_word_references_step);
flush_icache_for(compiled);
}
}
/* Update references to words. This is done after a new code block
is added to the heap. */
/* Mark all literals referenced from a word XT. Only for tenured
collections */
void mark_code_block(F_CODE_BLOCK *compiled)
{
mark_block(compiled_to_block(compiled));
copy_handle(&compiled->literals);
copy_handle(&compiled->relocation);
flush_icache_for(compiled);
}
void mark_stack_frame_step(F_STACK_FRAME *frame)
{
mark_code_block(frame_code(frame));
}
/* Mark code blocks executing in currently active stack frames. */
void mark_active_blocks(F_CONTEXT *stacks)
{
if(collecting_gen == TENURED)
{
CELL top = (CELL)stacks->callstack_top;
CELL bottom = (CELL)stacks->callstack_bottom;
iterate_callstack(top,bottom,mark_stack_frame_step);
}
}
void mark_object_code_block(CELL scan)
{
F_WORD *word;
F_QUOTATION *quot;
F_CALLSTACK *stack;
switch(object_type(scan))
{
case WORD_TYPE:
word = (F_WORD *)scan;
mark_code_block(word->code);
if(word->profiling)
mark_code_block(word->profiling);
break;
case QUOTATION_TYPE:
quot = (F_QUOTATION *)scan;
if(quot->compiledp != F)
mark_code_block(quot->code);
break;
case CALLSTACK_TYPE:
stack = (F_CALLSTACK *)scan;
iterate_callstack_object(stack,mark_stack_frame_step);
break;
}
}
/* References to undefined symbols are patched up to call this function on
image load */
void undefined_symbol(void)
{
general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
}
/* Look up an external library symbol referenced by a compiled code block */
void *get_rel_symbol(F_REL *rel, F_ARRAY *literals)
{
CELL arg = REL_ARGUMENT(rel);
CELL symbol = array_nth(literals,arg);
CELL library = array_nth(literals,arg + 1);
F_DLL *dll = (library == F ? NULL : untag_dll(library));
if(dll != NULL && !dll->dll)
return undefined_symbol;
if(type_of(symbol) == BYTE_ARRAY_TYPE)
{
F_SYMBOL *name = alien_offset(symbol);
void *sym = ffi_dlsym(dll,name);
if(sym)
return sym;
}
else if(type_of(symbol) == ARRAY_TYPE)
{
CELL i;
F_ARRAY *names = untag_object(symbol);
for(i = 0; i < array_capacity(names); i++)
{
F_SYMBOL *name = alien_offset(array_nth(names,i));
void *sym = ffi_dlsym(dll,name);
if(sym)
return sym;
}
}
return undefined_symbol;
}
/* Compute an address to store at a relocation */
void relocate_code_block_step(F_REL *rel, F_CODE_BLOCK *compiled)
{
CELL offset = rel->offset + (CELL)(compiled + 1);
F_ARRAY *literals = untag_object(compiled->literals);
F_FIXNUM absolute_value;
switch(REL_TYPE(rel))
{
case RT_PRIMITIVE:
absolute_value = (CELL)primitives[REL_ARGUMENT(rel)];
break;
case RT_DLSYM:
absolute_value = (CELL)get_rel_symbol(rel,literals);
break;
case RT_IMMEDIATE:
absolute_value = array_nth(literals,REL_ARGUMENT(rel));
break;
case RT_XT:
absolute_value = object_xt(array_nth(literals,REL_ARGUMENT(rel)));
break;
case RT_HERE:
absolute_value = rel->offset + (CELL)(compiled + 1) + (short)REL_ARGUMENT(rel);
break;
case RT_LABEL:
absolute_value = (CELL)(compiled + 1) + REL_ARGUMENT(rel);
break;
case RT_STACK_CHAIN:
absolute_value = (CELL)&stack_chain;
break;
default:
critical_error("Bad rel type",rel->type);
return; /* Can't happen */
}
store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
}
/* Perform all fixups on a code block */
void relocate_code_block(F_CODE_BLOCK *compiled)
{
compiled->last_scan = NURSERY;
compiled->needs_fixup = false;
iterate_relocations(compiled,relocate_code_block_step);
flush_icache_for(compiled);
}
/* Fixup labels. This is done at compile time, not image load time */
void fixup_labels(F_ARRAY *labels, CELL code_format, F_CODE_BLOCK *compiled)
{
CELL i;
CELL size = array_capacity(labels);
for(i = 0; i < size; i += 3)
{
CELL class = to_fixnum(array_nth(labels,i));
CELL offset = to_fixnum(array_nth(labels,i + 1));
CELL target = to_fixnum(array_nth(labels,i + 2));
store_address_in_code_block(class,
offset + (CELL)(compiled + 1),
target + (CELL)(compiled + 1));
}
}
/* Write a sequence of integers to memory, with 'format' bytes per integer */
void deposit_integers(CELL here, F_ARRAY *array, CELL format)
{
CELL count = array_capacity(array);
CELL i;
for(i = 0; i < count; i++)
{
F_FIXNUM value = to_fixnum(array_nth(array,i));
if(format == 1)
bput(here + i,value);
else if(format == sizeof(unsigned int))
*(unsigned int *)(here + format * i) = value;
else if(format == sizeof(CELL))
*(CELL *)(here + format * i) = value;
else
critical_error("Bad format in deposit_integers()",format);
}
}
bool stack_traces_p(void)
{
return to_boolean(userenv[STACK_TRACES_ENV]);
}
CELL compiled_code_format(void)
{
return untag_fixnum_fast(userenv[JIT_CODE_FORMAT]);
}
/* Might GC */
void *allot_code_block(CELL size)
{
void *start = heap_allot(&code_heap,size);
/* If allocation failed, do a code GC */
if(start == NULL)
{
gc();
start = heap_allot(&code_heap,size);
/* Insufficient room even after code GC, give up */
if(start == NULL)
{
CELL used, total_free, max_free;
heap_usage(&code_heap,&used,&total_free,&max_free);
print_string("Code heap stats:\n");
print_string("Used: "); print_cell(used); nl();
print_string("Total free space: "); print_cell(total_free); nl();
print_string("Largest free block: "); print_cell(max_free); nl();
fatal_error("Out of memory in add-compiled-block",0);
}
}
return start;
}
/* Might GC */
F_CODE_BLOCK *add_compiled_block(
CELL type,
F_ARRAY *code,
F_ARRAY *labels,
CELL relocation,
CELL literals)
{
CELL code_format = compiled_code_format();
CELL code_length = align8(array_capacity(code) * code_format);
REGISTER_ROOT(literals);
REGISTER_ROOT(relocation);
REGISTER_UNTAGGED(code);
REGISTER_UNTAGGED(labels);
F_CODE_BLOCK *compiled = allot_code_block(sizeof(F_CODE_BLOCK) + code_length);
UNREGISTER_UNTAGGED(labels);
UNREGISTER_UNTAGGED(code);
UNREGISTER_ROOT(relocation);
UNREGISTER_ROOT(literals);
/* compiled header */
compiled->type = type;
compiled->last_scan = NURSERY;
compiled->needs_fixup = true;
compiled->code_length = code_length;
compiled->literals = literals;
compiled->relocation = relocation;
/* code */
deposit_integers((CELL)(compiled + 1),code,code_format);
/* fixup labels */
if(labels) fixup_labels(labels,code_format,compiled);
/* next time we do a minor GC, we have to scan the code heap for
literals */
last_code_heap_scan = NURSERY;
return compiled;
}

91
vm/code_block.h Normal file
View File

@ -0,0 +1,91 @@
typedef enum {
/* arg is a primitive number */
RT_PRIMITIVE,
/* arg is a literal table index, holding an array pair (symbol/dll) */
RT_DLSYM,
/* a pointer to a compiled word reference */
RT_DISPATCH,
/* a compiled word reference */
RT_XT,
/* current offset */
RT_HERE,
/* a local label */
RT_LABEL,
/* immediate literal */
RT_IMMEDIATE,
/* address of stack_chain var */
RT_STACK_CHAIN
} F_RELTYPE;
typedef enum {
/* absolute address in a 64-bit location */
RC_ABSOLUTE_CELL,
/* absolute address in a 32-bit location */
RC_ABSOLUTE,
/* relative address in a 32-bit location */
RC_RELATIVE,
/* relative address in a PowerPC LIS/ORI sequence */
RC_ABSOLUTE_PPC_2_2,
/* relative address in a PowerPC LWZ/STW/BC instruction */
RC_RELATIVE_PPC_2,
/* relative address in a PowerPC B/BL instruction */
RC_RELATIVE_PPC_3,
/* relative address in an ARM B/BL instruction */
RC_RELATIVE_ARM_3,
/* pointer to address in an ARM LDR/STR instruction */
RC_INDIRECT_ARM,
/* pointer to address in an ARM LDR/STR instruction offset by 8 bytes */
RC_INDIRECT_ARM_PC
} F_RELCLASS;
#define REL_RELATIVE_PPC_2_MASK 0xfffc
#define REL_RELATIVE_PPC_3_MASK 0x3fffffc
#define REL_INDIRECT_ARM_MASK 0xfff
#define REL_RELATIVE_ARM_3_MASK 0xffffff
/* the rel type is built like a cell to avoid endian-specific code in
the compiler */
#define REL_TYPE(r) ((r)->type & 0x000000ff)
#define REL_CLASS(r) (((r)->type & 0x0000ff00) >> 8)
#define REL_ARGUMENT(r) (((r)->type & 0xffff0000) >> 16)
/* code relocation consists of a table of entries for each fixup */
typedef struct {
unsigned int type;
unsigned int offset;
} F_REL;
void flush_icache_for(F_CODE_BLOCK *compiled);
typedef void (*RELOCATION_ITERATOR)(F_REL *rel, F_CODE_BLOCK *compiled);
void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter);
void store_address_in_code_block(CELL class, CELL offset, F_FIXNUM absolute_value);
void relocate_code_block(F_CODE_BLOCK *compiled);
void update_literal_references(F_CODE_BLOCK *compiled);
void copy_literal_references(F_CODE_BLOCK *compiled);
void update_word_references(F_CODE_BLOCK *compiled);
void mark_code_block(F_CODE_BLOCK *compiled);
void mark_active_blocks(F_CONTEXT *stacks);
void mark_object_code_block(CELL scan);
void relocate_code_block(F_CODE_BLOCK *relocating);
CELL compiled_code_format(void);
bool stack_traces_p(void);
F_CODE_BLOCK *add_compiled_block(
CELL type,
F_ARRAY *code,
F_ARRAY *labels,
CELL relocation,
CELL literals);

266
vm/code_gc.c
View File

@ -11,18 +11,6 @@ void new_heap(F_HEAP *heap, CELL size)
heap->free_list = NULL;
}
/* Allocate a code heap during startup */
void init_code_heap(CELL size)
{
new_heap(&code_heap,size);
}
bool in_code_heap_p(CELL ptr)
{
return (ptr >= code_heap.segment->start
&& ptr <= code_heap.segment->end);
}
/* If there is no previous block, next_free becomes the head of the free list,
else its linked in */
INLINE void update_free_list(F_HEAP *heap, F_BLOCK *prev, F_BLOCK *next_free)
@ -92,7 +80,7 @@ void build_free_list(F_HEAP *heap, CELL size)
}
/* Allocate a block of memory from the mark and sweep GC heap */
CELL heap_allot(F_HEAP *heap, CELL size)
void *heap_allot(F_HEAP *heap, CELL size)
{
F_BLOCK *prev = NULL;
F_BLOCK *scan = heap->free_list;
@ -139,13 +127,29 @@ CELL heap_allot(F_HEAP *heap, CELL size)
/* this is our new block */
scan->status = B_ALLOCATED;
return (CELL)(scan + 1);
return scan + 1;
}
return 0;
return NULL;
}
/* If in the middle of code GC, we have to grow the heap, GC restarts from
void mark_block(F_BLOCK *block)
{
/* If already marked, do nothing */
switch(block->status)
{
case B_MARKED:
return;
case B_ALLOCATED:
block->status = B_MARKED;
break;
default:
critical_error("Marking the wrong block",(CELL)block);
break;
}
}
/* If in the middle of code GC, we have to grow the heap, data GC restarts from
scratch, so we have to unmark any marked blocks. */
void unmark_marked(F_HEAP *heap)
{
@ -243,136 +247,6 @@ CELL heap_size(F_HEAP *heap)
return heap->segment->size;
}
/* Apply a function to every code block */
void iterate_code_heap(CODE_HEAP_ITERATOR iter)
{
F_BLOCK *scan = first_block(&code_heap);
while(scan)
{
if(scan->status != B_FREE)
iterate_code_heap_step(block_to_compiled(scan),iter);
scan = next_block(&code_heap,scan);
}
}
/* Copy all literals referenced from a code block to newspace */
void collect_literals_step(F_COMPILED *compiled, CELL code_start, CELL literals_start)
{
if(collecting_gen >= compiled->last_scan)
{
CELL scan;
CELL literal_end = literals_start + compiled->literals_length;
if(collecting_accumulation_gen_p())
compiled->last_scan = collecting_gen;
else
compiled->last_scan = collecting_gen + 1;
for(scan = literals_start; scan < literal_end; scan += CELLS)
copy_handle((CELL*)scan);
if(compiled->relocation != F)
{
copy_handle(&compiled->relocation);
F_BYTE_ARRAY *relocation = untag_object(compiled->relocation);
F_REL *rel = (F_REL *)(relocation + 1);
F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation));
while(rel < rel_end)
{
if(REL_TYPE(rel) == RT_IMMEDIATE)
{
CELL offset = rel->offset + code_start;
F_FIXNUM absolute_value = get(CREF(literals_start,REL_ARGUMENT(rel)));
apply_relocation(REL_CLASS(rel),offset,absolute_value);
}
rel++;
}
}
flush_icache(code_start,literals_start - code_start);
}
}
/* Copy literals referenced from all code blocks to newspace */
void collect_literals(void)
{
iterate_code_heap(collect_literals_step);
}
/* Mark all XTs and literals referenced from a word XT */
void recursive_mark(F_BLOCK *block)
{
/* If already marked, do nothing */
switch(block->status)
{
case B_MARKED:
return;
case B_ALLOCATED:
block->status = B_MARKED;
break;
default:
critical_error("Marking the wrong block",(CELL)block);
break;
}
F_COMPILED *compiled = block_to_compiled(block);
iterate_code_heap_step(compiled,collect_literals_step);
}
/* Push the free space and total size of the code heap */
void primitive_code_room(void)
{
CELL used, total_free, max_free;
heap_usage(&code_heap,&used,&total_free,&max_free);
dpush(tag_fixnum((code_heap.segment->size) / 1024));
dpush(tag_fixnum(used / 1024));
dpush(tag_fixnum(total_free / 1024));
dpush(tag_fixnum(max_free / 1024));
}
/* Dump all code blocks for debugging */
void dump_heap(F_HEAP *heap)
{
CELL size = 0;
F_BLOCK *scan = first_block(heap);
while(scan)
{
char *status;
switch(scan->status)
{
case B_FREE:
status = "free";
break;
case B_ALLOCATED:
size += object_size(block_to_compiled(scan)->relocation);
status = "allocated";
break;
case B_MARKED:
size += object_size(block_to_compiled(scan)->relocation);
status = "marked";
break;
default:
status = "invalid";
break;
}
print_cell_hex((CELL)scan); print_string(" ");
print_cell_hex(scan->size); print_string(" ");
print_string(status); print_string("\n");
scan = next_block(heap,scan);
}
print_cell(size); print_string(" bytes of relocation data\n");
}
/* Compute where each block is going to go, after compaction */
CELL compute_heap_forwarding(F_HEAP *heap)
{
@ -395,80 +269,6 @@ CELL compute_heap_forwarding(F_HEAP *heap)
return address - heap->segment->start;
}
F_COMPILED *forward_xt(F_COMPILED *compiled)
{
return block_to_compiled(compiled_to_block(compiled)->forwarding);
}
void forward_frame_xt(F_STACK_FRAME *frame)
{
CELL offset = (CELL)FRAME_RETURN_ADDRESS(frame) - (CELL)frame_code(frame);
F_COMPILED *forwarded = forward_xt(frame_code(frame));
frame->xt = (XT)(forwarded + 1);
FRAME_RETURN_ADDRESS(frame) = (XT)((CELL)forwarded + offset);
}
void forward_object_xts(void)
{
begin_scan();
CELL obj;
while((obj = next_object()) != F)
{
if(type_of(obj) == WORD_TYPE)
{
F_WORD *word = untag_object(obj);
word->code = forward_xt(word->code);
if(word->profiling)
word->profiling = forward_xt(word->profiling);
}
else if(type_of(obj) == QUOTATION_TYPE)
{
F_QUOTATION *quot = untag_object(obj);
if(quot->compiledp != F)
quot->code = forward_xt(quot->code);
}
else if(type_of(obj) == CALLSTACK_TYPE)
{
F_CALLSTACK *stack = untag_object(obj);
iterate_callstack_object(stack,forward_frame_xt);
}
}
/* End the heap scan */
gc_off = false;
}
/* Set the XT fields now that the heap has been compacted */
void fixup_object_xts(void)
{
begin_scan();
CELL obj;
while((obj = next_object()) != F)
{
if(type_of(obj) == WORD_TYPE)
{
F_WORD *word = untag_object(obj);
update_word_xt(word);
}
else if(type_of(obj) == QUOTATION_TYPE)
{
F_QUOTATION *quot = untag_object(obj);
if(quot->compiledp != F)
set_quot_xt(quot,quot->code);
}
}
/* End the heap scan */
gc_off = false;
}
void compact_heap(F_HEAP *heap)
{
F_BLOCK *scan = first_block(heap);
@ -482,29 +282,3 @@ void compact_heap(F_HEAP *heap)
scan = next;
}
}
/* Move all free space to the end of the code heap. This is not very efficient,
since it makes several passes over the code and data heaps, but we only ever
do this before saving a deployed image and exiting, so performaance is not
critical here */
void compact_code_heap(void)
{
/* Free all unreachable code blocks */
gc();
/* Figure out where the code heap blocks are going to end up */
CELL size = compute_heap_forwarding(&code_heap);
/* Update word and quotation code pointers */
forward_object_xts();
/* Actually perform the compaction */
compact_heap(&code_heap);
/* Update word and quotation XTs */
fixup_object_xts();
/* Now update the free list; there will be a single free block at
the end */
build_free_list(&code_heap,size);
}

38
vm/code_gc.h
View File

@ -26,11 +26,14 @@ typedef struct {
void new_heap(F_HEAP *heap, CELL size);
void build_free_list(F_HEAP *heap, CELL size);
CELL heap_allot(F_HEAP *heap, CELL size);
void *heap_allot(F_HEAP *heap, CELL size);
void mark_block(F_BLOCK *block);
void unmark_marked(F_HEAP *heap);
void free_unmarked(F_HEAP *heap);
void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free);
CELL heap_size(F_HEAP *heap);
CELL compute_heap_forwarding(F_HEAP *heap);
void compact_heap(F_HEAP *heap);
INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block)
{
@ -41,29 +44,6 @@ INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block)
return (F_BLOCK *)next;
}
/* compiled code */
F_HEAP code_heap;
typedef void (*CODE_HEAP_ITERATOR)(F_COMPILED *compiled, CELL code_start, CELL literals_start);
INLINE void iterate_code_heap_step(F_COMPILED *compiled, CODE_HEAP_ITERATOR iter)
{
CELL code_start = (CELL)(compiled + 1);
CELL literals_start = code_start + compiled->code_length;
iter(compiled,code_start,literals_start);
}
INLINE F_BLOCK *compiled_to_block(F_COMPILED *compiled)
{
return (F_BLOCK *)compiled - 1;
}
INLINE F_COMPILED *block_to_compiled(F_BLOCK *block)
{
return (F_COMPILED *)(block + 1);
}
INLINE F_BLOCK *first_block(F_HEAP *heap)
{
return (F_BLOCK *)heap->segment->start;
@ -73,13 +53,3 @@ INLINE F_BLOCK *last_block(F_HEAP *heap)
{
return (F_BLOCK *)heap->segment->end;
}
void init_code_heap(CELL size);
bool in_code_heap_p(CELL ptr);
void iterate_code_heap(CODE_HEAP_ITERATOR iter);
void collect_literals(void);
void recursive_mark(F_BLOCK *block);
void dump_heap(F_HEAP *heap);
void compact_code_heap(void);
void primitive_code_room(void);

476
vm/code_heap.c
View File

@ -1,315 +1,18 @@
#include "master.h"
/* References to undefined symbols are patched up to call this function on
image load */
void undefined_symbol(void)
/* Allocate a code heap during startup */
void init_code_heap(CELL size)
{
general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
new_heap(&code_heap,size);
}
INLINE CELL get_literal(CELL literals_start, CELL num)
bool in_code_heap_p(CELL ptr)
{
return get(CREF(literals_start,num));
return (ptr >= code_heap.segment->start
&& ptr <= code_heap.segment->end);
}
/* Look up an external library symbol referenced by a compiled code block */
void *get_rel_symbol(F_REL *rel, CELL literals_start)
{
CELL arg = REL_ARGUMENT(rel);
CELL symbol = get_literal(literals_start,arg);
CELL library = get_literal(literals_start,arg + 1);
F_DLL *dll = (library == F ? NULL : untag_dll(library));
if(dll != NULL && !dll->dll)
return undefined_symbol;
if(type_of(symbol) == BYTE_ARRAY_TYPE)
{
F_SYMBOL *name = alien_offset(symbol);
void *sym = ffi_dlsym(dll,name);
if(sym)
return sym;
}
else if(type_of(symbol) == ARRAY_TYPE)
{
CELL i;
F_ARRAY *names = untag_object(symbol);
for(i = 0; i < array_capacity(names); i++)
{
F_SYMBOL *name = alien_offset(array_nth(names,i));
void *sym = ffi_dlsym(dll,name);
if(sym)
return sym;
}
}
return undefined_symbol;
}
/* Compute an address to store at a relocation */
INLINE CELL compute_code_rel(F_REL *rel,
CELL code_start, CELL literals_start)
{
CELL obj;
switch(REL_TYPE(rel))
{
case RT_PRIMITIVE:
return (CELL)primitives[REL_ARGUMENT(rel)];
case RT_DLSYM:
return (CELL)get_rel_symbol(rel,literals_start);
case RT_IMMEDIATE:
return get(CREF(literals_start,REL_ARGUMENT(rel)));
case RT_XT:
obj = get(CREF(literals_start,REL_ARGUMENT(rel)));
if(type_of(obj) == WORD_TYPE)
return (CELL)untag_word(obj)->xt;
else
return (CELL)untag_quotation(obj)->xt;
case RT_HERE:
return rel->offset + code_start + (short)REL_ARGUMENT(rel);
case RT_LABEL:
return code_start + REL_ARGUMENT(rel);
case RT_STACK_CHAIN:
return (CELL)&stack_chain;
default:
critical_error("Bad rel type",rel->type);
return -1; /* Can't happen */
}
}
/* Store a 32-bit value into a PowerPC LIS/ORI sequence */
INLINE void reloc_set_2_2(CELL cell, CELL value)
{
put(cell - CELLS,((get(cell - CELLS) & ~0xffff) | ((value >> 16) & 0xffff)));
put(cell,((get(cell) & ~0xffff) | (value & 0xffff)));
}
/* Store a value into a bitfield of a PowerPC instruction */
INLINE void reloc_set_masked(CELL cell, F_FIXNUM value, CELL mask, F_FIXNUM shift)
{
/* This is unaccurate but good enough */
F_FIXNUM test = (F_FIXNUM)mask >> 1;
if(value <= -test || value >= test)
critical_error("Value does not fit inside relocation",0);
u32 original = *(u32*)cell;
original &= ~mask;
*(u32*)cell = (original | ((value >> shift) & mask));
}
/* Perform a fixup on a code block */
void apply_relocation(CELL class, CELL offset, F_FIXNUM absolute_value)
{
F_FIXNUM relative_value = absolute_value - offset;
switch(class)
{
case RC_ABSOLUTE_CELL:
put(offset,absolute_value);
break;
case RC_ABSOLUTE:
*(u32*)offset = absolute_value;
break;
case RC_RELATIVE:
*(u32*)offset = relative_value - sizeof(u32);
break;
case RC_ABSOLUTE_PPC_2_2:
reloc_set_2_2(offset,absolute_value);
break;
case RC_RELATIVE_PPC_2:
reloc_set_masked(offset,relative_value,REL_RELATIVE_PPC_2_MASK,0);
break;
case RC_RELATIVE_PPC_3:
reloc_set_masked(offset,relative_value,REL_RELATIVE_PPC_3_MASK,0);
break;
case RC_RELATIVE_ARM_3:
reloc_set_masked(offset,relative_value - CELLS * 2,
REL_RELATIVE_ARM_3_MASK,2);
break;
case RC_INDIRECT_ARM:
reloc_set_masked(offset,relative_value - CELLS,
REL_INDIRECT_ARM_MASK,0);
break;
case RC_INDIRECT_ARM_PC:
reloc_set_masked(offset,relative_value - CELLS * 2,
REL_INDIRECT_ARM_MASK,0);
break;
default:
critical_error("Bad rel class",class);
break;
}
}
/* Perform all fixups on a code block */
void relocate_code_block(F_COMPILED *compiled, CELL code_start, CELL literals_start)
{
compiled->last_scan = NURSERY;
if(compiled->relocation != F)
{
F_BYTE_ARRAY *relocation = untag_object(compiled->relocation);
F_REL *rel = (F_REL *)(relocation + 1);
F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation));
while(rel < rel_end)
{
CELL offset = rel->offset + code_start;
F_FIXNUM absolute_value = compute_code_rel(
rel,code_start,literals_start);
apply_relocation(REL_CLASS(rel),offset,absolute_value);
rel++;
}
}
flush_icache(code_start,literals_start - code_start);
}
/* Fixup labels. This is done at compile time, not image load time */
void fixup_labels(F_ARRAY *labels, CELL code_format, CELL code_start)
{
CELL i;
CELL size = array_capacity(labels);
for(i = 0; i < size; i += 3)
{
CELL class = to_fixnum(array_nth(labels,i));
CELL offset = to_fixnum(array_nth(labels,i + 1));
CELL target = to_fixnum(array_nth(labels,i + 2));
apply_relocation(class,
offset + code_start,
target + code_start);
}
}
/* Write a sequence of integers to memory, with 'format' bytes per integer */
void deposit_integers(CELL here, F_ARRAY *array, CELL format)
{
CELL count = array_capacity(array);
CELL i;
for(i = 0; i < count; i++)
{
F_FIXNUM value = to_fixnum(array_nth(array,i));
if(format == 1)
bput(here + i,value);
else if(format == sizeof(unsigned int))
*(unsigned int *)(here + format * i) = value;
else if(format == CELLS)
put(CREF(here,i),value);
else
critical_error("Bad format in deposit_integers()",format);
}
}
/* Write a sequence of tagged pointers to memory */
void deposit_objects(CELL here, F_ARRAY *array)
{
memcpy((void*)here,array + 1,array_capacity(array) * CELLS);
}
bool stack_traces_p(void)
{
return to_boolean(userenv[STACK_TRACES_ENV]);
}
CELL compiled_code_format(void)
{
return untag_fixnum_fast(userenv[JIT_CODE_FORMAT]);
}
CELL allot_code_block(CELL size)
{
CELL start = heap_allot(&code_heap,size);
/* If allocation failed, do a code GC */
if(start == 0)
{
gc();
start = heap_allot(&code_heap,size);
/* Insufficient room even after code GC, give up */
if(start == 0)
{
CELL used, total_free, max_free;
heap_usage(&code_heap,&used,&total_free,&max_free);
print_string("Code heap stats:\n");
print_string("Used: "); print_cell(used); nl();
print_string("Total free space: "); print_cell(total_free); nl();
print_string("Largest free block: "); print_cell(max_free); nl();
fatal_error("Out of memory in add-compiled-block",0);
}
}
return start;
}
/* Might GC */
F_COMPILED *add_compiled_block(
CELL type,
F_ARRAY *code,
F_ARRAY *labels,
CELL relocation,
F_ARRAY *literals)
{
CELL code_format = compiled_code_format();
CELL code_length = align8(array_capacity(code) * code_format);
CELL literals_length = array_capacity(literals) * CELLS;
REGISTER_ROOT(relocation);
REGISTER_UNTAGGED(code);
REGISTER_UNTAGGED(labels);
REGISTER_UNTAGGED(literals);
CELL here = allot_code_block(sizeof(F_COMPILED) + code_length + literals_length);
UNREGISTER_UNTAGGED(literals);
UNREGISTER_UNTAGGED(labels);
UNREGISTER_UNTAGGED(code);
UNREGISTER_ROOT(relocation);
/* compiled header */
F_COMPILED *header = (void *)here;
header->type = type;
header->last_scan = NURSERY;
header->code_length = code_length;
header->literals_length = literals_length;
header->relocation = relocation;
here += sizeof(F_COMPILED);
CELL code_start = here;
/* code */
deposit_integers(here,code,code_format);
here += code_length;
/* literals */
deposit_objects(here,literals);
here += literals_length;
/* fixup labels */
if(labels)
fixup_labels(labels,code_format,code_start);
/* next time we do a minor GC, we have to scan the code heap for
literals */
last_code_heap_scan = NURSERY;
return header;
}
void set_word_code(F_WORD *word, F_COMPILED *compiled)
void set_word_code(F_WORD *word, F_CODE_BLOCK *compiled)
{
if(compiled->type != WORD_TYPE)
critical_error("bad param to set_word_xt",(CELL)compiled);
@ -329,12 +32,48 @@ void default_word_code(F_WORD *word, bool relocate)
word->optimizedp = F;
}
/* Apply a function to every code block */
void iterate_code_heap(CODE_HEAP_ITERATOR iter)
{
F_BLOCK *scan = first_block(&code_heap);
while(scan)
{
if(scan->status != B_FREE)
iter(block_to_compiled(scan));
scan = next_block(&code_heap,scan);
}
}
/* Copy literals referenced from all code blocks to newspace. Only for
aging and nursery collections */
void copy_code_heap_roots(void)
{
iterate_code_heap(copy_literal_references);
}
/* Update literals referenced from all code blocks. Only for tenured
collections, done at the end. */
void update_code_heap_roots(void)
{
iterate_code_heap(update_literal_references);
}
/* Update pointers to words referenced from all code blocks. Only after
defining a new word. */
void update_code_heap_words(void)
{
iterate_code_heap(update_word_references);
}
void primitive_modify_code_heap(void)
{
bool rescan_code_heap = to_boolean(dpop());
F_ARRAY *alist = untag_array(dpop());
CELL count = untag_fixnum_fast(alist->capacity);
if(count == 0)
return;
CELL i;
for(i = 0; i < count; i++)
{
@ -364,12 +103,12 @@ void primitive_modify_code_heap(void)
REGISTER_UNTAGGED(alist);
REGISTER_UNTAGGED(word);
F_COMPILED *compiled = add_compiled_block(
F_CODE_BLOCK *compiled = add_compiled_block(
WORD_TYPE,
code,
labels,
relocation,
literals);
tag_object(literals));
UNREGISTER_UNTAGGED(word);
UNREGISTER_UNTAGGED(alist);
@ -382,21 +121,116 @@ void primitive_modify_code_heap(void)
UNREGISTER_UNTAGGED(alist);
}
/* If there were any interned words in the set, we relocate all XT
references in the entire code heap. But if all the words are
uninterned, it is impossible that other words reference them, so we
only have to relocate the new words. This makes compile-call much
more efficient */
if(rescan_code_heap)
iterate_code_heap(relocate_code_block);
else
{
for(i = 0; i < count; i++)
{
F_ARRAY *pair = untag_array(array_nth(alist,i));
F_WORD *word = untag_word(array_nth(pair,0));
update_code_heap_words();
}
iterate_code_heap_step(word->code,relocate_code_block);
/* Push the free space and total size of the code heap */
void primitive_code_room(void)
{
CELL used, total_free, max_free;
heap_usage(&code_heap,&used,&total_free,&max_free);
dpush(tag_fixnum((code_heap.segment->size) / 1024));
dpush(tag_fixnum(used / 1024));
dpush(tag_fixnum(total_free / 1024));
dpush(tag_fixnum(max_free / 1024));
}
F_CODE_BLOCK *forward_xt(F_CODE_BLOCK *compiled)
{
return block_to_compiled(compiled_to_block(compiled)->forwarding);
}
void forward_frame_xt(F_STACK_FRAME *frame)
{
CELL offset = (CELL)FRAME_RETURN_ADDRESS(frame) - (CELL)frame_code(frame);
F_CODE_BLOCK *forwarded = forward_xt(frame_code(frame));
frame->xt = (XT)(forwarded + 1);
FRAME_RETURN_ADDRESS(frame) = (XT)((CELL)forwarded + offset);
}
void forward_object_xts(void)
{
begin_scan();
CELL obj;
while((obj = next_object()) != F)
{
if(type_of(obj) == WORD_TYPE)
{
F_WORD *word = untag_object(obj);
word->code = forward_xt(word->code);
if(word->profiling)
word->profiling = forward_xt(word->profiling);
}
else if(type_of(obj) == QUOTATION_TYPE)
{
F_QUOTATION *quot = untag_object(obj);
if(quot->compiledp != F)
quot->code = forward_xt(quot->code);
}
else if(type_of(obj) == CALLSTACK_TYPE)
{
F_CALLSTACK *stack = untag_object(obj);
iterate_callstack_object(stack,forward_frame_xt);
}
}
/* End the heap scan */
gc_off = false;
}
/* Set the XT fields now that the heap has been compacted */
void fixup_object_xts(void)
{
begin_scan();
CELL obj;
while((obj = next_object()) != F)
{
if(type_of(obj) == WORD_TYPE)
{
F_WORD *word = untag_object(obj);
update_word_xt(word);
}
else if(type_of(obj) == QUOTATION_TYPE)
{
F_QUOTATION *quot = untag_object(obj);
if(quot->compiledp != F)
set_quot_xt(quot,quot->code);
}
}
/* End the heap scan */
gc_off = false;
}
/* Move all free space to the end of the code heap. This is not very efficient,
since it makes several passes over the code and data heaps, but we only ever
do this before saving a deployed image and exiting, so performaance is not
critical here */
void compact_code_heap(void)
{
/* Free all unreachable code blocks */
gc();
/* Figure out where the code heap blocks are going to end up */
CELL size = compute_heap_forwarding(&code_heap);
/* Update word and quotation code pointers */
forward_object_xts();
/* Actually perform the compaction */
compact_heap(&code_heap);
/* Update word and quotation XTs */
fixup_object_xts();
/* Now update the free list; there will be a single free block at
the end */
build_free_list(&code_heap,size);
}

90
vm/code_heap.h
View File

@ -1,78 +1,34 @@
typedef enum {
/* arg is a primitive number */
RT_PRIMITIVE,
/* arg is a literal table index, holding an array pair (symbol/dll) */
RT_DLSYM,
/* a pointer to a compiled word reference */
RT_DISPATCH,
/* a compiled word reference */
RT_XT,
/* current offset */
RT_HERE,
/* a local label */
RT_LABEL,
/* immediate literal */
RT_IMMEDIATE,
/* address of stack_chain var */
RT_STACK_CHAIN
} F_RELTYPE;
/* compiled code */
F_HEAP code_heap;
typedef enum {
/* absolute address in a 64-bit location */
RC_ABSOLUTE_CELL,
/* absolute address in a 32-bit location */
RC_ABSOLUTE,
/* relative address in a 32-bit location */
RC_RELATIVE,
/* relative address in a PowerPC LIS/ORI sequence */
RC_ABSOLUTE_PPC_2_2,
/* relative address in a PowerPC LWZ/STW/BC instruction */
RC_RELATIVE_PPC_2,
/* relative address in a PowerPC B/BL instruction */
RC_RELATIVE_PPC_3,
/* relative address in an ARM B/BL instruction */
RC_RELATIVE_ARM_3,
/* pointer to address in an ARM LDR/STR instruction */
RC_INDIRECT_ARM,
/* pointer to address in an ARM LDR/STR instruction offset by 8 bytes */
RC_INDIRECT_ARM_PC
} F_RELCLASS;
INLINE F_BLOCK *compiled_to_block(F_CODE_BLOCK *compiled)
{
return (F_BLOCK *)compiled - 1;
}
#define REL_RELATIVE_PPC_2_MASK 0xfffc
#define REL_RELATIVE_PPC_3_MASK 0x3fffffc
#define REL_INDIRECT_ARM_MASK 0xfff
#define REL_RELATIVE_ARM_3_MASK 0xffffff
INLINE F_CODE_BLOCK *block_to_compiled(F_BLOCK *block)
{
return (F_CODE_BLOCK *)(block + 1);
}
/* the rel type is built like a cell to avoid endian-specific code in
the compiler */
#define REL_TYPE(r) ((r)->type & 0x000000ff)
#define REL_CLASS(r) (((r)->type & 0x0000ff00) >> 8)
#define REL_ARGUMENT(r) (((r)->type & 0xffff0000) >> 16)
void init_code_heap(CELL size);
/* code relocation consists of a table of entries for each fixup */
typedef struct {
unsigned int type;
unsigned int offset;
} F_REL;
#define CREF(array,i) ((CELL)(array) + CELLS * (i))
void apply_relocation(CELL class, CELL offset, F_FIXNUM absolute_value);
void relocate_code_block(F_COMPILED *relocating, CELL code_start, CELL literals_start);
bool in_code_heap_p(CELL ptr);
void default_word_code(F_WORD *word, bool relocate);
void set_word_code(F_WORD *word, F_COMPILED *compiled);
void set_word_code(F_WORD *word, F_CODE_BLOCK *compiled);
F_COMPILED *add_compiled_block(
CELL type,
F_ARRAY *code,
F_ARRAY *labels,
CELL relocation,
F_ARRAY *literals);
typedef void (*CODE_HEAP_ITERATOR)(F_CODE_BLOCK *compiled);
CELL compiled_code_format(void);
bool stack_traces_p(void);
void iterate_code_heap(CODE_HEAP_ITERATOR iter);
void copy_code_heap_roots(void);
void update_code_heap_roots(void);
void primitive_modify_code_heap(void);
void primitive_code_room(void);
void compact_code_heap(void);

519
vm/data_gc.c
View File

@ -1,302 +1,7 @@
#include "master.h"
CELL init_zone(F_ZONE *z, CELL size, CELL start)
{
z->size = size;
z->start = z->here = start;
z->end = start + size;
return z->end;
}
void init_card_decks(void)
{
CELL start = align(data_heap->segment->start,DECK_SIZE);
allot_markers_offset = (CELL)data_heap->allot_markers - (start >> CARD_BITS);
cards_offset = (CELL)data_heap->cards - (start >> CARD_BITS);
decks_offset = (CELL)data_heap->decks - (start >> DECK_BITS);
}
F_DATA_HEAP *alloc_data_heap(CELL gens,
CELL young_size,
CELL aging_size,
CELL tenured_size)
{
young_size = align(young_size,DECK_SIZE);
aging_size = align(aging_size,DECK_SIZE);
tenured_size = align(tenured_size,DECK_SIZE);
F_DATA_HEAP *data_heap = safe_malloc(sizeof(F_DATA_HEAP));
data_heap->young_size = young_size;
data_heap->aging_size = aging_size;
data_heap->tenured_size = tenured_size;
data_heap->gen_count = gens;
CELL total_size;
if(data_heap->gen_count == 2)
total_size = young_size + 2 * tenured_size;
else if(data_heap->gen_count == 3)
total_size = young_size + 2 * aging_size + 2 * tenured_size;
else
{
fatal_error("Invalid number of generations",data_heap->gen_count);
return NULL; /* can't happen */
}
total_size += DECK_SIZE;
data_heap->segment = alloc_segment(total_size);
data_heap->generations = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
CELL cards_size = total_size >> CARD_BITS;
data_heap->allot_markers = safe_malloc(cards_size);
data_heap->allot_markers_end = data_heap->allot_markers + cards_size;
data_heap->cards = safe_malloc(cards_size);
data_heap->cards_end = data_heap->cards + cards_size;
CELL decks_size = total_size >> DECK_BITS;
data_heap->decks = safe_malloc(decks_size);
data_heap->decks_end = data_heap->decks + decks_size;
CELL alloter = align(data_heap->segment->start,DECK_SIZE);
alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter);
alloter = init_zone(&data_heap->semispaces[TENURED],tenured_size,alloter);
if(data_heap->gen_count == 3)
{
alloter = init_zone(&data_heap->generations[AGING],aging_size,alloter);
alloter = init_zone(&data_heap->semispaces[AGING],aging_size,alloter);
}
if(data_heap->gen_count >= 2)
{
alloter = init_zone(&data_heap->generations[NURSERY],young_size,alloter);
alloter = init_zone(&data_heap->semispaces[NURSERY],0,alloter);
}
if(data_heap->segment->end - alloter > DECK_SIZE)
critical_error("Bug in alloc_data_heap",alloter);
return data_heap;
}
F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes)
{
CELL new_tenured_size = (data_heap->tenured_size * 2) + requested_bytes;
return alloc_data_heap(data_heap->gen_count,
data_heap->young_size,
data_heap->aging_size,
new_tenured_size);
}
void dealloc_data_heap(F_DATA_HEAP *data_heap)
{
dealloc_segment(data_heap->segment);
free(data_heap->generations);
free(data_heap->semispaces);
free(data_heap->allot_markers);
free(data_heap->cards);
free(data_heap->decks);
free(data_heap);
}
void clear_cards(CELL from, CELL to)
{
/* NOTE: reverse order due to heap layout. */
F_CARD *first_card = ADDR_TO_CARD(data_heap->generations[to].start);
F_CARD *last_card = ADDR_TO_CARD(data_heap->generations[from].end);
memset(first_card,0,last_card - first_card);
}
void clear_decks(CELL from, CELL to)
{
/* NOTE: reverse order due to heap layout. */
F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[to].start);
F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[from].end);
memset(first_deck,0,last_deck - first_deck);
}
void clear_allot_markers(CELL from, CELL to)
{
/* NOTE: reverse order due to heap layout. */
F_CARD *first_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[to].start);
F_CARD *last_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[from].end);
memset(first_card,INVALID_ALLOT_MARKER,last_card - first_card);
}
void set_data_heap(F_DATA_HEAP *data_heap_)
{
data_heap = data_heap_;
nursery = data_heap->generations[NURSERY];
init_card_decks();
clear_cards(NURSERY,TENURED);
clear_decks(NURSERY,TENURED);
clear_allot_markers(NURSERY,TENURED);
}
void gc_reset(void)
{
int i;
for(i = 0; i < MAX_GEN_COUNT; i++)
memset(&gc_stats[i],0,sizeof(F_GC_STATS));
cards_scanned = 0;
decks_scanned = 0;
code_heap_scans = 0;
}
void init_data_heap(CELL gens,
CELL young_size,
CELL aging_size,
CELL tenured_size,
bool secure_gc_)
{
set_data_heap(alloc_data_heap(gens,young_size,aging_size,tenured_size));
gc_locals_region = alloc_segment(getpagesize());
gc_locals = gc_locals_region->start - CELLS;
extra_roots_region = alloc_segment(getpagesize());
extra_roots = extra_roots_region->start - CELLS;
secure_gc = secure_gc_;
gc_reset();
}
/* Size of the object pointed to by a tagged pointer */
CELL object_size(CELL tagged)
{
if(immediate_p(tagged))
return 0;
else
return untagged_object_size(UNTAG(tagged));
}
/* Size of the object pointed to by an untagged pointer */
CELL untagged_object_size(CELL pointer)
{
return align8(unaligned_object_size(pointer));
}
/* Size of the data area of an object pointed to by an untagged pointer */
CELL unaligned_object_size(CELL pointer)
{
F_TUPLE *tuple;
F_TUPLE_LAYOUT *layout;
switch(untag_header(get(pointer)))
{
case ARRAY_TYPE:
case BIGNUM_TYPE:
return array_size(array_capacity((F_ARRAY*)pointer));
case BYTE_ARRAY_TYPE:
return byte_array_size(
byte_array_capacity((F_BYTE_ARRAY*)pointer));
case STRING_TYPE:
return string_size(string_capacity((F_STRING*)pointer));
case TUPLE_TYPE:
tuple = untag_object(pointer);
layout = untag_object(tuple->layout);
return tuple_size(layout);
case QUOTATION_TYPE:
return sizeof(F_QUOTATION);
case WORD_TYPE:
return sizeof(F_WORD);
case RATIO_TYPE:
return sizeof(F_RATIO);
case FLOAT_TYPE:
return sizeof(F_FLOAT);
case COMPLEX_TYPE:
return sizeof(F_COMPLEX);
case DLL_TYPE:
return sizeof(F_DLL);
case ALIEN_TYPE:
return sizeof(F_ALIEN);
case WRAPPER_TYPE:
return sizeof(F_WRAPPER);
case CALLSTACK_TYPE:
return callstack_size(
untag_fixnum_fast(((F_CALLSTACK *)pointer)->length));
default:
critical_error("Invalid header",pointer);
return -1; /* can't happen */
}
}
void primitive_size(void)
{
box_unsigned_cell(object_size(dpop()));
}
/* Push memory usage statistics in data heap */
void primitive_data_room(void)
{
F_ARRAY *a = allot_array(ARRAY_TYPE,data_heap->gen_count * 2,F);
int gen;
dpush(tag_fixnum((data_heap->cards_end - data_heap->cards) >> 10));
dpush(tag_fixnum((data_heap->decks_end - data_heap->decks) >> 10));
for(gen = 0; gen < data_heap->gen_count; gen++)
{
F_ZONE *z = (gen == NURSERY ? &nursery : &data_heap->generations[gen]);
set_array_nth(a,gen * 2,tag_fixnum((z->end - z->here) >> 10));
set_array_nth(a,gen * 2 + 1,tag_fixnum((z->size) >> 10));
}
dpush(tag_object(a));
}
/* Disables GC and activates next-object ( -- obj ) primitive */
void begin_scan(void)
{
heap_scan_ptr = data_heap->generations[TENURED].start;
gc_off = true;
}
void primitive_begin_scan(void)
{
gc();
begin_scan();
}
CELL next_object(void)
{
if(!gc_off)
general_error(ERROR_HEAP_SCAN,F,F,NULL);
CELL value = get(heap_scan_ptr);
CELL obj = heap_scan_ptr;
CELL type;
if(heap_scan_ptr >= data_heap->generations[TENURED].here)
return F;
type = untag_header(value);
heap_scan_ptr += untagged_object_size(heap_scan_ptr);
return RETAG(obj,type <= HEADER_TYPE ? type : OBJECT_TYPE);
}
/* Push object at heap scan cursor and advance; pushes f when done */
void primitive_next_object(void)
{
dpush(next_object());
}
/* Re-enables GC */
void primitive_end_scan(void)
{
gc_off = false;
}
/* Scan all the objects in the card */
void collect_card(F_CARD *ptr, CELL gen, CELL here)
void copy_card(F_CARD *ptr, CELL gen, CELL here)
{
CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + CARD_OFFSET(ptr);
CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
@ -304,12 +9,12 @@ void collect_card(F_CARD *ptr, CELL gen, CELL here)
if(here < card_end)
card_end = here;
collect_next_loop(card_scan,&card_end);
copy_reachable_objects(card_scan,&card_end);
cards_scanned++;
}
void collect_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask)
void copy_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask)
{
F_CARD *first_card = DECK_TO_CARD(deck);
F_CARD *last_card = DECK_TO_CARD(deck + 1);
@ -330,7 +35,7 @@ void collect_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask)
{
if(ptr[card] & mask)
{
collect_card(&ptr[card],gen,here);
copy_card(&ptr[card],gen,here);
ptr[card] &= ~unmask;
}
}
@ -341,7 +46,7 @@ void collect_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask)
}
/* Copy all newspace objects referenced from marked cards to the destination */
void collect_gen_cards(CELL gen)
void copy_gen_cards(CELL gen)
{
F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[gen].start);
F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[gen].end);
@ -365,7 +70,7 @@ void collect_gen_cards(CELL gen)
unmask = CARD_MARK_MASK;
else
{
critical_error("bug in collect_gen_cards",gen);
critical_error("bug in copy_gen_cards",gen);
return;
}
}
@ -390,7 +95,7 @@ void collect_gen_cards(CELL gen)
}
else
{
critical_error("bug in collect_gen_cards",gen);
critical_error("bug in copy_gen_cards",gen);
return;
}
@ -400,7 +105,7 @@ void collect_gen_cards(CELL gen)
{
if(*ptr & mask)
{
collect_card_deck(ptr,gen,mask,unmask);
copy_card_deck(ptr,gen,mask,unmask);
*ptr &= ~unmask;
}
}
@ -408,15 +113,15 @@ void collect_gen_cards(CELL gen)
/* Scan cards in all generations older than the one being collected, copying
old->new references */
void collect_cards(void)
void copy_cards(void)
{
int i;
for(i = collecting_gen + 1; i < data_heap->gen_count; i++)
collect_gen_cards(i);
copy_gen_cards(i);
}
/* Copy all tagged pointers in a range of memory */
void collect_stack(F_SEGMENT *region, CELL top)
void copy_stack_elements(F_SEGMENT *region, CELL top)
{
CELL ptr = region->start;
@ -424,25 +129,7 @@ void collect_stack(F_SEGMENT *region, CELL top)
copy_handle((CELL*)ptr);
}
void collect_stack_frame(F_STACK_FRAME *frame)
{
recursive_mark(compiled_to_block(frame_code(frame)));
}
/* The base parameter allows us to adjust for a heap-allocated
callstack snapshot */
void collect_callstack(F_CONTEXT *stacks)
{
if(collecting_gen == TENURED)
{
CELL top = (CELL)stacks->callstack_top;
CELL bottom = (CELL)stacks->callstack_bottom;
iterate_callstack(top,bottom,collect_stack_frame);
}
}
void collect_gc_locals(void)
void copy_registered_locals(void)
{
CELL ptr = gc_locals_region->start;
@ -452,28 +139,28 @@ void collect_gc_locals(void)
/* Copy roots over at the start of GC, namely various constants, stacks,
the user environment and extra roots registered with REGISTER_ROOT */
void collect_roots(void)
void copy_roots(void)
{
copy_handle(&T);
copy_handle(&bignum_zero);
copy_handle(&bignum_pos_one);
copy_handle(&bignum_neg_one);
collect_gc_locals();
collect_stack(extra_roots_region,extra_roots);
copy_registered_locals();
copy_stack_elements(extra_roots_region,extra_roots);
save_stacks();
F_CONTEXT *stacks = stack_chain;
while(stacks)
{
collect_stack(stacks->datastack_region,stacks->datastack);
collect_stack(stacks->retainstack_region,stacks->retainstack);
copy_stack_elements(stacks->datastack_region,stacks->datastack);
copy_stack_elements(stacks->retainstack_region,stacks->retainstack);
copy_handle(&stacks->catchstack_save);
copy_handle(&stacks->current_callback_save);
collect_callstack(stacks);
mark_active_blocks(stacks);
stacks = stacks->next;
}
@ -554,79 +241,7 @@ void copy_handle(CELL *handle)
*handle = copy_object(pointer);
}
/* The number of cells from the start of the object which should be scanned by
the GC. Some types have a binary payload at the end (string, word, DLL) which
we ignore. */
CELL binary_payload_start(CELL pointer)
{
F_TUPLE *tuple;
F_TUPLE_LAYOUT *layout;
switch(untag_header(get(pointer)))
{
/* these objects do not refer to other objects at all */
case FLOAT_TYPE:
case BYTE_ARRAY_TYPE:
case BIGNUM_TYPE:
case CALLSTACK_TYPE:
return 0;
/* these objects have some binary data at the end */
case WORD_TYPE:
return sizeof(F_WORD) - CELLS * 3;
case ALIEN_TYPE:
return CELLS * 3;
case DLL_TYPE:
return CELLS * 2;
case QUOTATION_TYPE:
return sizeof(F_QUOTATION) - CELLS * 2;
case STRING_TYPE:
return sizeof(F_STRING);
/* everything else consists entirely of pointers */
case ARRAY_TYPE:
return array_size(array_capacity((F_ARRAY*)pointer));
case TUPLE_TYPE:
tuple = untag_object(pointer);
layout = untag_object(tuple->layout);
return tuple_size(layout);
case RATIO_TYPE:
return sizeof(F_RATIO);
case COMPLEX_TYPE:
return sizeof(F_COMPLEX);
case WRAPPER_TYPE:
return sizeof(F_WRAPPER);
default:
critical_error("Invalid header",pointer);
return -1; /* can't happen */
}
}
void do_code_slots(CELL scan)
{
F_WORD *word;
F_QUOTATION *quot;
F_CALLSTACK *stack;
switch(object_type(scan))
{
case WORD_TYPE:
word = (F_WORD *)scan;
recursive_mark(compiled_to_block(word->code));
if(word->profiling)
recursive_mark(compiled_to_block(word->profiling));
break;
case QUOTATION_TYPE:
quot = (F_QUOTATION *)scan;
if(quot->compiledp != F)
recursive_mark(compiled_to_block(quot->code));
break;
case CALLSTACK_TYPE:
stack = (F_CALLSTACK *)scan;
iterate_callstack_object(stack,collect_stack_frame);
break;
}
}
CELL collect_next_nursery(CELL scan)
CELL copy_next_from_nursery(CELL scan)
{
CELL *obj = (CELL *)scan;
CELL *end = (CELL *)(scan + binary_payload_start(scan));
@ -651,7 +266,7 @@ CELL collect_next_nursery(CELL scan)
return scan + untagged_object_size(scan);
}
CELL collect_next_aging(CELL scan)
CELL copy_next_from_aging(CELL scan)
{
CELL *obj = (CELL *)scan;
CELL *end = (CELL *)(scan + binary_payload_start(scan));
@ -680,8 +295,7 @@ CELL collect_next_aging(CELL scan)
return scan + untagged_object_size(scan);
}
/* This function is performance-critical */
CELL collect_next_tenured(CELL scan)
CELL copy_next_from_tenured(CELL scan)
{
CELL *obj = (CELL *)scan;
CELL *end = (CELL *)(scan + binary_payload_start(scan));
@ -702,52 +316,30 @@ CELL collect_next_tenured(CELL scan)
}
}
do_code_slots(scan);
mark_object_code_block(scan);
return scan + untagged_object_size(scan);
}
void collect_next_loop(CELL scan, CELL *end)
void copy_reachable_objects(CELL scan, CELL *end)
{
if(HAVE_NURSERY_P && collecting_gen == NURSERY)
{
while(scan < *end)
scan = collect_next_nursery(scan);
scan = copy_next_from_nursery(scan);
}
else if(HAVE_AGING_P && collecting_gen == AGING)
{
while(scan < *end)
scan = collect_next_aging(scan);
scan = copy_next_from_aging(scan);
}
else if(collecting_gen == TENURED)
{
while(scan < *end)
scan = collect_next_tenured(scan);
scan = copy_next_from_tenured(scan);
}
}
INLINE void reset_generation(CELL i)
{
F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]);
z->here = z->start;
if(secure_gc)
memset((void*)z->start,69,z->size);
}
/* After garbage collection, any generations which are now empty need to have
their allocation pointers and cards reset. */
void reset_generations(CELL from, CELL to)
{
CELL i;
for(i = from; i <= to; i++)
reset_generation(i);
clear_cards(from,to);
clear_decks(from,to);
clear_allot_markers(from,to);
}
/* Prepare to start copying reachable objects into an unused zone */
void begin_gc(CELL requested_bytes)
{
@ -879,25 +471,22 @@ void garbage_collection(CELL gen,
CELL scan = newspace->here;
/* collect objects referenced from stacks and environment */
collect_roots();
copy_roots();
/* collect objects referenced from older generations */
collect_cards();
copy_cards();
/* do some tracing */
copy_reachable_objects(scan,&newspace->here);
/* don't scan code heap unless it has pointers to this
generation or younger */
if(collecting_gen >= last_code_heap_scan)
{
if(collecting_gen != TENURED)
{
/* if we are doing code GC, then we will copy over
literals from any code block which gets marked as live.
if we are not doing code GC, just consider all literals
as roots. */
code_heap_scans++;
code_heap_scans++;
collect_literals();
}
if(collecting_gen == TENURED)
update_code_heap_roots();
else
copy_code_heap_roots();
if(collecting_accumulation_gen_p())
last_code_heap_scan = collecting_gen;
@ -905,8 +494,6 @@ void garbage_collection(CELL gen,
last_code_heap_scan = collecting_gen + 1;
}
collect_next_loop(scan,&newspace->here);
CELL gc_elapsed = (current_micros() - start);
end_gc(gc_elapsed);
@ -958,9 +545,20 @@ void primitive_gc_stats(void)
dpush(stats);
}
void primitive_gc_reset(void)
void clear_gc_stats(void)
{
gc_reset();
int i;
for(i = 0; i < MAX_GEN_COUNT; i++)
memset(&gc_stats[i],0,sizeof(F_GC_STATS));
cards_scanned = 0;
decks_scanned = 0;
code_heap_scans = 0;
}
void primitive_clear_gc_stats(void)
{
clear_gc_stats();
}
void primitive_become(void)
@ -986,24 +584,3 @@ void primitive_become(void)
compile_all_words();
}
CELL find_all_words(void)
{
GROWABLE_ARRAY(words);
begin_scan();
CELL obj;
while((obj = next_object()) != F)
{
if(type_of(obj) == WORD_TYPE)
GROWABLE_ARRAY_ADD(words,obj);
}
/* End heap scan */
gc_off = false;
GROWABLE_ARRAY_TRIM(words);
return words;
}

299
vm/data_gc.h
View File

@ -1,163 +1,19 @@
/* Set by the -S command line argument */
bool secure_gc;
/* set up guard pages to check for under/overflow.
size must be a multiple of the page size */
F_SEGMENT *alloc_segment(CELL size);
void dealloc_segment(F_SEGMENT *block);
CELL untagged_object_size(CELL pointer);
CELL unaligned_object_size(CELL pointer);
CELL object_size(CELL pointer);
CELL binary_payload_start(CELL pointer);
void begin_scan(void);
CELL next_object(void);
void primitive_data_room(void);
void primitive_size(void);
void primitive_begin_scan(void);
void primitive_next_object(void);
void primitive_end_scan(void);
void gc(void);
DLLEXPORT void minor_gc(void);
/* generational copying GC divides memory into zones */
typedef struct {
/* allocation pointer is 'here'; its offset is hardcoded in the
compiler backends, see core/compiler/.../allot.factor */
CELL start;
CELL here;
CELL size;
CELL end;
} F_ZONE;
typedef struct {
F_SEGMENT *segment;
CELL young_size;
CELL aging_size;
CELL tenured_size;
CELL gen_count;
F_ZONE *generations;
F_ZONE* semispaces;
CELL *allot_markers;
CELL *allot_markers_end;
CELL *cards;
CELL *cards_end;
CELL *decks;
CELL *decks_end;
} F_DATA_HEAP;
F_DATA_HEAP *data_heap;
/* card marking write barrier. a card is a byte storing a mark flag,
and the offset (in cells) of the first object in the card.
the mark flag is set by the write barrier when an object in the
card has a slot written to.
the offset of the first object is set by the allocator. */
/* if CARD_POINTS_TO_NURSERY is set, CARD_POINTS_TO_AGING must also be set. */
#define CARD_POINTS_TO_NURSERY 0x80
#define CARD_POINTS_TO_AGING 0x40
#define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING)
typedef u8 F_CARD;
#define CARD_BITS 8
#define CARD_SIZE (1<<CARD_BITS)
#define ADDR_CARD_MASK (CARD_SIZE-1)
DLLEXPORT CELL cards_offset;
#define ADDR_TO_CARD(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + cards_offset)
#define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)<<CARD_BITS)
typedef u8 F_DECK;
#define DECK_BITS (CARD_BITS + 10)
#define DECK_SIZE (1<<DECK_BITS)
#define ADDR_DECK_MASK (DECK_SIZE-1)
DLLEXPORT CELL decks_offset;
#define ADDR_TO_DECK(a) (F_DECK*)(((CELL)(a) >> DECK_BITS) + decks_offset)
#define DECK_TO_ADDR(c) (CELL*)(((CELL)(c) - decks_offset) << DECK_BITS)
#define DECK_TO_CARD(d) (F_CARD*)((((CELL)(d) - decks_offset) << (DECK_BITS - CARD_BITS)) + cards_offset)
#define ADDR_TO_ALLOT_MARKER(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + allot_markers_offset)
#define CARD_OFFSET(c) (*((c) - (CELL)data_heap->cards + (CELL)data_heap->allot_markers))
#define INVALID_ALLOT_MARKER 0xff
DLLEXPORT CELL allot_markers_offset;
void init_card_decks(void);
/* the write barrier must be called any time we are potentially storing a
pointer from an older generation to a younger one */
INLINE void write_barrier(CELL address)
{
*ADDR_TO_CARD(address) = CARD_MARK_MASK;
*ADDR_TO_DECK(address) = CARD_MARK_MASK;
}
#define SLOT(obj,slot) (UNTAG(obj) + (slot) * CELLS)
INLINE void set_slot(CELL obj, CELL slot, CELL value)
{
put(SLOT(obj,slot),value);
write_barrier(obj);
}
/* we need to remember the first object allocated in the card */
INLINE void allot_barrier(CELL address)
{
F_CARD *ptr = ADDR_TO_ALLOT_MARKER(address);
if(*ptr == INVALID_ALLOT_MARKER)
*ptr = (address & ADDR_CARD_MASK);
}
void clear_cards(CELL from, CELL to);
void collect_cards(void);
/* the 0th generation is where new objects are allocated. */
#define NURSERY 0
#define HAVE_NURSERY_P (data_heap->gen_count>1)
/* where objects hang around */
#define AGING (data_heap->gen_count-2)
#define HAVE_AGING_P (data_heap->gen_count>2)
/* the oldest generation */
#define TENURED (data_heap->gen_count-1)
#define MIN_GEN_COUNT 1
#define MAX_GEN_COUNT 3
/* used during garbage collection only */
F_ZONE *newspace;
bool performing_gc;
CELL collecting_gen;
/* new objects are allocated here */
DLLEXPORT F_ZONE nursery;
/* if true, we collecting AGING space for the second time, so if it is still
full, we go on to collect TENURED */
bool collecting_aging_again;
INLINE bool in_zone(F_ZONE *z, CELL pointer)
{
return pointer >= z->start && pointer < z->end;
}
CELL init_zone(F_ZONE *z, CELL size, CELL base);
void init_data_heap(CELL gens,
CELL young_size,
CELL aging_size,
CELL tenured_size,
bool secure_gc_);
/* in case a generation fills up in the middle of a gc, we jump back
up to try collecting the next generation. */
jmp_buf gc_jmp;
/* statistics */
typedef struct {
@ -173,24 +29,8 @@ u64 cards_scanned;
u64 decks_scanned;
CELL code_heap_scans;
/* only meaningful during a GC */
bool performing_gc;
CELL collecting_gen;
/* if true, we collecting AGING space for the second time, so if it is still
full, we go on to collect TENURED */
bool collecting_aging_again;
INLINE bool collecting_accumulation_gen_p(void)
{
return ((HAVE_AGING_P
&& collecting_gen == AGING
&& !collecting_aging_again)
|| collecting_gen == TENURED);
}
/* What generation was being collected when collect_literals() was last
called? Until the next call to primitive_add_compiled_block(), future
/* What generation was being collected when copy_code_heap_roots() was last
called? Until the next call to add_compiled_block(), future
collections of younger generations don't have to touch the code
heap. */
CELL last_code_heap_scan;
@ -199,22 +39,12 @@ CELL last_code_heap_scan;
bool growing_data_heap;
F_DATA_HEAP *old_data_heap;
/* 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. */
INLINE void do_slots(CELL obj, void (* iter)(CELL *))
INLINE bool collecting_accumulation_gen_p(void)
{
CELL scan = obj;
CELL payload_start = binary_payload_start(obj);
CELL end = obj + payload_start;
scan += CELLS;
while(scan < end)
{
iter((CELL *)scan);
scan += CELLS;
}
return ((HAVE_AGING_P
&& collecting_gen == AGING
&& !collecting_aging_again)
|| collecting_gen == TENURED);
}
/* test if the pointer is in generation being collected, or a younger one. */
@ -237,98 +67,10 @@ INLINE bool should_copy(CELL untagged)
void copy_handle(CELL *handle);
/* in case a generation fills up in the middle of a gc, we jump back
up to try collecting the next generation. */
jmp_buf gc_jmp;
/* 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 garbage_collection(volatile CELL gen,
bool growing_data_heap_,
CELL requested_bytes);
/* If a runtime function needs to call another function which potentially
allocates memory, it must store any local variable references to Factor
objects on the root stack */
/* GC locals: stores addresses of pointers to objects. The GC updates these
pointers, so you can do
REGISTER_ROOT(some_local);
... allocate memory ...
foo(some_local);
...
UNREGISTER_ROOT(some_local); */
F_SEGMENT *gc_locals_region;
CELL gc_locals;
DEFPUSHPOP(gc_local_,gc_locals)
#define REGISTER_ROOT(obj) gc_local_push((CELL)&obj)
#define UNREGISTER_ROOT(obj) \
{ \
if(gc_local_pop() != (CELL)&obj) \
critical_error("Mismatched REGISTER_ROOT/UNREGISTER_ROOT",0); \
}
/* Extra roots: stores pointers to objects in the heap. Requires extra work
(you have to unregister before accessing the object) but more flexible. */
F_SEGMENT *extra_roots_region;
CELL extra_roots;
DEFPUSHPOP(root_,extra_roots)
#define REGISTER_UNTAGGED(obj) root_push(obj ? tag_object(obj) : 0)
#define UNREGISTER_UNTAGGED(obj) obj = untag_object(root_pop())
INLINE bool in_data_heap_p(CELL ptr)
{
return (ptr >= data_heap->segment->start
&& ptr <= data_heap->segment->end);
}
/* We ignore strings which point outside the data heap, but we might be given
a char* which points inside the data heap, in which case it is a root, for
example if we call unbox_char_string() the result is placed in a byte array */
INLINE bool root_push_alien(const void *ptr)
{
if(in_data_heap_p((CELL)ptr))
{
F_BYTE_ARRAY *objptr = ((F_BYTE_ARRAY *)ptr) - 1;
if(objptr->header == tag_header(BYTE_ARRAY_TYPE))
{
root_push(tag_object(objptr));
return true;
}
}
return false;
}
#define REGISTER_C_STRING(obj) \
bool obj##_root = root_push_alien(obj)
#define UNREGISTER_C_STRING(obj) \
if(obj##_root) obj = alien_offset(root_pop())
#define REGISTER_BIGNUM(obj) if(obj) root_push(tag_bignum(obj))
#define UNREGISTER_BIGNUM(obj) if(obj) obj = (untag_object(root_pop()))
INLINE void *allot_zone(F_ZONE *z, CELL a)
{
CELL h = z->here;
z->here = h + align8(a);
return (void*)h;
}
/* We leave this many bytes free at the top of the nursery so that inline
allocation (which does not call GC because of possible roots in volatile
registers) does not run out of memory */
@ -338,7 +80,7 @@ registers) does not run out of memory */
* It is up to the caller to fill in the object's fields in a meaningful
* fashion!
*/
INLINE void* allot_object(CELL type, CELL a)
INLINE void *allot_object(CELL type, CELL a)
{
CELL *object;
@ -387,11 +129,10 @@ INLINE void* allot_object(CELL type, CELL a)
return object;
}
void collect_next_loop(CELL scan, CELL *end);
void copy_reachable_objects(CELL scan, CELL *end);
void primitive_gc(void);
void primitive_gc_stats(void);
void primitive_gc_reset(void);
void clear_gc_stats(void);
void primitive_clear_gc_stats(void);
void primitive_become(void);
CELL find_all_words(void);

371
vm/data_heap.c Normal file
View File

@ -0,0 +1,371 @@
#include "master.h"
CELL init_zone(F_ZONE *z, CELL size, CELL start)
{
z->size = size;
z->start = z->here = start;
z->end = start + size;
return z->end;
}
void init_card_decks(void)
{
CELL start = align(data_heap->segment->start,DECK_SIZE);
allot_markers_offset = (CELL)data_heap->allot_markers - (start >> CARD_BITS);
cards_offset = (CELL)data_heap->cards - (start >> CARD_BITS);
decks_offset = (CELL)data_heap->decks - (start >> DECK_BITS);
}
F_DATA_HEAP *alloc_data_heap(CELL gens,
CELL young_size,
CELL aging_size,
CELL tenured_size)
{
young_size = align(young_size,DECK_SIZE);
aging_size = align(aging_size,DECK_SIZE);
tenured_size = align(tenured_size,DECK_SIZE);
F_DATA_HEAP *data_heap = safe_malloc(sizeof(F_DATA_HEAP));
data_heap->young_size = young_size;
data_heap->aging_size = aging_size;
data_heap->tenured_size = tenured_size;
data_heap->gen_count = gens;
CELL total_size;
if(data_heap->gen_count == 2)
total_size = young_size + 2 * tenured_size;
else if(data_heap->gen_count == 3)
total_size = young_size + 2 * aging_size + 2 * tenured_size;
else
{
fatal_error("Invalid number of generations",data_heap->gen_count);
return NULL; /* can't happen */
}
total_size += DECK_SIZE;
data_heap->segment = alloc_segment(total_size);
data_heap->generations = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
CELL cards_size = total_size >> CARD_BITS;
data_heap->allot_markers = safe_malloc(cards_size);
data_heap->allot_markers_end = data_heap->allot_markers + cards_size;
data_heap->cards = safe_malloc(cards_size);
data_heap->cards_end = data_heap->cards + cards_size;
CELL decks_size = total_size >> DECK_BITS;
data_heap->decks = safe_malloc(decks_size);
data_heap->decks_end = data_heap->decks + decks_size;
CELL alloter = align(data_heap->segment->start,DECK_SIZE);
alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter);
alloter = init_zone(&data_heap->semispaces[TENURED],tenured_size,alloter);
if(data_heap->gen_count == 3)
{
alloter = init_zone(&data_heap->generations[AGING],aging_size,alloter);
alloter = init_zone(&data_heap->semispaces[AGING],aging_size,alloter);
}
if(data_heap->gen_count >= 2)
{
alloter = init_zone(&data_heap->generations[NURSERY],young_size,alloter);
alloter = init_zone(&data_heap->semispaces[NURSERY],0,alloter);
}
if(data_heap->segment->end - alloter > DECK_SIZE)
critical_error("Bug in alloc_data_heap",alloter);
return data_heap;
}
F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes)
{
CELL new_tenured_size = (data_heap->tenured_size * 2) + requested_bytes;
return alloc_data_heap(data_heap->gen_count,
data_heap->young_size,
data_heap->aging_size,
new_tenured_size);
}
void dealloc_data_heap(F_DATA_HEAP *data_heap)
{
dealloc_segment(data_heap->segment);
free(data_heap->generations);
free(data_heap->semispaces);
free(data_heap->allot_markers);
free(data_heap->cards);
free(data_heap->decks);
free(data_heap);
}
void clear_cards(CELL from, CELL to)
{
/* NOTE: reverse order due to heap layout. */
F_CARD *first_card = ADDR_TO_CARD(data_heap->generations[to].start);
F_CARD *last_card = ADDR_TO_CARD(data_heap->generations[from].end);
memset(first_card,0,last_card - first_card);
}
void clear_decks(CELL from, CELL to)
{
/* NOTE: reverse order due to heap layout. */
F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[to].start);
F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[from].end);
memset(first_deck,0,last_deck - first_deck);
}
void clear_allot_markers(CELL from, CELL to)
{
/* NOTE: reverse order due to heap layout. */
F_CARD *first_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[to].start);
F_CARD *last_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[from].end);
memset(first_card,INVALID_ALLOT_MARKER,last_card - first_card);
}
void reset_generation(CELL i)
{
F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]);
z->here = z->start;
if(secure_gc)
memset((void*)z->start,69,z->size);
}
/* After garbage collection, any generations which are now empty need to have
their allocation pointers and cards reset. */
void reset_generations(CELL from, CELL to)
{
CELL i;
for(i = from; i <= to; i++)
reset_generation(i);
clear_cards(from,to);
clear_decks(from,to);
clear_allot_markers(from,to);
}
void set_data_heap(F_DATA_HEAP *data_heap_)
{
data_heap = data_heap_;
nursery = data_heap->generations[NURSERY];
init_card_decks();
clear_cards(NURSERY,TENURED);
clear_decks(NURSERY,TENURED);
clear_allot_markers(NURSERY,TENURED);
}
void init_data_heap(CELL gens,
CELL young_size,
CELL aging_size,
CELL tenured_size,
bool secure_gc_)
{
set_data_heap(alloc_data_heap(gens,young_size,aging_size,tenured_size));
gc_locals_region = alloc_segment(getpagesize());
gc_locals = gc_locals_region->start - CELLS;
extra_roots_region = alloc_segment(getpagesize());
extra_roots = extra_roots_region->start - CELLS;
secure_gc = secure_gc_;
}
/* Size of the object pointed to by a tagged pointer */
CELL object_size(CELL tagged)
{
if(immediate_p(tagged))
return 0;
else
return untagged_object_size(UNTAG(tagged));
}
/* Size of the object pointed to by an untagged pointer */
CELL untagged_object_size(CELL pointer)
{
return align8(unaligned_object_size(pointer));
}
/* Size of the data area of an object pointed to by an untagged pointer */
CELL unaligned_object_size(CELL pointer)
{
F_TUPLE *tuple;
F_TUPLE_LAYOUT *layout;
switch(untag_header(get(pointer)))
{
case ARRAY_TYPE:
case BIGNUM_TYPE:
return array_size(array_capacity((F_ARRAY*)pointer));
case BYTE_ARRAY_TYPE:
return byte_array_size(
byte_array_capacity((F_BYTE_ARRAY*)pointer));
case STRING_TYPE:
return string_size(string_capacity((F_STRING*)pointer));
case TUPLE_TYPE:
tuple = untag_object(pointer);
layout = untag_object(tuple->layout);
return tuple_size(layout);
case QUOTATION_TYPE:
return sizeof(F_QUOTATION);
case WORD_TYPE:
return sizeof(F_WORD);
case RATIO_TYPE:
return sizeof(F_RATIO);
case FLOAT_TYPE:
return sizeof(F_FLOAT);
case COMPLEX_TYPE:
return sizeof(F_COMPLEX);
case DLL_TYPE:
return sizeof(F_DLL);
case ALIEN_TYPE:
return sizeof(F_ALIEN);
case WRAPPER_TYPE:
return sizeof(F_WRAPPER);
case CALLSTACK_TYPE:
return callstack_size(
untag_fixnum_fast(((F_CALLSTACK *)pointer)->length));
default:
critical_error("Invalid header",pointer);
return -1; /* can't happen */
}
}
void primitive_size(void)
{
box_unsigned_cell(object_size(dpop()));
}
/* The number of cells from the start of the object which should be scanned by
the GC. Some types have a binary payload at the end (string, word, DLL) which
we ignore. */
CELL binary_payload_start(CELL pointer)
{
F_TUPLE *tuple;
F_TUPLE_LAYOUT *layout;
switch(untag_header(get(pointer)))
{
/* these objects do not refer to other objects at all */
case FLOAT_TYPE:
case BYTE_ARRAY_TYPE:
case BIGNUM_TYPE:
case CALLSTACK_TYPE:
return 0;
/* these objects have some binary data at the end */
case WORD_TYPE:
return sizeof(F_WORD) - CELLS * 3;
case ALIEN_TYPE:
return CELLS * 3;
case DLL_TYPE:
return CELLS * 2;
case QUOTATION_TYPE:
return sizeof(F_QUOTATION) - CELLS * 2;
case STRING_TYPE:
return sizeof(F_STRING);
/* everything else consists entirely of pointers */
case ARRAY_TYPE:
return array_size(array_capacity((F_ARRAY*)pointer));
case TUPLE_TYPE:
tuple = untag_object(pointer);
layout = untag_object(tuple->layout);
return tuple_size(layout);
case RATIO_TYPE:
return sizeof(F_RATIO);
case COMPLEX_TYPE:
return sizeof(F_COMPLEX);
case WRAPPER_TYPE:
return sizeof(F_WRAPPER);
default:
critical_error("Invalid header",pointer);
return -1; /* can't happen */
}
}
/* Push memory usage statistics in data heap */
void primitive_data_room(void)
{
F_ARRAY *a = allot_array(ARRAY_TYPE,data_heap->gen_count * 2,F);
int gen;
dpush(tag_fixnum((data_heap->cards_end - data_heap->cards) >> 10));
dpush(tag_fixnum((data_heap->decks_end - data_heap->decks) >> 10));
for(gen = 0; gen < data_heap->gen_count; gen++)
{
F_ZONE *z = (gen == NURSERY ? &nursery : &data_heap->generations[gen]);
set_array_nth(a,gen * 2,tag_fixnum((z->end - z->here) >> 10));
set_array_nth(a,gen * 2 + 1,tag_fixnum((z->size) >> 10));
}
dpush(tag_object(a));
}
/* Disables GC and activates next-object ( -- obj ) primitive */
void begin_scan(void)
{
heap_scan_ptr = data_heap->generations[TENURED].start;
gc_off = true;
}
void primitive_begin_scan(void)
{
begin_scan();
}
CELL next_object(void)
{
if(!gc_off)
general_error(ERROR_HEAP_SCAN,F,F,NULL);
CELL value = get(heap_scan_ptr);
CELL obj = heap_scan_ptr;
CELL type;
if(heap_scan_ptr >= data_heap->generations[TENURED].here)
return F;
type = untag_header(value);
heap_scan_ptr += untagged_object_size(heap_scan_ptr);
return RETAG(obj,type <= HEADER_TYPE ? type : OBJECT_TYPE);
}
/* Push object at heap scan cursor and advance; pushes f when done */
void primitive_next_object(void)
{
dpush(next_object());
}
/* Re-enables GC */
void primitive_end_scan(void)
{
gc_off = false;
}
CELL find_all_words(void)
{
GROWABLE_ARRAY(words);
begin_scan();
CELL obj;
while((obj = next_object()) != F)
{
if(type_of(obj) == WORD_TYPE)
GROWABLE_ARRAY_ADD(words,obj);
}
/* End heap scan */
gc_off = false;
GROWABLE_ARRAY_TRIM(words);
return words;
}

138
vm/data_heap.h Normal file
View File

@ -0,0 +1,138 @@
/* Set by the -securegc command line argument */
bool secure_gc;
/* generational copying GC divides memory into zones */
typedef struct {
/* allocation pointer is 'here'; its offset is hardcoded in the
compiler backends*/
CELL start;
CELL here;
CELL size;
CELL end;
} F_ZONE;
typedef struct {
F_SEGMENT *segment;
CELL young_size;
CELL aging_size;
CELL tenured_size;
CELL gen_count;
F_ZONE *generations;
F_ZONE* semispaces;
CELL *allot_markers;
CELL *allot_markers_end;
CELL *cards;
CELL *cards_end;
CELL *decks;
CELL *decks_end;
} F_DATA_HEAP;
F_DATA_HEAP *data_heap;
/* the 0th generation is where new objects are allocated. */
#define NURSERY 0
#define HAVE_NURSERY_P (data_heap->gen_count>1)
/* where objects hang around */
#define AGING (data_heap->gen_count-2)
#define HAVE_AGING_P (data_heap->gen_count>2)
/* the oldest generation */
#define TENURED (data_heap->gen_count-1)
#define MIN_GEN_COUNT 1
#define MAX_GEN_COUNT 3
/* new objects are allocated here */
DLLEXPORT F_ZONE nursery;
INLINE bool in_zone(F_ZONE *z, CELL pointer)
{
return pointer >= z->start && pointer < z->end;
}
CELL init_zone(F_ZONE *z, CELL size, CELL base);
void init_card_decks(void);
F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes);
void dealloc_data_heap(F_DATA_HEAP *data_heap);
void clear_cards(CELL from, CELL to);
void clear_decks(CELL from, CELL to);
void clear_allot_markers(CELL from, CELL to);
void reset_generation(CELL i);
void reset_generations(CELL from, CELL to);
void set_data_heap(F_DATA_HEAP *data_heap_);
void init_data_heap(CELL gens,
CELL young_size,
CELL aging_size,
CELL tenured_size,
bool secure_gc_);
/* set up guard pages to check for under/overflow.
size must be a multiple of the page size */
F_SEGMENT *alloc_segment(CELL size);
void dealloc_segment(F_SEGMENT *block);
CELL untagged_object_size(CELL pointer);
CELL unaligned_object_size(CELL pointer);
CELL object_size(CELL pointer);
CELL binary_payload_start(CELL pointer);
void begin_scan(void);
CELL next_object(void);
void primitive_data_room(void);
void primitive_size(void);
void primitive_begin_scan(void);
void primitive_next_object(void);
void primitive_end_scan(void);
/* 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;
INLINE bool in_data_heap_p(CELL ptr)
{
return (ptr >= data_heap->segment->start
&& ptr <= data_heap->segment->end);
}
INLINE void *allot_zone(F_ZONE *z, CELL a)
{
CELL h = z->here;
z->here = h + align8(a);
return (void*)h;
}
CELL find_all_words(void);
/* 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. */
INLINE void do_slots(CELL obj, void (* iter)(CELL *))
{
CELL scan = obj;
CELL payload_start = binary_payload_start(obj);
CELL end = obj + payload_start;
scan += CELLS;
while(scan < end)
{
iter((CELL *)scan);
scan += CELLS;
}
}

56
vm/debug.c
View File

@ -308,34 +308,42 @@ void find_data_references(CELL look_for_)
gc_off = false;
}
CELL look_for;
void find_code_references_step(F_COMPILED *compiled, CELL code_start, CELL literals_start)
/* Dump all code blocks for debugging */
void dump_code_heap(void)
{
CELL scan;
CELL literal_end = literals_start + compiled->literals_length;
CELL size = 0;
for(scan = literals_start; scan < literal_end; scan += CELLS)
F_BLOCK *scan = first_block(&code_heap);
while(scan)
{
CELL code_start = (CELL)(compiled + 1);
CELL literal_start = code_start + compiled->code_length;
CELL obj = get(literal_start);
if(look_for == get(scan))
char *status;
switch(scan->status)
{
print_cell_hex_pad(obj);
print_string(" ");
print_nested_obj(obj,2);
nl();
case B_FREE:
status = "free";
break;
case B_ALLOCATED:
size += object_size(block_to_compiled(scan)->relocation);
status = "allocated";
break;
case B_MARKED:
size += object_size(block_to_compiled(scan)->relocation);
status = "marked";
break;
default:
status = "invalid";
break;
}
}
}
void find_code_references(CELL look_for_)
{
look_for = look_for_;
iterate_code_heap(find_code_references_step);
print_cell_hex((CELL)scan); print_string(" ");
print_cell_hex(scan->size); print_string(" ");
print_string(status); print_string("\n");
scan = next_block(&code_heap,scan);
}
print_cell(size); print_string(" bytes of relocation data\n");
}
void factorbug(void)
@ -464,8 +472,6 @@ void factorbug(void)
CELL addr = read_cell_hex();
print_string("Data heap references:\n");
find_data_references(addr);
print_string("Code heap references:\n");
find_code_references(addr);
nl();
}
else if(strcmp(cmd,"words") == 0)
@ -478,7 +484,7 @@ void factorbug(void)
dpush(addr);
}
else if(strcmp(cmd,"code") == 0)
dump_heap(&code_heap);
dump_code_heap();
else
print_string("unknown command\n");
}

13
vm/image.c
View File

@ -26,6 +26,8 @@ INLINE void load_data_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p)
p->tenured_size,
p->secure_gc);
clear_gc_stats();
F_ZONE *tenured = &data_heap->generations[TENURED];
F_FIXNUM bytes_read = fread((void*)tenured->start,1,h->data_size,file);
@ -311,18 +313,13 @@ void relocate_data()
}
}
void fixup_code_block(F_COMPILED *compiled, CELL code_start, CELL literals_start)
void fixup_code_block(F_CODE_BLOCK *compiled)
{
/* relocate literal table data */
CELL scan;
CELL literal_end = literals_start + compiled->literals_length;
data_fixup(&compiled->relocation);
data_fixup(&compiled->literals);
for(scan = literals_start; scan < literal_end; scan += CELLS)
data_fixup((CELL*)scan);
relocate_code_block(compiled,code_start,literals_start);
relocate_code_block(compiled);
}
void relocate_code()

11
vm/layouts.h
View File

@ -106,10 +106,11 @@ typedef struct
{
char type; /* this is WORD_TYPE or QUOTATION_TYPE */
char last_scan; /* the youngest generation in which this block's literals may live */
char needs_fixup; /* is this a new block that needs full fixup? */
CELL code_length; /* # bytes */
CELL literals_length; /* # bytes */
CELL literals; /* # bytes */
CELL relocation; /* tagged pointer to byte-array or f */
} F_COMPILED;
} F_CODE_BLOCK;
/* Assembly code makes assumptions about the layout of this struct */
typedef struct {
@ -135,9 +136,9 @@ typedef struct {
/* UNTAGGED execution token: jump here to execute word */
XT xt;
/* UNTAGGED compiled code block */
F_COMPILED *code;
F_CODE_BLOCK *code;
/* UNTAGGED profiler stub */
F_COMPILED *profiling;
F_CODE_BLOCK *profiling;
} F_WORD;
/* Assembly code makes assumptions about the layout of this struct */
@ -174,7 +175,7 @@ typedef struct {
/* UNTAGGED */
XT xt;
/* UNTAGGED compiled code block */
F_COMPILED *code;
F_CODE_BLOCK *code;
} F_QUOTATION;
/* Assembly code makes assumptions about the layout of this struct */

63
vm/local_roots.h Normal file
View File

@ -0,0 +1,63 @@
/* If a runtime function needs to call another function which potentially
allocates memory, it must store any local variable references to Factor
objects on the root stack */
/* GC locals: stores addresses of pointers to objects. The GC updates these
pointers, so you can do
REGISTER_ROOT(some_local);
... allocate memory ...
foo(some_local);
...
UNREGISTER_ROOT(some_local); */
F_SEGMENT *gc_locals_region;
CELL gc_locals;
DEFPUSHPOP(gc_local_,gc_locals)
#define REGISTER_ROOT(obj) gc_local_push((CELL)&obj)
#define UNREGISTER_ROOT(obj) \
{ \
if(gc_local_pop() != (CELL)&obj) \
critical_error("Mismatched REGISTER_ROOT/UNREGISTER_ROOT",0); \
}
/* Extra roots: stores pointers to objects in the heap. Requires extra work
(you have to unregister before accessing the object) but more flexible. */
F_SEGMENT *extra_roots_region;
CELL extra_roots;
DEFPUSHPOP(root_,extra_roots)
#define REGISTER_UNTAGGED(obj) root_push(obj ? tag_object(obj) : 0)
#define UNREGISTER_UNTAGGED(obj) obj = untag_object(root_pop())
/* We ignore strings which point outside the data heap, but we might be given
a char* which points inside the data heap, in which case it is a root, for
example if we call unbox_char_string() the result is placed in a byte array */
INLINE bool root_push_alien(const void *ptr)
{
if(in_data_heap_p((CELL)ptr))
{
F_BYTE_ARRAY *objptr = ((F_BYTE_ARRAY *)ptr) - 1;
if(objptr->header == tag_header(BYTE_ARRAY_TYPE))
{
root_push(tag_object(objptr));
return true;
}
}
return false;
}
#define REGISTER_C_STRING(obj) \
bool obj##_root = root_push_alien(obj)
#define UNREGISTER_C_STRING(obj) \
if(obj##_root) obj = alien_offset(root_pop())
#define REGISTER_BIGNUM(obj) if(obj) root_push(tag_bignum(obj))
#define UNREGISTER_BIGNUM(obj) if(obj) obj = (untag_object(root_pop()))

4
vm/master.h
View File

@ -25,6 +25,9 @@
#include "errors.h"
#include "bignumint.h"
#include "bignum.h"
#include "write_barrier.h"
#include "data_heap.h"
#include "local_roots.h"
#include "data_gc.h"
#include "debug.h"
#include "types.h"
@ -32,6 +35,7 @@
#include "float_bits.h"
#include "io.h"
#include "code_gc.h"
#include "code_block.h"
#include "code_heap.h"
#include "image.h"
#include "callstack.h"

2
vm/primitives.c
View File

@ -141,7 +141,7 @@ void *primitives[] = {
primitive_resize_byte_array,
primitive_dll_validp,
primitive_unimplemented,
primitive_gc_reset,
primitive_clear_gc_stats,
primitive_jit_compile,
primitive_load_locals,
};

6
vm/profiler.c
View File

@ -1,7 +1,7 @@
#include "master.h"
/* Allocates memory */
F_COMPILED *compile_profiling_stub(F_WORD *word)
F_CODE_BLOCK *compile_profiling_stub(F_WORD *word)
{
CELL literals = allot_array_1(tag_object(word));
REGISTER_ROOT(literals);
@ -26,7 +26,7 @@ F_COMPILED *compile_profiling_stub(F_WORD *word)
untag_object(code),
NULL, /* no labels */
tag_object(relocation),
untag_object(literals));
literals);
}
/* Allocates memory */
@ -37,7 +37,7 @@ void update_word_xt(F_WORD *word)
if(!word->profiling)
{
REGISTER_UNTAGGED(word);
F_COMPILED *profiling = compile_profiling_stub(word);
F_CODE_BLOCK *profiling = compile_profiling_stub(word);
UNREGISTER_UNTAGGED(word);
word->profiling = profiling;
}

2
vm/profiler.h
View File

@ -1,4 +1,4 @@
bool profiling_p;
void primitive_profiling(void);
F_COMPILED *compile_profiling_stub(F_WORD *word);
F_CODE_BLOCK *compile_profiling_stub(F_WORD *word);
void update_word_xt(F_WORD *word);

8
vm/quotations.c
View File

@ -155,7 +155,7 @@ bool jit_stack_frame_p(F_ARRAY *array)
return false;
}
void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code)
void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code)
{
if(code->type != QUOTATION_TYPE)
critical_error("bad param to set_quot_xt",(CELL)code);
@ -339,17 +339,17 @@ void jit_compile(CELL quot, bool relocate)
GROWABLE_ARRAY_TRIM(literals);
GROWABLE_BYTE_ARRAY_TRIM(relocation);
F_COMPILED *compiled = add_compiled_block(
F_CODE_BLOCK *compiled = add_compiled_block(
QUOTATION_TYPE,
untag_object(code),
NULL,
relocation,
untag_object(literals));
literals);
set_quot_xt(untag_object(quot),compiled);
if(relocate)
iterate_code_heap_step(compiled,relocate_code_block);
relocate_code_block(compiled);
UNREGISTER_ROOT(literals);
UNREGISTER_ROOT(relocation);

2
vm/quotations.h
View File

@ -1,4 +1,4 @@
void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code);
void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code);
void jit_compile(CELL quot, bool relocate);
F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack);
F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset);

8
vm/types.c
View File

@ -62,7 +62,7 @@ F_WORD *allot_word(CELL vocab, CELL name)
UNREGISTER_UNTAGGED(word);
if(profiling_p)
iterate_code_heap_step(word->profiling,relocate_code_block);
relocate_code_block(word->profiling);
return word;
}
@ -79,9 +79,9 @@ void primitive_word(void)
void primitive_word_xt(void)
{
F_WORD *word = untag_word(dpop());
F_COMPILED *code = (profiling_p ? word->profiling : word->code);
dpush(allot_cell((CELL)code + sizeof(F_COMPILED)));
dpush(allot_cell((CELL)code + sizeof(F_COMPILED) + code->code_length));
F_CODE_BLOCK *code = (profiling_p ? word->profiling : word->code);
dpush(allot_cell((CELL)code + sizeof(F_CODE_BLOCK)));
dpush(allot_cell((CELL)code + sizeof(F_CODE_BLOCK) + code->code_length));
}
void primitive_wrapper(void)

66
vm/write_barrier.h Normal file
View File

@ -0,0 +1,66 @@
/* card marking write barrier. a card is a byte storing a mark flag,
and the offset (in cells) of the first object in the card.
the mark flag is set by the write barrier when an object in the
card has a slot written to.
the offset of the first object is set by the allocator. */
/* if CARD_POINTS_TO_NURSERY is set, CARD_POINTS_TO_AGING must also be set. */
#define CARD_POINTS_TO_NURSERY 0x80
#define CARD_POINTS_TO_AGING 0x40
#define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING)
typedef u8 F_CARD;
#define CARD_BITS 8
#define CARD_SIZE (1<<CARD_BITS)
#define ADDR_CARD_MASK (CARD_SIZE-1)
DLLEXPORT CELL cards_offset;
#define ADDR_TO_CARD(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + cards_offset)
#define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)<<CARD_BITS)
typedef u8 F_DECK;
#define DECK_BITS (CARD_BITS + 10)
#define DECK_SIZE (1<<DECK_BITS)
#define ADDR_DECK_MASK (DECK_SIZE-1)
DLLEXPORT CELL decks_offset;
#define ADDR_TO_DECK(a) (F_DECK*)(((CELL)(a) >> DECK_BITS) + decks_offset)
#define DECK_TO_ADDR(c) (CELL*)(((CELL)(c) - decks_offset) << DECK_BITS)
#define DECK_TO_CARD(d) (F_CARD*)((((CELL)(d) - decks_offset) << (DECK_BITS - CARD_BITS)) + cards_offset)
#define ADDR_TO_ALLOT_MARKER(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + allot_markers_offset)
#define CARD_OFFSET(c) (*((c) - (CELL)data_heap->cards + (CELL)data_heap->allot_markers))
#define INVALID_ALLOT_MARKER 0xff
DLLEXPORT CELL allot_markers_offset;
/* the write barrier must be called any time we are potentially storing a
pointer from an older generation to a younger one */
INLINE void write_barrier(CELL address)
{
*ADDR_TO_CARD(address) = CARD_MARK_MASK;
*ADDR_TO_DECK(address) = CARD_MARK_MASK;
}
#define SLOT(obj,slot) (UNTAG(obj) + (slot) * CELLS)
INLINE void set_slot(CELL obj, CELL slot, CELL value)
{
put(SLOT(obj,slot),value);
write_barrier(obj);
}
/* we need to remember the first object allocated in the card */
INLINE void allot_barrier(CELL address)
{
F_CARD *ptr = ADDR_TO_ALLOT_MARKER(address);
if(*ptr == INVALID_ALLOT_MARKER)
*ptr = (address & ADDR_CARD_MASK);
}