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

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

db4
Joe Groff 2009-10-09 10:44:05 -05:00
parent 07aa2620c6 61e1854ca5
commit e466665029
111 changed files with 2490 additions and 1925 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
Makefile
View File

@ -31,6 +31,7 @@ ifdef CONFIG
endif
DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/aging_collector.o \
vm/alien.o \
vm/arrays.o \
vm/bignum.o \
@ -40,29 +41,31 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/code_block.o \
vm/code_heap.o \
vm/contexts.o \
vm/data_gc.o \
vm/data_heap.o \
vm/debug.o \
vm/dispatch.o \
vm/errors.o \
vm/factor.o \
vm/full_collector.o \
vm/gc.o \
vm/heap.o \
vm/image.o \
vm/inline_cache.o \
vm/io.o \
vm/jit.o \
vm/local_roots.o \
vm/math.o \
vm/nursery_collector.o \
vm/old_space.o \
vm/primitives.o \
vm/profiler.o \
vm/quotations.o \
vm/run.o \
vm/strings.o \
vm/to_tenured_collector.o \
vm/tuples.o \
vm/utilities.o \
vm/vm.o \
vm/words.o \
vm/write_barrier.o
vm/words.o
EXE_OBJS = $(PLAF_EXE_OBJS)

154
README.txt
View File

@ -1,154 +0,0 @@
The Factor programming language
-------------------------------
This file covers installation and basic usage of the Factor
implementation. It is not an introduction to the language itself.
* Contents
- Compiling the Factor VM
- Libraries needed for compilation
- Bootstrapping the Factor image
- Running Factor on Unix with X11
- Running Factor on Mac OS X - Cocoa UI
- Running Factor on Mac OS X - X11 UI
- Running Factor on Windows
- Command line usage
- The Factor FAQ
- Source organization
- Community
* Compiling the Factor VM
Factor supports various platforms. For an up-to-date list, see
<http://factorcode.org>.
The Factor VM is written in C++ and uses GNU extensions. When compiling
with GCC 3.x, boost::unordered_map must be installed. On GCC 4.x, Factor
uses std::tr1::unordered_map which is shipped as part of GCC.
Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM.
* Bootstrapping the Factor image
Once you have compiled the Factor VM, you must bootstrap the Factor
system using the image that corresponds to your CPU architecture.
Boot images can be obtained from <http://factorcode.org/images/latest/>.
Once you download the right image, bootstrap Factor with the
following command line:
./factor -i=boot.<cpu>.image
Bootstrap can take a while, depending on your system. When the process
completes, a 'factor.image' file will be generated. Note that this image
is both CPU and OS-specific, so in general cannot be shared between
machines.
* Running Factor on Unix with X11
On Unix, Factor can either run a graphical user interface using X11, or
a terminal listener.
For X11 support, you need recent development libraries for libc,
Pango, X11, and OpenGL. On a Debian-derived Linux distribution
(like Ubuntu), you can use the following line to grab everything:
sudo apt-get install libc6-dev libpango1.0-dev libx11-dev libgl1-mesa-dev
Note that if you are using a proprietary OpenGL driver, you should
probably leave out the last package in the list.
If your DISPLAY environment variable is set, the UI will start
automatically when you run Factor:
./factor
To run an interactive terminal listener:
./factor -run=listener
* Running Factor on Mac OS X - Cocoa UI
On Mac OS X, a Cocoa UI is available in addition to the terminal
listener.
The 'factor' executable runs the terminal listener:
./factor
The 'Factor.app' bundle runs the Cocoa UI. Note that this is not a
self-contained bundle, it must be run from the same directory which
contains factor.image and the library sources.
* Running Factor on Mac OS X - X11 UI
The X11 UI is also available on Mac OS X, however its use is not
recommended since it does not integrate with the host OS.
When compiling Factor, pass the X11=1 parameter:
make X11=1
Then bootstrap with the following switches:
./factor -i=boot.<cpu>.image -ui-backend=x11
Now if $DISPLAY is set, running ./factor will start the UI.
* Running Factor on Windows XP/Vista
The Factor runtime is compiled into two binaries:
factor.com - a Windows console application
factor.exe - a Windows native application, without a console
If you did not download the binary package, you can bootstrap Factor in
the command prompt using the console application:
factor.com -i=boot.<cpu>.image
Once bootstrapped, double-clicking factor.exe or factor.com starts
the Factor UI.
To run the listener in the command prompt:
factor.com -run=listener
* The Factor FAQ
The Factor FAQ is available at the following location:
<http://concatenative.org/wiki/view/Factor/FAQ>
* Command line usage
Factor supports a number of command line switches. To read command line
usage documentation, enter the following in the UI listener:
"command-line" about
* Source organization
The Factor source tree is organized as follows:
build-support/ - scripts used for compiling Factor
vm/ - Factor VM
core/ - Factor core library
basis/ - Factor basis library, compiler, tools
extra/ - more libraries and applications
misc/ - editor modes, icons, etc
unmaintained/ - unmaintained contributions, please help!
* Community
The Factor homepage is located at <http://factorcode.org/>.
Factor developers meet in the #concatenative channel on the
irc.freenode.net server. Drop by if you want to discuss anything related
to Factor or language design in general.
Have fun!
:tabSize=2:indentSize=2:noTabs=true:

8
basis/alien/libraries/libraries-docs.factor
View File

@ -45,10 +45,12 @@ HELP: load-library
HELP: add-library
{ $values { "name" string } { "path" string } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
{ $description "Defines a new logical library named " { $snippet "name" } " located in the file system at " { $snippet "path" } "and the specified ABI." }
{ $notes "Because the entire source file is parsed before top-level forms are executed, " { $link add-library } " cannot be used in the same file as " { $link POSTPONE: FUNCTION: } " definitions from that library. The " { $link add-library } " call will happen too late, after compilation, and the alien calls will not work."
{ $description "Defines a new logical library named " { $snippet "name" } " located in the file system at " { $snippet "path" } " and the specified ABI. The logical library name can then be used by a " { $link POSTPONE: LIBRARY: } " form to specify the logical library for subsequent " { $link POSTPONE: FUNCTION: } " definitions." }
{ $notes "Because the entire source file is parsed before top-level forms are executed, " { $link add-library } " must be placed within a " { $snippet "<< ... >>" } " parse-time evaluation block."
$nl
"Instead, " { $link add-library } " calls must either be placed in different source files from those that use that library, or alternatively, " { $link "syntax-immediate" } " can be used to load the library before compilation." }
"This ensures that if the logical library is later used in the same file, for example by a " { $link POSTPONE: FUNCTION: } " definition. Otherwise, the " { $link add-library } " call will happen too late, after compilation, and the C function calls will not refer to the correct library."
$nl
"For details about parse-time evaluation, see " { $link "syntax-immediate" } "." }
{ $examples "Here is a typical usage of " { $link add-library } ":"
{ $code
"<< \"freetype\" {"

16
basis/alien/parser/parser-tests.factor
View File

@ -1,6 +1,7 @@
! (c)2009 Joe Groff bsd license
USING: accessors alien.c-types alien.parser alien.syntax
tools.test vocabs.parser parser ;
tools.test vocabs.parser parser eval vocabs.parser debugger
continuations ;
IN: alien.parser.tests
TYPEDEF: char char2
@ -28,4 +29,15 @@ SYMBOL: not-c-type
[ "not-c-type" parse-c-type ] [ no-c-type? ] must-fail-with
[ "not-word" parse-c-type ] [ error>> no-word-error? ] must-fail-with
] with-file-vocabs
] with-file-vocabs
! Reported by mnestic
TYPEDEF: int alien-parser-test-int ! reasonably unique name...
[ "OK!" ] [
[
"USE: specialized-arrays SPECIALIZED-ARRAY: alien-parser-test-int" eval( -- )
! after restart, we end up here
"OK!"
] [ :1 ] recover
] unit-test

4
basis/alien/parser/parser.factor
View File

@ -8,7 +8,7 @@ namespaces summary math vocabs.parser ;
IN: alien.parser
: parse-c-type-name ( name -- word )
dup search [ nip ] [ no-word ] if* ;
dup search [ ] [ no-word ] ?if ;
: parse-c-type ( string -- type )
{
@ -17,7 +17,7 @@ IN: alien.parser
{ [ dup search c-type-word? ] [ parse-c-type-name ] }
{ [ "**" ?tail ] [ drop void* ] }
{ [ "*" ?tail ] [ parse-c-type-name resolve-pointer-type ] }
[ parse-c-type-name no-c-type ]
[ dup search [ no-c-type ] [ no-word ] ?if ]
} cond ;
: scan-c-type ( -- c-type )

17
basis/alien/syntax/syntax-docs.factor
View File

@ -1,5 +1,6 @@
IN: alien.syntax
USING: alien alien.c-types alien.parser classes.struct help.markup help.syntax see ;
USING: alien alien.c-types alien.parser alien.libraries
classes.struct help.markup help.syntax see ;
HELP: DLL"
{ $syntax "DLL\" path\"" }
@ -21,7 +22,8 @@ ARTICLE: "syntax-aliens" "Alien object literal syntax"
HELP: LIBRARY:
{ $syntax "LIBRARY: name" }
{ $values { "name" "a logical library name" } }
{ $description "Sets the logical library for consequent " { $link POSTPONE: FUNCTION: } " definitions that follow." } ;
{ $description "Sets the logical library for consequent " { $link POSTPONE: FUNCTION: } ", " { $link POSTPONE: C-GLOBAL: } " and " { $link POSTPONE: CALLBACK: } " definitions, as well as " { $link POSTPONE: &: } " forms." }
{ $notes "Logical library names are defined with the " { $link add-library } " word." } ;
HELP: FUNCTION:
{ $syntax "FUNCTION: return name ( parameters )" }
@ -96,21 +98,26 @@ HELP: CALLBACK:
HELP: &:
{ $syntax "&: symbol" }
{ $values { "symbol" "A C library symbol name" } }
{ $values { "symbol" "A C global variable name" } }
{ $description "Pushes the address of a symbol named " { $snippet "symbol" } " from the current library, set with " { $link POSTPONE: LIBRARY: } "." } ;
HELP: typedef
{ $values { "old" "a string" } { "new" "a string" } }
{ $values { "old" "a C type" } { "new" "a C type" } }
{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
{ $notes "Using this word in the same source file which defines C bindings can cause problems, because words are compiled before top-level forms are run. Use the " { $link POSTPONE: TYPEDEF: } " word instead." } ;
{ POSTPONE: TYPEDEF: typedef } related-words
HELP: c-struct?
{ $values { "c-type" "a C type name" } { "?" "a boolean" } }
{ $values { "c-type" "a C type" } { "?" "a boolean" } }
{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: STRUCT: } "." } ;
HELP: define-function
{ $values { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } }
{ $description "Defines a word named " { $snippet "function" } " in the current vocabulary (see " { $link "vocabularies" } "). The word calls " { $link alien-invoke } " with the specified parameters." }
{ $notes "This word is used to implement the " { $link POSTPONE: FUNCTION: } " parsing word." } ;
HELP: C-GLOBAL:
{ $syntax "C-GLOBAL: type name" }
{ $values { "type" "a C type" } { "name" "a C global variable name" } }
{ $description "Defines a new word named " { $snippet "name" } " which accesses a global variable in the current library, set with " { $link POSTPONE: LIBRARY: } "." } ;

9
basis/alien/syntax/syntax.factor
View File

@ -38,3 +38,12 @@ ERROR: no-such-symbol name library ;
SYNTAX: &:
scan "c-library" get '[ _ _ address-of ] over push-all ;
: global-quot ( type word -- quot )
name>> "c-library" get '[ _ _ address-of 0 ]
swap c-type-getter-boxer append ;
: define-global ( type word -- )
[ nip ] [ global-quot ] 2bi (( -- value )) define-declared ;
SYNTAX: C-GLOBAL: scan-c-type CREATE-WORD define-global ;

7
basis/classes/struct/bit-accessors/bit-accessors-tests.factor Normal file
View File

@ -0,0 +1,7 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: classes.struct.bit-accessors tools.test effects kernel random stack-checker ;
IN: classes.struct.bit-accessors.test
[ t ] [ 20 random 20 random bit-reader infer (( alien -- n )) effect= ] unit-test
[ t ] [ 20 random 20 random bit-writer infer (( n alien -- )) effect= ] unit-test

46
basis/classes/struct/bit-accessors/bit-accessors.factor Normal file
View File

@ -0,0 +1,46 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences math fry locals math.order alien.accessors ;
IN: classes.struct.bit-accessors
! Bitfield accessors are little-endian on all platforms
! Why not? It's unspecified in C
: ones-between ( start end -- n )
[ 2^ 1 - ] bi@ swap bitnot bitand ;
:: manipulate-bits ( offset bits step-quot -- quot shift-amount offset' bits' )
offset 8 /mod :> start-bit :> i
start-bit bits + 8 min :> end-bit
start-bit end-bit ones-between :> mask
end-bit start-bit - :> used-bits
i mask start-bit step-quot call( i mask start-bit -- quot )
used-bits
i 1 + 8 *
bits used-bits - ; inline
:: bit-manipulator ( offset bits
step-quot: ( i mask start-bit -- quot )
combine-quot: ( prev-quot shift-amount next-quot -- quot )
-- quot )
offset bits step-quot manipulate-bits
dup zero? [ 3drop ] [
step-quot combine-quot bit-manipulator
combine-quot call( prev shift next -- quot )
] if ; inline recursive
: bit-reader ( offset bits -- quot: ( alien -- n ) )
[ neg '[ _ alien-unsigned-1 _ bitand _ shift ] ]
[ swap '[ _ _ bi _ shift bitor ] ]
bit-manipulator ;
:: write-bits ( n alien i mask start-bit -- )
n start-bit shift mask bitand
alien i alien-unsigned-1 mask bitnot bitand
bitor alien i set-alien-unsigned-1 ; inline
: bit-writer ( offset bits -- quot: ( n alien -- ) )
[ '[ _ _ _ write-bits ] ]
[ '[ _ [ [ _ neg shift ] dip @ ] 2bi ] ]
bit-manipulator ;

5
basis/classes/struct/prettyprint/prettyprint.factor
View File

@ -23,6 +23,11 @@ IN: classes.struct.prettyprint
[ type>> pprint-c-type ]
[ read-only>> [ \ read-only pprint-word ] when ]
[ initial>> [ \ initial: pprint-word pprint* ] when* ]
[
dup struct-bit-slot-spec?
[ \ bits: pprint-word bits>> pprint* ]
[ drop ] if
]
} cleave block>
\ } pprint-word block> ;

13
basis/classes/struct/struct-tests.factor
View File

@ -352,3 +352,16 @@ STRUCT: struct-that's-a-word { x int } ;
] unit-test
[ f ] [ "a-struct" c-types get key? ] unit-test
STRUCT: bit-field-test
{ a uint bits: 12 }
{ b int bits: 2 }
{ c char } ;
[ S{ bit-field-test f 0 0 0 } ] [ bit-field-test <struct> ] unit-test
[ S{ bit-field-test f 1 -2 3 } ] [ bit-field-test <struct> 1 >>a 2 >>b 3 >>c ] unit-test
[ 4095 ] [ bit-field-test <struct> 8191 >>a a>> ] unit-test
[ 1 ] [ bit-field-test <struct> 1 >>b b>> ] unit-test
[ -2 ] [ bit-field-test <struct> 2 >>b b>> ] unit-test
[ 1 ] [ bit-field-test <struct> 257 >>c c>> ] unit-test
[ 3 ] [ bit-field-test heap-size ] unit-test

90
basis/classes/struct/struct.factor
View File

@ -1,4 +1,4 @@
! (c)Joe Groff bsd license
! (c)Joe Groff, Daniel Ehrenberg bsd license
USING: accessors alien alien.c-types alien.data alien.parser arrays
byte-arrays classes classes.parser classes.tuple classes.tuple.parser
classes.tuple.private combinators combinators.short-circuit
@ -6,7 +6,9 @@ combinators.smart cpu.architecture definitions functors.backend
fry generalizations generic.parser kernel kernel.private lexer
libc locals macros make math math.order parser quotations
sequences slots slots.private specialized-arrays vectors words
summary namespaces assocs vocabs.parser ;
summary namespaces assocs vocabs.parser math.functions
classes.struct.bit-accessors bit-arrays ;
QUALIFIED: math
IN: classes.struct
SPECIALIZED-ARRAY: uchar
@ -22,6 +24,10 @@ TUPLE: struct
TUPLE: struct-slot-spec < slot-spec
type ;
! For a struct-bit-slot-spec, offset is in bits, not bytes
TUPLE: struct-bit-slot-spec < struct-slot-spec
bits signed? ;
PREDICATE: struct-class < tuple-class
superclass \ struct eq? ;
@ -84,14 +90,36 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
: pad-struct-slots ( values class -- values' class )
[ struct-slots [ initial>> ] map over length tail append ] keep ;
: (reader-quot) ( slot -- quot )
: sign-extend ( n bits -- n' )
! formula from:
! http://guru.multimedia.cx/fast-sign-extension/
1 - -1 swap shift [ + ] keep bitxor ; inline
: sign-extender ( signed? bits -- quot )
'[ _ [ _ sign-extend ] when ] ;
GENERIC: (reader-quot) ( slot -- quot )
M: struct-slot-spec (reader-quot)
[ type>> c-type-getter-boxer ]
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
: (writer-quot) ( slot -- quot )
M: struct-bit-slot-spec (reader-quot)
[ [ offset>> ] [ bits>> ] bi bit-reader ]
[ [ signed?>> ] [ bits>> ] bi sign-extender ]
bi compose
[ >c-ptr ] prepose ;
GENERIC: (writer-quot) ( slot -- quot )
M: struct-slot-spec (writer-quot)
[ type>> c-setter ]
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
M: struct-bit-slot-spec (writer-quot)
[ offset>> ] [ bits>> ] bi bit-writer
[ >c-ptr ] prepose ;
: (boxer-quot) ( class -- quot )
'[ _ memory>struct ] ;
@ -186,20 +214,24 @@ M: struct-c-type c-struct? drop t ;
class (unboxer-quot) >>unboxer-quot
class (boxer-quot) >>boxer-quot ;
: align-offset ( offset class -- offset' )
c-type-align align ;
GENERIC: align-offset ( offset class -- offset' )
M: struct-slot-spec align-offset
[ type>> c-type-align 8 * align ] keep
[ [ 8 /i ] dip (>>offset) ] [ type>> heap-size 8 * + ] 2bi ;
M: struct-bit-slot-spec align-offset
[ (>>offset) ] [ bits>> + ] 2bi ;
: struct-offsets ( slots -- size )
0 [
[ type>> align-offset ] keep
[ (>>offset) ] [ type>> heap-size + ] 2bi
] reduce ;
0 [ align-offset ] reduce 8 align 8 /i ;
: union-struct-offsets ( slots -- size )
[ 0 >>offset type>> heap-size ] [ max ] map-reduce ;
1 [ 0 >>offset type>> heap-size max ] reduce ;
: struct-align ( slots -- align )
[ type>> c-type-align ] [ max ] map-reduce ;
[ struct-bit-slot-spec? not ] filter
1 [ type>> c-type-align max ] reduce ;
PRIVATE>
M: struct byte-length class "struct-size" word-prop ; foldable
@ -273,11 +305,43 @@ ERROR: invalid-struct-slot token ;
c-type c-type-boxed-class
dup \ byte-array = [ drop \ c-ptr ] when ;
SYMBOL: bits:
<PRIVATE
ERROR: bad-type-for-bits type ;
:: set-bits ( slot-spec n -- slot-spec )
struct-bit-slot-spec new
n >>bits
slot-spec type>> {
{ int [ t ] }
{ uint [ f ] }
[ bad-type-for-bits ]
} case >>signed?
slot-spec name>> >>name
slot-spec class>> >>class
slot-spec type>> >>type
slot-spec read-only>> >>read-only
slot-spec initial>> >>initial ;
: peel-off-struct-attributes ( slot-spec array -- slot-spec array )
dup empty? [
unclip {
{ initial: [ [ first >>initial ] [ rest ] bi ] }
{ read-only [ [ t >>read-only ] dip ] }
{ bits: [ [ first set-bits ] [ rest ] bi ] }
[ bad-slot-attribute ]
} case
] unless ;
PRIVATE>
: <struct-slot-spec> ( name c-type attributes -- slot-spec )
[ struct-slot-spec new ] 3dip
[ >>name ]
[ [ >>type ] [ struct-slot-class >>class ] bi ]
[ [ dup empty? ] [ peel-off-attributes ] until drop ] tri* ;
[ [ dup empty? ] [ peel-off-struct-attributes ] until drop ] tri* ;
<PRIVATE
: parse-struct-slot ( -- slot )

1
basis/command-line/command-line-docs.factor
View File

@ -47,7 +47,6 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM"
{ { $snippet "-i=" { $emphasis "image" } } { "Specifies the image file to use; see " { $link "images" } } }
{ { $snippet "-datastack=" { $emphasis "n" } } "Data stack size, kilobytes" }
{ { $snippet "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" }
{ { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must equal 1, 2 or 3" }
{ { $snippet "-young=" { $emphasis "n" } } { "Size of youngest generation (0), megabytes" } }
{ { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" }
{ { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" }

24
basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.short-circuit arrays
fry kernel layouts math namespaces sequences cpu.architecture
@ -242,6 +242,28 @@ M: ##shl-imm constant-fold* drop shift ;
[ [ src1>> vreg>constant ] [ src2>> ] [ ] tri constant-fold* ] bi
\ ##load-immediate new-insn ; inline
: unary-constant-fold? ( insn -- ? )
src>> vreg>expr constant-expr? ; inline
GENERIC: unary-constant-fold* ( x insn -- y )
M: ##not unary-constant-fold* drop bitnot ;
M: ##neg unary-constant-fold* drop neg ;
: unary-constant-fold ( insn -- insn' )
[ dst>> ]
[ [ src>> vreg>constant ] [ ] bi unary-constant-fold* ] bi
\ ##load-immediate new-insn ; inline
: maybe-unary-constant-fold ( insn -- insn' )
dup unary-constant-fold? [ unary-constant-fold ] [ drop f ] if ;
M: ##neg rewrite
maybe-unary-constant-fold ;
M: ##not rewrite
maybe-unary-constant-fold ;
: reassociate ( insn op -- insn )
[
{

28
basis/compiler/cfg/value-numbering/value-numbering-tests.factor
View File

@ -983,6 +983,34 @@ cell 8 = [
] unit-test
] when
[
{
T{ ##peek f 0 D 0 }
T{ ##load-immediate f 1 1 }
T{ ##load-immediate f 2 -1 }
}
] [
{
T{ ##peek f 0 D 0 }
T{ ##load-immediate f 1 1 }
T{ ##neg f 2 1 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
T{ ##load-immediate f 1 1 }
T{ ##load-immediate f 2 -2 }
}
] [
{
T{ ##peek f 0 D 0 }
T{ ##load-immediate f 1 1 }
T{ ##not f 2 1 }
} value-numbering-step
] unit-test
! Displaced alien optimizations
3 vreg-counter set-global

16
basis/compiler/codegen/codegen-tests.factor
View File

@ -1,14 +1,14 @@
USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make
compiler.constants ;
compiler.constants words ;
IN: compiler.codegen.tests
[ ] [ [ ] with-fixup drop ] unit-test
[ ] [ [ \ + %call ] with-fixup drop ] unit-test
[ ] [ gensym [ ] with-fixup drop ] unit-test
[ ] [ gensym [ \ + %call ] with-fixup drop ] unit-test
[ ] [ [ <label> dup define-label dup resolve-label %jump-label ] with-fixup drop ] unit-test
[ ] [ [ <label> dup define-label dup resolve-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup drop ] unit-test
[ ] [ gensym [ <label> dup define-label dup resolve-label %jump-label ] with-fixup drop ] unit-test
[ ] [ gensym [ <label> dup define-label dup resolve-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup drop ] unit-test
! Error checking
[ [ <label> dup define-label %jump-label ] with-fixup ] must-fail
[ [ <label> dup define-label B{ 0 0 0 0 } % rc-relative label-fixup ] with-fixup ] must-fail
[ [ <label> dup define-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup ] must-fail
[ gensym [ <label> dup define-label %jump-label ] with-fixup ] must-fail
[ gensym [ <label> dup define-label B{ 0 0 0 0 } % rc-relative label-fixup ] with-fixup ] must-fail
[ gensym [ <label> dup define-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup ] must-fail

27
basis/compiler/codegen/codegen.factor
View File

@ -32,30 +32,21 @@ SYMBOL: calls
#! Compile this word later.
calls get push ;
SYMBOL: compiling-word
: compiled-stack-traces? ( -- ? ) 67 getenv ;
! Mapping _label IDs to label instances
SYMBOL: labels
: init-generator ( word -- )
: init-generator ( -- )
H{ } clone labels set
V{ } clone calls set
compiling-word set
compiled-stack-traces? [ compiling-word get add-literal ] when ;
V{ } clone calls set ;
: generate-insns ( asm -- code )
[
[ word>> init-generator ]
[
instructions>>
[
[ class insn-counts get inc-at ]
[ generate-insn ]
bi
] each
] bi
dup word>> [
init-generator
instructions>> [
[ class insn-counts get inc-at ]
[ generate-insn ]
bi
] each
] with-fixup ;
: generate ( mr -- asm )

17
basis/compiler/codegen/fixup/fixup.factor
View File

@ -4,9 +4,12 @@ USING: arrays byte-arrays byte-vectors generic assocs hashtables
io.binary kernel kernel.private math namespaces make sequences
words quotations strings alien.accessors alien.strings layouts
system combinators math.bitwise math.order
accessors growable compiler.constants ;
accessors growable fry generalizations compiler.constants ;
IN: compiler.codegen.fixup
! Owner
SYMBOL: compiling-word
! Literal table
SYMBOL: literal-table
@ -91,17 +94,19 @@ SYMBOL: relocation-table
[ [ resolve-relative-label ] map concat ]
bi* ;
: init-fixup ( -- )
: init-fixup ( word -- )
compiling-word set
V{ } clone literal-table set
V{ } clone label-table set
BV{ } clone relocation-table set ;
: with-fixup ( quot -- code )
[
: with-fixup ( word quot -- code )
'[
init-fixup
call
@
label-table [ resolve-labels ] change
compiling-word get
literal-table get >array
relocation-table get >byte-array
label-table get
] B{ } make 4array ; inline
] B{ } make 5 narray ; inline

7
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -899,3 +899,10 @@ M: tuple-with-read-only-slot clone
! We want this to inline
[ t ] [ [ void* <c-direct-array> ] { <c-direct-array> } inlined? ] unit-test
[ V{ void*-array } ] [ [ void* <c-direct-array> ] final-classes ] unit-test
[ t ] [ [ alien-unsigned-1 255 bitand ] { bitand fixnum-bitand } inlined? ] unit-test
[ t ] [ [ alien-unsigned-1 255 swap bitand ] { bitand fixnum-bitand } inlined? ] unit-test
[ t ] [ [ { fixnum } declare 256 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test
[ t ] [ [ { fixnum } declare 250 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test
[ f ] [ [ { fixnum } declare 257 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test

33
basis/compiler/tree/propagation/transforms/transforms.factor
View File

@ -45,6 +45,27 @@ IN: compiler.tree.propagation.transforms
: simplify-bitand? ( value -- ? )
value-info literal>> positive-fixnum? ;
: all-ones? ( int -- ? )
dup 1 + bitand zero? ; inline
: redundant-bitand? ( var 111... -- ? )
[ value-info ] bi@ [ interval>> ] [ literal>> ] bi* {
[ nip integer? ]
[ nip all-ones? ]
[ 0 swap [a,b] interval-subset? ]
} 2&& ;
: (zero-bitand?) ( value-info value-info' -- ? )
[ interval>> ] [ literal>> ] bi* {
[ nip integer? ]
[ nip bitnot all-ones? ]
[ 0 swap bitnot [a,b] interval-subset? ]
} 2&& ;
: zero-bitand? ( var1 var2 -- ? )
[ value-info ] bi@
{ [ (zero-bitand?) ] [ swap (zero-bitand?) ] } 2|| ;
{
bitand-integer-integer
bitand-integer-fixnum
@ -53,6 +74,18 @@ IN: compiler.tree.propagation.transforms
} [
[
{
{
[ dup in-d>> first2 zero-bitand? ]
[ drop [ 2drop 0 ] ]
}
{
[ dup in-d>> first2 redundant-bitand? ]
[ drop [ drop ] ]
}
{
[ dup in-d>> first2 swap redundant-bitand? ]
[ drop [ nip ] ]
}
{
[ dup in-d>> first simplify-bitand? ]
[ drop [ >fixnum fixnum-bitand ] ]

2
basis/compression/inflate/inflate-tests.factor
View File

@ -4,7 +4,7 @@ USING: tools.test compression.inflate ;
IN: compression.inflate.tests
[
BV{
B{
1 255 255 255 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 122 121 94 119
239 237 227 88 16 16 10 5 16 17 26 172 3 20 19 245 22 54 55

6
basis/compression/inflate/inflate.factor
View File

@ -3,7 +3,7 @@
USING: accessors arrays assocs byte-vectors combinators
combinators.smart compression.huffman fry hashtables io.binary
kernel literals locals math math.bitwise math.order math.ranges
sequences sorting memoize combinators.short-circuit ;
sequences sorting memoize combinators.short-circuit byte-arrays ;
QUALIFIED-WITH: bitstreams bs
IN: compression.inflate
@ -88,14 +88,14 @@ CONSTANT: dist-table
: nth* ( n seq -- elt )
[ length 1 - swap - ] [ nth ] bi ; inline
:: inflate-lz77 ( seq -- bytes )
:: inflate-lz77 ( seq -- byte-array )
1000 <byte-vector> :> bytes
seq [
dup array?
[ first2 '[ _ 1 - bytes nth* bytes push ] times ]
[ bytes push ] if
] each
bytes ;
bytes >byte-array ;
:: inflate-huffman ( bitstream tables -- bytes )
bitstream tables [ <huffman-decoder> ] with map :> tables

18
basis/core-text/core-text.factor
View File

@ -6,19 +6,19 @@ math.order math.vectors math.rectangles math.functions locals init
namespaces combinators fonts colors cache core-foundation
core-foundation.strings core-foundation.attributed-strings
core-foundation.utilities core-graphics core-graphics.types
core-text.fonts core-text.utilities ;
core-text.fonts ;
IN: core-text
TYPEDEF: void* CTLineRef
C-GLOBAL: kCTFontAttributeName
C-GLOBAL: kCTKernAttributeName
C-GLOBAL: kCTLigatureAttributeName
C-GLOBAL: kCTForegroundColorAttributeName
C-GLOBAL: kCTParagraphStyleAttributeName
C-GLOBAL: kCTUnderlineStyleAttributeName
C-GLOBAL: kCTVerticalFormsAttributeName
C-GLOBAL: kCTGlyphInfoAttributeName
C-GLOBAL: CFStringRef kCTFontAttributeName
C-GLOBAL: CFStringRef kCTKernAttributeName
C-GLOBAL: CFStringRef kCTLigatureAttributeName
C-GLOBAL: CFStringRef kCTForegroundColorAttributeName
C-GLOBAL: CFStringRef kCTParagraphStyleAttributeName
C-GLOBAL: CFStringRef kCTUnderlineStyleAttributeName
C-GLOBAL: CFStringRef kCTVerticalFormsAttributeName
C-GLOBAL: CFStringRef kCTGlyphInfoAttributeName
FUNCTION: CTLineRef CTLineCreateWithAttributedString ( CFAttributedStringRef string ) ;

44
basis/core-text/fonts/fonts.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.syntax assocs core-foundation
core-foundation.dictionaries core-foundation.strings
core-graphics.types core-text.utilities destructors init
core-graphics.types destructors init
kernel math memoize fonts combinators unix.types ;
IN: core-text.fonts
@ -18,28 +18,28 @@ TYPEDEF: void* CTFontDescriptorRef
: kCTFontVerticalTrait ( -- n ) 11 2^ ; inline
: kCTFontUIOptimizedTrait ( -- n ) 12 2^ ; inline
C-GLOBAL: kCTFontSymbolicTrait
C-GLOBAL: kCTFontWeightTrait
C-GLOBAL: kCTFontWidthTrait
C-GLOBAL: kCTFontSlantTrait
C-GLOBAL: CFStringRef kCTFontSymbolicTrait
C-GLOBAL: CFStringRef kCTFontWeightTrait
C-GLOBAL: CFStringRef kCTFontWidthTrait
C-GLOBAL: CFStringRef kCTFontSlantTrait
C-GLOBAL: kCTFontNameAttribute
C-GLOBAL: kCTFontDisplayNameAttribute
C-GLOBAL: kCTFontFamilyNameAttribute
C-GLOBAL: kCTFontStyleNameAttribute
C-GLOBAL: kCTFontTraitsAttribute
C-GLOBAL: kCTFontVariationAttribute
C-GLOBAL: kCTFontSizeAttribute
C-GLOBAL: kCTFontMatrixAttribute
C-GLOBAL: kCTFontCascadeListAttribute
C-GLOBAL: kCTFontCharacterSetAttribute
C-GLOBAL: kCTFontLanguagesAttribute
C-GLOBAL: kCTFontBaselineAdjustAttribute
C-GLOBAL: kCTFontMacintoshEncodingsAttribute
C-GLOBAL: kCTFontFeaturesAttribute
C-GLOBAL: kCTFontFeatureSettingsAttribute
C-GLOBAL: kCTFontFixedAdvanceAttribute
C-GLOBAL: kCTFontOrientationAttribute
C-GLOBAL: CFStringRef kCTFontNameAttribute
C-GLOBAL: CFStringRef kCTFontDisplayNameAttribute
C-GLOBAL: CFStringRef kCTFontFamilyNameAttribute
C-GLOBAL: CFStringRef kCTFontStyleNameAttribute
C-GLOBAL: CFStringRef kCTFontTraitsAttribute
C-GLOBAL: CFStringRef kCTFontVariationAttribute
C-GLOBAL: CFStringRef kCTFontSizeAttribute
C-GLOBAL: CFStringRef kCTFontMatrixAttribute
C-GLOBAL: CFStringRef kCTFontCascadeListAttribute
C-GLOBAL: CFStringRef kCTFontCharacterSetAttribute
C-GLOBAL: CFStringRef kCTFontLanguagesAttribute
C-GLOBAL: CFStringRef kCTFontBaselineAdjustAttribute
C-GLOBAL: CFStringRef kCTFontMacintoshEncodingsAttribute
C-GLOBAL: CFStringRef kCTFontFeaturesAttribute
C-GLOBAL: CFStringRef kCTFontFeatureSettingsAttribute
C-GLOBAL: CFStringRef kCTFontFixedAdvanceAttribute
C-GLOBAL: CFStringRef kCTFontOrientationAttribute
FUNCTION: CTFontDescriptorRef CTFontDescriptorCreateWithAttributes (
CFDictionaryRef attributes

1
basis/core-text/utilities/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

10
basis/core-text/utilities/utilities.factor
View File

@ -1,10 +0,0 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words parser alien alien.c-types kernel fry accessors
alien.libraries ;
IN: core-text.utilities
SYNTAX: C-GLOBAL:
CREATE-WORD
dup name>> '[ _ f dlsym *void* ]
(( -- value )) define-declared ;

4
basis/help/help.factor
View File

@ -120,12 +120,12 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
title-style get [
[ ($title) ] [ ($navigation) ] bi
] with-nesting
] with-style nl ;
] with-style ;
: print-topic ( topic -- )
>link
last-element off
[ $title ] [ nl article-content print-content nl ] bi ;
[ $title ] [ ($blank-line) article-content print-content ] bi ;
SYMBOL: help-hook

26
basis/help/markup/markup.factor
View File

@ -5,7 +5,8 @@ combinators definitions definitions.icons effects fry generic
hashtables help.stylesheet help.topics io io.styles kernel make
math namespaces parser present prettyprint
prettyprint.stylesheet quotations see sequences sets slots
sorting splitting strings vectors vocabs vocabs.loader words ;
sorting splitting strings vectors vocabs vocabs.loader words
words.symbol ;
FROM: prettyprint.sections => with-pprint ;
IN: help.markup
@ -26,6 +27,9 @@ SYMBOL: blank-line
last-blank-line? not
and [ nl ] when ;
: ($blank-line) ( -- )
nl nl blank-line last-element set ;
: ($span) ( quot -- )
last-block? [ nl ] when
span last-element set
@ -44,7 +48,6 @@ M: f print-element drop ;
: with-default-style ( quot -- )
default-span-style get [
last-element off
default-block-style get swap with-nesting
] with-style ; inline
@ -179,12 +182,23 @@ GENERIC: link-long-text ( topic -- )
M: topic link-long-text
[ article-title ] keep write-link ;
GENERIC: link-effect? ( word -- ? )
M: parsing-word link-effect? drop f ;
M: symbol link-effect? drop f ;
M: word link-effect? drop t ;
: $effect ( effect -- )
effect>string stack-effect-style get format ;
M: word link-long-text
dup presented associate [
[ article-name link-style get format ]
[ drop bl ]
[ stack-effect effect>string stack-effect-style get format ]
tri
[
dup link-effect? [
bl stack-effect $effect
] [ drop ] if
] bi
] with-nesting ;
: >topic ( obj -- topic ) dup topic? [ >link ] unless ;
@ -220,7 +234,7 @@ PRIVATE>
] ($subsection) ;
: $subsections ( children -- )
[ $subsection* ] each nl nl blank-line last-element set ;
[ $subsection* ] each ($blank-line) ;
: $subsection ( element -- )
first $subsection* ;

34
basis/html/streams/streams.factor
View File

@ -10,22 +10,10 @@ GENERIC: url-of ( object -- url )
M: object url-of drop f ;
TUPLE: html-writer data last-div ;
TUPLE: html-writer data ;
<PRIVATE
! stream-nl after with-nesting or tabular-output is
! ignored, so that HTML stream output looks like
! UI pane output
: last-div? ( stream -- ? )
[ f ] change-last-div drop ;
: not-a-div ( stream -- stream )
f >>last-div ; inline
: a-div ( stream -- stream )
t >>last-div ; inline
: new-html-writer ( class -- html-writer )
new V{ } clone >>data ; inline
@ -107,7 +95,7 @@ MACRO: make-css ( pairs -- str )
TUPLE: html-span-stream < html-sub-stream ;
M: html-span-stream dispose
end-sub-stream not-a-div format-html-span ;
end-sub-stream format-html-span ;
: border-css, ( border -- )
"border: 1px solid #" % hex-color, "; " % ;
@ -124,10 +112,8 @@ CONSTANT: pre-css "white-space: pre; font-family: monospace;"
{ border-color border-css, }
{ inset padding-css, }
} make-css
] [
wrap-margin swap at
[ pre-css append ] unless
] bi ;
] [ wrap-margin swap at [ pre-css append ] unless ] bi
"display: inline-block;" append ;
: div-tag ( xml style -- xml' )
div-css-style
@ -139,7 +125,7 @@ CONSTANT: pre-css "white-space: pre; font-family: monospace;"
TUPLE: html-block-stream < html-sub-stream ;
M: html-block-stream dispose ( quot style stream -- )
end-sub-stream a-div format-html-div ;
end-sub-stream format-html-div ;
: border-spacing-css, ( pair -- )
"padding: " % first2 max 2 /i # "px; " % ;
@ -157,16 +143,16 @@ PRIVATE>
M: html-writer stream-flush drop ;
M: html-writer stream-write1
not-a-div [ 1string ] emit-html ;
[ 1string ] emit-html ;
M: html-writer stream-write
not-a-div [ ] emit-html ;
[ ] emit-html ;
M: html-writer stream-format
format-html-span ;
M: html-writer stream-nl
dup last-div? [ drop ] [ [ [XML <br/> XML] ] emit-html ] if ;
[ [XML <br/> XML] ] emit-html ;
M: html-writer make-span-stream
html-span-stream new-html-sub-stream ;
@ -178,12 +164,12 @@ M: html-writer make-cell-stream
html-sub-stream new-html-sub-stream ;
M: html-writer stream-write-table
a-div [
[
table-style swap [
[ data>> [XML <td valign="top" style=<->><-></td> XML] ] with map
[XML <tr><-></tr> XML]
] with map
[XML <table><-></table> XML]
[XML <table style="display: inline-table;"><-></table> XML]
] emit-html ;
M: html-writer dispose drop ;

149
basis/images/png/png.factor
View File

@ -3,7 +3,9 @@
USING: accessors arrays checksums checksums.crc32 combinators
compression.inflate fry grouping images images.loader io
io.binary io.encodings.ascii io.encodings.string kernel locals
math math.bitwise math.ranges sequences sorting ;
math math.bitwise math.ranges sequences sorting assocs
math.functions math.order ;
QUALIFIED-WITH: bitstreams bs
IN: images.png
SINGLETON: png-image
@ -57,13 +59,16 @@ ERROR: bad-checksum ;
4 read = [ bad-checksum ] unless
4 cut-slice
[ ascii decode >>type ] [ B{ } like >>data ] bi*
[ over chunks>> push ]
[ over chunks>> push ]
[ type>> ] bi "IEND" =
[ read-png-chunks ] unless ;
: find-chunk ( loading-png string -- chunk )
[ chunks>> ] dip '[ type>> _ = ] find nip ;
: find-chunks ( loading-png string -- chunk )
[ chunks>> ] dip '[ type>> _ = ] filter ;
: parse-ihdr-chunk ( loading-png -- loading-png )
dup "IHDR" find-chunk data>> {
[ [ 0 4 ] dip subseq be> >>width ]
@ -76,30 +81,31 @@ ERROR: bad-checksum ;
} cleave ;
: find-compressed-bytes ( loading-png -- bytes )
chunks>> [ type>> "IDAT" = ] filter
[ data>> ] map concat ;
"IDAT" find-chunks [ data>> ] map concat ;
ERROR: unknown-color-type n ;
ERROR: unimplemented-color-type image ;
: inflate-data ( loading-png -- bytes )
find-compressed-bytes zlib-inflate ;
find-compressed-bytes zlib-inflate ;
: scale-bit-depth ( loading-png -- n ) bit-depth>> 8 / ; inline
: png-bytes-per-pixel ( loading-png -- n )
dup color-type>> {
{ truecolor [ scale-bit-depth 3 * ] }
{ truecolor-alpha [ scale-bit-depth 4 * ] }
: png-components-per-pixel ( loading-png -- n )
color-type>> {
{ greyscale [ 1 ] }
{ truecolor [ 3 ] }
{ greyscale-alpha [ 2 ] }
{ indexed-color [ 1 ] }
{ truecolor-alpha [ 4 ] }
[ unknown-color-type ]
} case ; inline
: png-group-width ( loading-png -- n )
! 1 + is for the filter type, 1 byte preceding each line
[ png-bytes-per-pixel ] [ width>> ] bi * 1 + ;
[ [ png-components-per-pixel ] [ bit-depth>> ] bi * ]
[ width>> ] bi * 1 + ;
:: paeth ( a b c -- p )
a b + c - { a b c } [ [ - abs ] keep 2array ] with map
:: paeth ( a b c -- p )
a b + c - { a b c } [ [ - abs ] keep 2array ] with map
sort-keys first second ;
:: png-unfilter-line ( width prev curr filter -- curr' )
@ -114,10 +120,10 @@ ERROR: unimplemented-color-type image ;
{ filter-up [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
{ filter-average [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
{ filter-paeth [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
} case
} case
curr width tail ;
:: reverse-png-filter ( n lines -- byte-array )
:: reverse-png-filter ( lines n -- byte-array )
lines dup first length 0 <array> prefix
[ n 1 - 0 <array> prepend ] map
2 clump [
@ -130,48 +136,82 @@ ERROR: unimplemented-color-type image ;
ERROR: unimplemented-interlace ;
: reverse-interlace ( byte-array loading-png -- byte-array )
: reverse-interlace ( byte-array loading-png -- bitstream )
{
{ interlace-none [ ] }
{ interlace-adam7 [ unimplemented-interlace ] }
[ unimplemented-interlace ]
} case ;
} case bs:<msb0-bit-reader> ;
: png-image-bytes ( loading-png -- byte-array )
[ png-bytes-per-pixel ]
[ [ inflate-data ] [ interlace-method>> ] bi reverse-interlace ]
[ png-group-width ] tri group reverse-png-filter ;
: uncompress-bytes ( loading-png -- bitstream )
[ inflate-data ] [ interlace-method>> ] bi reverse-interlace ;
ERROR: bad-filter n ;
:: raw-bytes ( loading-png -- array )
loading-png uncompress-bytes :> bs
loading-png width>> :> width
loading-png height>> :> height
loading-png png-components-per-pixel :> #components
loading-png bit-depth>> :> bit-depth
bit-depth :> depth!
#components width * :> count!
! Only read up to 8 bits at a time
bit-depth 16 = [
8 depth!
count 2 * count!
] when
height [
8 bs bs:read dup 0 4 between? [ bad-filter ] unless
count [ depth bs bs:read ] replicate swap prefix
8 bs bs:align
] replicate
#components bit-depth 16 = [ 2 * ] when reverse-png-filter ;
ERROR: unknown-component-type n ;
: png-component ( loading-png -- obj )
bit-depth>> {
{ 1 [ ubyte-components ] }
{ 2 [ ubyte-components ] }
{ 4 [ ubyte-components ] }
{ 8 [ ubyte-components ] }
{ 16 [ ushort-components ] }
[ unknown-component-type ]
} case ;
: loading-png>image ( loading-png -- image )
[ image new ] dip {
[ png-image-bytes >>bitmap ]
[ [ width>> ] [ height>> ] bi 2array >>dim ]
[ png-component >>component-type ]
} cleave ;
: scale-factor ( n -- n' )
{
{ 1 [ 255 ] }
{ 2 [ 127 ] }
{ 4 [ 17 ] }
} case ;
: decode-greyscale ( loading-png -- image )
unimplemented-color-type ;
: scale-greyscale ( byte-array loading-png -- byte-array' )
bit-depth>> {
{ 8 [ ] }
{ 16 [ 2 group [ swap ] assoc-map B{ } concat-as ] }
[ scale-factor '[ _ * ] B{ } map-as ]
} case ;
: decode-truecolor ( loading-png -- image )
loading-png>image RGB >>component-order ;
: decode-indexed-color ( loading-png -- image )
unimplemented-color-type ;
: decode-greyscale ( loading-png -- byte-array )
[ raw-bytes ] keep scale-greyscale ;
: decode-greyscale-alpha ( loading-png -- image )
unimplemented-color-type ;
: decode-greyscale-alpha ( loading-image -- byte-array )
[ raw-bytes ] [ bit-depth>> ] bi 16 = [
4 group [ first4 [ swap ] 2dip 4array ] map B{ } concat-as
] when ;
: decode-truecolor-alpha ( loading-png -- image )
loading-png>image RGBA >>component-order ;
ERROR: invalid-PLTE array ;
: verify-PLTE ( seq -- seq )
dup length 3 divisor? [ invalid-PLTE ] unless ;
: decode-indexed-color ( loading-image -- byte-array )
[ raw-bytes ] keep "PLTE" find-chunk data>> verify-PLTE
3 group '[ _ nth ] { } map-as B{ } concat-as ; inline
ERROR: invalid-color-type/bit-depth loading-png ;
@ -194,16 +234,33 @@ ERROR: invalid-color-type/bit-depth loading-png ;
: validate-truecolor-alpha ( loading-png -- loading-png )
{ 8 16 } validate-bit-depth ;
: png>image ( loading-png -- image )
: loading-png>bitmap ( loading-png -- bytes component-order )
dup color-type>> {
{ greyscale [ validate-greyscale decode-greyscale ] }
{ truecolor [ validate-truecolor decode-truecolor ] }
{ indexed-color [ validate-indexed-color decode-indexed-color ] }
{ greyscale-alpha [ validate-greyscale-alpha decode-greyscale-alpha ] }
{ truecolor-alpha [ validate-truecolor-alpha decode-truecolor-alpha ] }
{ greyscale [
validate-greyscale decode-greyscale L
] }
{ truecolor [
validate-truecolor raw-bytes RGB
] }
{ indexed-color [
validate-indexed-color decode-indexed-color RGB
] }
{ greyscale-alpha [
validate-greyscale-alpha decode-greyscale-alpha LA
] }
{ truecolor-alpha [
validate-truecolor-alpha raw-bytes RGBA
] }
[ unknown-color-type ]
} case ;
: loading-png>image ( loading-png -- image )
[ image new ] dip {
[ loading-png>bitmap [ >>bitmap ] [ >>component-order ] bi* ]
[ [ width>> ] [ height>> ] bi 2array >>dim ]
[ png-component >>component-type ]
} cleave ;
: load-png ( stream -- loading-png )
[
<loading-png>
@ -213,4 +270,4 @@ ERROR: invalid-color-type/bit-depth loading-png ;
] with-input-stream ;
M: png-image stream>image
drop load-png png>image ;
drop load-png loading-png>image ;

55
basis/io/mmap/mmap-docs.factor
View File

@ -1,5 +1,6 @@
USING: help.markup help.syntax alien math continuations
destructors specialized-arrays ;
USING: alien alien.c-types continuations destructors
help.markup help.syntax kernel math quotations
specialized-arrays ;
IN: io.mmap
HELP: mapped-file
@ -33,9 +34,42 @@ HELP: close-mapped-file
{ $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link dispose } " instead." }
{ $errors "Throws an error if a memory mapping could not be established." } ;
HELP: <mapped-file-reader>
{ $values { "path" "a pathname string" } { "mmap" mapped-file } }
{ $contract "Opens a file for reading only and maps its contents into memory. The length is permitted to exceed the length of the file on disk, in which case the remaining space is padded with zero bytes." }
{ $notes "You must call " { $link dispose } " when you are finished working with the returned object, to reclaim resources. The " { $link with-mapped-file } " provides an abstraction which can close the mapped file for you." }
{ $errors "Throws an error if a memory mapping could not be established." } ;
HELP: with-mapped-array
{ $values
{ "path" "a pathname string" } { "c-type" c-type } { "quot" quotation }
}
{ $description "Memory-maps a file for reading and writing as a mapped-array of the given c-type. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
{ $examples
{ $unchecked-example
"USING: alien.c-types io.mmap prettyprint specialized-arrays ;"
"SPECIALIZED-ARRAY: uint"
""""resource:license.txt" uint [
[ . ] each
] with-mapped-array"""
""
}
}
{ $errors "Throws an error if a memory mapping could not be established." } ;
HELP: with-mapped-array-reader
{ $values
{ "path" "a pathname string" } { "c-type" c-type } { "quot" quotation }
}
{ $description "Memory-maps a file for reading as a mapped-array of the given c-type. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
{ $errors "Throws an error if a memory mapping could not be established." } ;
ARTICLE: "io.mmap.arrays" "Working with memory-mapped data"
"The " { $link <mapped-file> } " word returns an instance of " { $link mapped-file } ", which doesn't directly support the sequence protocol. Instead, it needs to be wrapped in a specialized array of the appropriate C type:"
{ $subsections <mapped-array> }
"Additionally, files may be opened with two combinators which take a c-type as input:"
{ $subsections with-mapped-array }
{ $subsections with-mapped-array-reader }
"The appropriate specialized array type must first be generated with " { $link POSTPONE: SPECIALIZED-ARRAY: } "."
$nl
"Data can also be read and written from the " { $link mapped-file } " by applying low-level alien words to the " { $slot "address" } " slot. This approach is not recommended, though, since in most cases the compiler will generate efficient code for specialized array usage. See " { $link "reading-writing-memory" } " for a description of low-level memory access primitives." ;
@ -46,10 +80,10 @@ ARTICLE: "io.mmap.examples" "Memory-mapped file examples"
"USING: alien.c-types grouping io.mmap sequences" "specialized-arrays ;"
"SPECIALIZED-ARRAY: char"
""
"\"mydata.dat\" ["
" char <mapped-array> 4 <sliced-groups>"
"\"mydata.dat\" char ["
" 4 <sliced-groups>"
" [ reverse-here ] change-each"
"] with-mapped-file"
"] with-mapped-array"
}
"Normalize a file containing packed quadrupes of floats:"
{ $code
@ -57,17 +91,20 @@ ARTICLE: "io.mmap.examples" "Memory-mapped file examples"
"SIMD: float"
"SPECIALIZED-ARRAY: float-4"
""
"\"mydata.dat\" ["
" float-4 <mapped-array>"
"\"mydata.dat\" float-4 ["
" [ normalize ] change-each"
"] with-mapped-file"
"] with-mapped-array"
} ;
ARTICLE: "io.mmap" "Memory-mapped files"
"The " { $vocab-link "io.mmap" } " vocabulary implements support for memory-mapped files."
{ $subsections <mapped-file> }
"Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } ". A utility combinator which wraps the above:"
"Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } "." $nl
"Utility combinators which wrap the above:"
{ $subsections with-mapped-file }
{ $subsections with-mapped-file-reader }
{ $subsections with-mapped-array }
{ $subsections with-mapped-array-reader }
"Instances of " { $link mapped-file } " don't support any interesting operations in themselves. There are two facilities for accessing their contents:"
{ $subsections
"io.mmap.arrays"

21
basis/io/mmap/mmap-tests.factor
View File

@ -1,7 +1,7 @@
USING: io io.mmap io.files io.files.temp io.directories kernel
tools.test continuations sequences io.encodings.ascii accessors
math compiler.tree.debugger alien.data alien.c-types
sequences.private ;
USING: alien.c-types alien.data compiler.tree.debugger
continuations io.directories io.encodings.ascii io.files
io.files.temp io.mmap kernel math sequences sequences.private
specialized-arrays specialized-arrays.instances.uint tools.test ;
IN: io.mmap.tests
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
@ -10,6 +10,19 @@ IN: io.mmap.tests
[ 5 ] [ "mmap-test-file.txt" temp-file [ char <mapped-array> length ] with-mapped-file ] unit-test
[ 5 ] [ "mmap-test-file.txt" temp-file [ char <mapped-array> length ] with-mapped-file-reader ] unit-test
[ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test
SPECIALIZED-ARRAY: uint
[ t ] [
"mmap-test-file.txt" temp-file uint [ sum ] with-mapped-array
integer?
] unit-test
[ t ] [
"mmap-test-file.txt" temp-file uint [ sum ] with-mapped-array-reader
integer?
] unit-test
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors

19
basis/io/mmap/mmap.factor
View File

@ -8,13 +8,13 @@ IN: io.mmap
TUPLE: mapped-file < disposable address handle length ;
HOOK: (mapped-file-reader) os ( path length -- address handle )
HOOK: (mapped-file-r/w) os ( path length -- address handle )
ERROR: bad-mmap-size n ;
<PRIVATE
HOOK: (mapped-file-reader) os ( path length -- address handle )
HOOK: (mapped-file-r/w) os ( path length -- address handle )
: prepare-mapped-file ( path quot -- mapped-file path' length )
[
[ normalize-path ] [ file-info size>> ] bi
@ -45,6 +45,19 @@ M: mapped-file dispose* ( mmap -- ) close-mapped-file ;
: with-mapped-file-reader ( path quot -- )
[ <mapped-file-reader> ] dip with-disposal ; inline
<PRIVATE
: (with-mapped-array) ( c-type quot -- )
[ [ <mapped-array> ] curry ] dip compose with-disposal ; inline
PRIVATE>
: with-mapped-array ( path c-type quot -- )
[ <mapped-file> ] 2dip (with-mapped-array) ; inline
: with-mapped-array-reader ( path c-type quot -- )
[ <mapped-file-reader> ] 2dip (with-mapped-array) ; inline
{
{ [ os unix? ] [ "io.mmap.unix" require ] }
{ [ os winnt? ] [ "io.mmap.windows" require ] }

4
basis/io/mmap/unix/unix.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien io io.files kernel math math.bitwise system unix
io.backend.unix io.ports io.mmap destructors locals accessors ;
USING: accessors destructors io.backend.unix io.mmap
io.mmap.private kernel locals math.bitwise system unix ;
IN: io.mmap.unix
:: mmap-open ( path length prot flags open-mode -- alien fd )

2
basis/io/mmap/windows/windows.factor
View File

@ -1,6 +1,6 @@
USING: alien alien.c-types arrays destructors generic io.mmap
io.ports io.backend.windows io.files.windows io.backend.windows.privileges
kernel libc math math.bitwise namespaces quotations sequences
io.mmap.private kernel libc math math.bitwise namespaces quotations sequences
windows windows.advapi32 windows.kernel32 io.backend system
accessors locals windows.errors ;
IN: io.mmap.windows

6
basis/tools/deploy/backend/backend.factor
View File

@ -53,9 +53,7 @@ CONSTANT: theme-path "basis/ui/gadgets/theme/"
] { } make ;
: staging-image-name ( profile -- name )
"staging."
swap strip-word-names? [ "strip" suffix ] when
"-" join ".image" 3append temp-file ;
"-" join "staging." ".image" surround temp-file ;
DEFER: ?make-staging-image
@ -72,7 +70,6 @@ DEFER: ?make-staging-image
] if
"-output-image=" over staging-image-name append ,
"-include=" swap " " join append ,
strip-word-names? [ "-no-stack-traces" , ] when
"-no-user-init" ,
] { } make ;
@ -102,7 +99,6 @@ DEFER: ?make-staging-image
[ "-deploy-vocab=" prepend , ]
[ make-deploy-config "-deploy-config=" prepend , ] bi
"-output-image=" prepend ,
strip-word-names? [ "-no-stack-traces" , ] when
] { } make
] bind ;

2
basis/tools/deploy/deploy-tests.factor
View File

@ -11,7 +11,7 @@ IN: tools.deploy.tests
[ t ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test
[ "staging.math-threads-compiler-ui-strip.image" ] [
[ "staging.math-threads-compiler-ui.image" ] [
"hello-ui" deploy-config
[ bootstrap-profile staging-image-name file-name ] bind
] unit-test

2
basis/tools/deploy/shaker/shaker.factor
View File

@ -208,7 +208,7 @@ IN: tools.deploy.shaker
[ word? ] instances
deploy-word-props? get [ 2dup strip-word-props ] unless
deploy-word-defs? get [ dup strip-word-defs ] unless
strip-word-names? [ dup strip-word-names ] when
strip-word-names? [ dup strip-word-names strip-stack-traces ] when
2drop ;
: compiler-classes ( -- seq )

8
basis/tools/disassembler/disassembler.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays byte-arrays combinators
destructors generic io kernel libc math sequences system tr
vocabs.loader words alien.data ;
USING: alien alien.data arrays byte-arrays compiler.units destructors
io kernel libc math quotations sequences stack-checker system tr
vocabs.loader words ;
IN: tools.disassembler
GENERIC: disassemble ( obj -- )
@ -24,6 +24,8 @@ M: pair disassemble first2 disassemble* [ tabs>spaces print ] each ;
M: word disassemble word-xt 2array disassemble ;
M: quotation disassemble [ dup infer define-temp ] with-compilation-unit disassemble ;
cpu x86?
"tools.disassembler.udis"
"tools.disassembler.gdb" ?

8
core/alien/alien-docs.factor
View File

@ -192,6 +192,13 @@ ARTICLE: "alien-callback" "Calling Factor from C"
{ $subsections "alien-callback-gc" }
{ $see-also "byte-arrays-gc" } ;
ARTICLE: "alien-globals" "Accessing C global variables"
"The " { $vocab-link "alien.syntax" } " vocabulary defines two parsing words for accessing the value of a global variable, and get the address of a global variable, respectively."
{ $subsections
POSTPONE: C-GLOBAL:
POSTPONE: &:
} ;
ARTICLE: "dll.private" "DLL handles"
"DLL handles are a built-in class of objects which represent loaded native libraries. DLL handles are instances of the " { $link dll } " class, and have a literal syntax used for debugging prinouts; see " { $link "syntax-aliens" } "."
$nl
@ -281,6 +288,7 @@ $nl
"alien-callback"
"c-data"
"classes.struct"
"alien-globals"
"dll.private"
"embedding"
} ;

1
core/bootstrap/primitives.factor
View File

@ -522,6 +522,7 @@ tuple
{ "optimized?" "words" (( word -- ? )) }
{ "quot-compiled?" "quotations" (( quot -- ? )) }
{ "vm-ptr" "vm" (( -- ptr )) }
{ "strip-stack-traces" "kernel.private" (( -- )) }
} [ [ first3 ] dip swap make-primitive ] each-index
! Bump build number

5
extra/curses/ffi/ffi.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.syntax combinators kernel system
alien.libraries classes.struct ;
alien.c-types alien.libraries classes.struct unix.types ;
IN: curses.ffi
<< "curses" {
@ -74,8 +74,7 @@ STRUCT: c-window
LIBRARY: curses
: stdscr ( -- alien )
"stdscr" "curses" library dll>> dlsym ;
C-GLOBAL: void* stdscr
FUNCTION: WINDOW* initscr ( ) ;
FUNCTION: int endwin ( ) ;

13
extra/project-euler/023/023.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.ranges project-euler.common sequences sets sorting ;
USING: kernel math math.ranges project-euler.common sequences sets sorting assocs fry ;
IN: project-euler.023
! http://projecteuler.net/index.php?section=problems&id=23
@ -42,10 +42,9 @@ IN: project-euler.023
[1,b] [ abundant? ] filter ;
: possible-sums ( seq -- seq )
dup { } -rot [
dupd [ + ] curry map
rot append prune swap rest
] each drop natural-sort ;
H{ } clone
[ dupd '[ _ [ + _ conjoin ] with each ] each ]
keep keys ;
PRIVATE>
@ -53,9 +52,7 @@ PRIVATE>
source-023
20161 abundants-upto possible-sums diff sum ;
! TODO: solution is still too slow, although it takes under 1 minute
! [ euler023 ] time
! 52780 ms run / 3839 ms GC
! 2.15542 seconds
SOLUTION: euler023

4
extra/project-euler/051/051-tests.factor Normal file
View File

@ -0,0 +1,4 @@
USING: project-euler.051 tools.test ;
IN: project-euler.051.tests
[ 121313 ] [ euler051 ] unit-test

84
extra/project-euler/051/051.factor Normal file
View File

@ -0,0 +1,84 @@
! Copyright (C) 2009 Jon Harper.
! See http://factorcode.org/license.txt for BSD license.
! http://projecteuler.net/index.php?section=problems&id=1
! DESCRIPTION
! -----------
! By replacing the first digit of *3, it turns out that
! six of the nine possible values:
! 13, 23, 43, 53, 73, and 83, are all prime.
! By replacing the third and fourth digits of 56**3 with the same digit,
! this 5-digit number is the first example having seven primes among
! the ten generated numbers, yielding the family:
! 56003, 56113, 56333, 56443, 56663, 56773, and 56993.
! Consequently 56003, being the first member of this family,
! is the smallest prime with this property.
!
! Find the smallest prime which, by replacing part of the number
! (not necessarily adjacent digits) with the same digit,
! is part of an eight prime value family.
! SOLUTION
! --------
! for each prime number, count the families it belongs to. When one reaches count of 8, stop, and get the smallest number by replacing * with ones.
USING: assocs kernel math math.combinatorics math.functions
math.parser math.primes namespaces project-euler.common
sequences sets strings grouping math.ranges arrays fry math.order ;
IN: project-euler.051
<PRIVATE
SYMBOL: family-count
SYMBOL: large-families
: reset-globals ( -- )
H{ } clone family-count set
H{ } clone large-families set ;
: digits-positions ( str -- positions )
H{ } clone [ '[ swap _ push-at ] each-index ] keep ;
: *-if-index ( char combination index -- char )
member? [ drop CHAR: * ] when ;
: replace-positions-with-* ( str positions -- str )
[ *-if-index ] curry map-index ;
: all-positions-combinations ( seq -- combinations )
dup length [1,b] [ all-combinations ] with map concat ;
: families ( stra -- seq )
dup digits-positions values
[ all-positions-combinations [ replace-positions-with-* ] with map ] with map concat ;
: save-family ( family -- )
dup family-count get at 8 = [ large-families get conjoin ] [ drop ] if ;
: increment-family ( family -- )
family-count get inc-at ;
: handle-family ( family -- )
[ increment-family ] [ save-family ] bi ;
! Test all primes that have length n
: n-digits-primes ( n -- primes )
[ 1 - 10^ ] [ 10^ ] bi primes-between ;
: test-n-digits-primes ( n -- seq )
reset-globals
n-digits-primes
[ number>string families [ handle-family ] each ] each
large-families get ;
: fill-*-with-ones ( str -- str )
[ dup CHAR: * = [ drop CHAR: 1 ] when ] map ;
! recursively test all primes by length until we find an answer
: (euler051) ( i -- answer )
dup test-n-digits-primes
dup assoc-size 0 >
[ nip values [ fill-*-with-ones string>number ] [ min ] map-reduce ]
[ drop 1 + (euler051) ] if ;
PRIVATE>
: euler051 ( -- answer )
2 (euler051) ;
SOLUTION: euler051

1
extra/project-euler/051/authors.txt Normal file
View File

@ -0,0 +1 @@
Jon Harper

4
extra/project-euler/255/255-tests.factor Normal file
View File

@ -0,0 +1,4 @@
USING: project-euler.255 tools.test ;
IN: project-euler.255.tests
[ 4.4474011180 ] [ euler255 ] unit-test

93
extra/project-euler/255/255.factor Normal file
View File

@ -0,0 +1,93 @@
! Copyright (C) 2009 Jon Harper.
! See http://factorcode.org/license.txt for BSD license.
USING: project-euler.common math kernel sequences math.functions math.ranges prettyprint io threads math.parser locals arrays namespaces ;
IN: project-euler.255
! http://projecteuler.net/index.php?section=problems&id=255
! DESCRIPTION
! -----------
! We define the rounded-square-root of a positive integer n as the square root of n rounded to the nearest integer.
!
! The following procedure (essentially Heron's method adapted to integer arithmetic) finds the rounded-square-root of n:
!
! Let d be the number of digits of the number n.
! If d is odd, set x_(0) = 2×10^((d-1)⁄2).
! If d is even, set x_(0) = 7×10^((d-2)⁄2).
! Repeat:
!
! until x_(k+1) = x_(k).
!
! As an example, let us find the rounded-square-root of n = 4321.
! n has 4 digits, so x_(0) = 7×10^((4-2)⁄2) = 70.
!
! Since x_(2) = x_(1), we stop here.
! So, after just two iterations, we have found that the rounded-square-root of 4321 is 66 (the actual square root is 65.7343137…).
!
! The number of iterations required when using this method is surprisingly low.
! For example, we can find the rounded-square-root of a 5-digit integer (10,000 ≤ n ≤ 99,999) with an average of 3.2102888889 iterations (the average value was rounded to 10 decimal places).
!
! Using the procedure described above, what is the average number of iterations required to find the rounded-square-root of a 14-digit number (10^(13) ≤ n < 10^(14))?
! Give your answer rounded to 10 decimal places.
!
! Note: The symbols ⌊x⌋ and ⌈x⌉ represent the floor function and ceiling function respectively.
!
<PRIVATE
: round-to-10-decimals ( a -- b ) 1.0e10 * round 1.0e10 / ;
! same as produce, but outputs the sum instead of the sequence of results
: produce-sum ( id pred quot -- sum )
[ 0 ] 2dip [ [ dip swap ] curry ] [ [ dip + ] curry ] bi* while ; inline
: x0 ( i -- x0 )
number-length dup even?
[ 2 - 2 / 10 swap ^ 7 * ]
[ 1 - 2 / 10 swap ^ 2 * ] if ;
: ⌈a/b⌉ ( a b -- ⌈a/b⌉ )
[ 1 - + ] keep /i ;
: xk+1 ( n xk -- xk+1 )
[ ⌈a/b⌉ ] keep + 2 /i ;
: next-multiple ( a multiple -- next )
[ [ 1 - ] dip /i 1 + ] keep * ;
DEFER: iteration#
! Gives the number of iterations when xk+1 has the same value for all a<=i<=n
:: (iteration#) ( i xi a b -- # )
a xi xk+1 dup xi =
[ drop i b a - 1 + * ]
[ i 1 + swap a b iteration# ] if ;
! Gives the number of iterations in the general case by breaking into intervals
! in which xk+1 is the same.
:: iteration# ( i xi a b -- # )
a
a xi next-multiple
[ dup b < ]
[
! set up the values for the next iteration
[ nip [ 1 + ] [ xi + ] bi ] 2keep
! set up the arguments for (iteration#)
[ i xi ] 2dip (iteration#)
] produce-sum
! deal with the last numbers
[ drop b [ i xi ] 2dip (iteration#) ] dip
+ ;
: 10^ ( a -- 10^a ) 10 swap ^ ; inline
: (euler255) ( a b -- answer )
[ 10^ ] bi@ 1 -
[ [ drop x0 1 swap ] 2keep iteration# ] 2keep
swap - 1 + /f ;
PRIVATE>
: euler255 ( -- answer )
13 14 (euler255) round-to-10-decimals ;
SOLUTION: euler255

1
extra/project-euler/255/authors.txt Normal file
View File

@ -0,0 +1 @@
Jon Harper

22
extra/project-euler/project-euler.factor
View File

@ -14,17 +14,17 @@ USING: definitions io io.files io.pathnames kernel math math.parser
project-euler.037 project-euler.038 project-euler.039 project-euler.040
project-euler.041 project-euler.042 project-euler.043 project-euler.044
project-euler.045 project-euler.046 project-euler.047 project-euler.048
project-euler.049 project-euler.052 project-euler.053 project-euler.054
project-euler.055 project-euler.056 project-euler.057 project-euler.058
project-euler.059 project-euler.063 project-euler.067 project-euler.069
project-euler.071 project-euler.072 project-euler.073 project-euler.074
project-euler.075 project-euler.076 project-euler.079 project-euler.085
project-euler.092 project-euler.097 project-euler.099 project-euler.100
project-euler.102 project-euler.112 project-euler.116 project-euler.117
project-euler.124 project-euler.134 project-euler.148 project-euler.150
project-euler.151 project-euler.164 project-euler.169 project-euler.173
project-euler.175 project-euler.186 project-euler.190 project-euler.203
project-euler.215 ;
project-euler.049 project-euler.051 project-euler.052 project-euler.053
project-euler.054 project-euler.055 project-euler.056 project-euler.057
project-euler.058 project-euler.059 project-euler.063 project-euler.067
project-euler.069 project-euler.071 project-euler.072 project-euler.073
project-euler.074 project-euler.075 project-euler.076 project-euler.079
project-euler.085 project-euler.092 project-euler.097 project-euler.099
project-euler.100 project-euler.102 project-euler.112 project-euler.116
project-euler.117 project-euler.124 project-euler.134 project-euler.148
project-euler.150 project-euler.151 project-euler.164 project-euler.169
project-euler.173 project-euler.175 project-euler.186 project-euler.190
project-euler.203 project-euler.215 ;
IN: project-euler
<PRIVATE

1
extra/s3/authors.txt Normal file
View File

@ -0,0 +1 @@
Chris Double

149
extra/s3/s3.factor Normal file
View File

@ -0,0 +1,149 @@
! Copyright (C) 2009 Chris Double. All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license.
USING:
accessors
assocs
base64
calendar
calendar.format
checksums.hmac
checksums.sha
combinators
http
http.client
kernel
make
math.order
namespaces
sequences
sorting
strings
xml
xml.traversal
;
IN: s3
SYMBOL: key-id
SYMBOL: secret-key
TUPLE: s3-request path mime-type date method headers bucket data ;
: hashtable>headers ( hashtable -- seq )
[
[ swap % ":" % % "\n" % ] "" make
] { } assoc>map [ <=> ] sort ;
: signature ( s3-request -- string )
[
{
[ method>> % "\n" % "\n" % ]
[ mime-type>> % "\n" % ]
[ date>> timestamp>rfc822 % "\n" % ]
[ headers>> [ hashtable>headers [ % ] each ] when* ]
[ bucket>> [ "/" % % ] when* ]
[ path>> % ]
} cleave
] "" make ;
: sign ( s3-request -- string )
[
"AWS " %
key-id get %
":" %
signature secret-key get sha1 hmac-bytes >base64 %
] "" make ;
: s3-url ( s3-request -- string )
[
"http://" %
dup bucket>> [ % "." % ] when*
"s3.amazonaws.com" %
path>> %
] "" make ;
: <s3-request> ( bucket path headers method -- request )
s3-request new
swap >>method
swap >>headers
swap >>path
swap >>bucket
now >>date ;
: sign-http-request ( s3-request http-request -- request )
over date>> timestamp>rfc822 "Date" set-header
swap sign "Authorization" set-header ;
: s3-get ( bucket path headers -- request data )
"GET" <s3-request> dup s3-url <get-request>
sign-http-request http-request ;
: s3-put ( data bucket path headers -- request data )
"PUT" <s3-request> dup s3-url swapd <put-request>
sign-http-request http-request ;
TUPLE: bucket name date ;
: (buckets) ( xml -- seq )
"Buckets" tag-named
"Bucket" tags-named [
[ "Name" tag-named children>string ]
[ "CreationDate" tag-named children>string ] bi bucket boa
] map ;
: buckets ( -- seq )
f "/" H{ } clone s3-get nip >string string>xml (buckets) ;
: bucket-url ( bucket -- string )
[ "http://" % % ".s3.amazonaws.com/" % ] "" make ;
TUPLE: key name last-modified size ;
: (keys) ( xml -- seq )
"Contents" tags-named [
[ "Key" tag-named children>string ]
[ "LastModified" tag-named children>string ]
[ "Size" tag-named children>string ]
tri key boa
] map ;
: keys ( bucket -- seq )
"/" H{ } clone s3-get
nip >string string>xml (keys) ;
: object-get ( bucket key -- response data )
s3-request new
swap "/" prepend >>path
swap >>bucket
s3-url http-get ;
: create-bucket ( bucket -- )
"" swap "/" H{ } clone "PUT" <s3-request>
"application/octet-stream" >>mime-type
dup s3-url swapd <put-request>
0 "content-length" set-header
sign-http-request
http-request 2drop ;
: delete-bucket ( bucket -- )
"/" H{ } clone "DELETE" <s3-request>
dup s3-url <delete-request> sign-http-request http-request 2drop ;
: put-object ( object type bucket key headers -- )
[ "/" prepend ] dip "PUT" <s3-request>
over >>mime-type
[ <post-data> swap >>data ] dip
dup s3-url swapd <put-request>
dup header>> pick headers>> assoc-union >>header
sign-http-request
http-request 2drop ;
! "testbucket" create-bucket
! "testbucket" delete-bucket
! buckets
! "testbucket" keys
! "hello world" binary encode "text/plain" "testbucket" "hello.txt"
! H{ { "x-amz-acl" "public-read" } } put-object
! "hello.txt" <pathname> "text/plain" "testbucket" "hello.txt"
! H{ { "x-amz-acl" "public-read" } } put-object
! "testbucket" "hello.txt" object-get
! Need to write docs...

1
extra/s3/summary.txt Normal file
View File

@ -0,0 +1 @@
Amazon S3 Wrapper

1
extra/s3/tags.txt Normal file
View File

@ -0,0 +1 @@
web

2
extra/websites/concatenative/concatenative.factor
View File

@ -97,7 +97,7 @@ SYMBOL: dh-file
<login-config> <factor-boilerplate> test-db <alloy> "concatenative.org" add-responder
<pastebin> <login-config> <factor-boilerplate> test-db <alloy> "paste.factorcode.org" add-responder
<planet> <login-config> <factor-boilerplate> test-db <alloy> "planet.factorcode.org" add-responder
home "docs" append-path <help-webapp> test-db <alloy> "docs.factorcode.org" add-responder
home "docs" append-path <help-webapp> "docs.factorcode.org" add-responder
home "cgi" append-path <gitweb> "gitweb.factorcode.org" add-responder
<mason-app> "builds.factorcode.org" add-responder
main-responder set-global ;

72
readme.html Normal file
View File

@ -0,0 +1,72 @@
<html>
<head><title>Factor</title></head>
<body>
<h1>The Factor programming language</h1>
<h2>Getting started</h2>
<p>If you are reading this README file, you either downloaded a binary
package, or checked out Factor sources from the GIT repository.</p>
<ul>
<li><a href="http://concatenative.org/wiki/view/Factor/Getting%20started">Getting started</a></li>
<li><a href="http://concatenative.org/wiki/view/Factor/Requirements">System requirements</a></li>
<li><a href="http://concatenative.org/wiki/view/Factor/Building%20Factor">Building Factor from source</a> (don't do this if you're using a binary package)</li>
</ul>
<p>To run Factor:<p>
<ul>
<li>Windows: Double-click <code>factor.exe</code>, or run
<code>.\factor.com</code> in a command prompt</li>
<li>Mac OS X: Double-click <code>Factor.app</code>code> or run <code>open
Factor.app</code> in a Terminal</li>
<li>Unix: Run <code>./factor</code>code> in a shell</li>
</ul>
<h2>Documentation</h2>
<p>The Factor environment includes extensive reference documentation and
a short "cookbook" to help you get started. The best way to read the
documentation is in the UI; press F1 in the UI listener to open the help
browser tool. You can also <a href="http://docs.factorcode.org">browse
the documentation online</a>.</p>
<h2>Command line usage</h2>
<p>Factor supports a number of command line switches. To read command line
usage documentation, enter the following in the UI listener:</p>
<pre>"command-line" about</pre>
<h2>Source organization</h2>
The Factor source tree is organized as follows:
<li><code>build-support/</code> - scripts used for compiling Factor (not
present in binary packages)</li>
<li><code>vm/</code> - Factor VM source code (not present in binary
packages)</li>
<li><code>core/</code> - Factor core library</li>
<li><code>basis/</code> - Factor basis library, compiler, tools</li>
<li><code>extra/</code> - more libraries and applications</li>
<li><code>misc/</code> - editor modes, icons, etc</li>
<li><code>unmaintained/</code> - unmaintained contributions, please
help!</li>
<h2>Community</h2>
<p>Factor developers meet in the <code>#concatenative</code> channel on <a
href="http://freenode.net">irc.freenode.net</a>. Drop by if you want to discuss
anything related to Factor or language design in general.</p>
<ul>
<li><a href="http://factorcode.org">Factor homepage</a></li>
<li><a href="http://concatenative.org">Concatenative languages wiki</a></li>
</ul>
<p>Have fun!</p>
</body>
</html>

30
vm/aging_collector.cpp Normal file
View File

@ -0,0 +1,30 @@
#include "master.hpp"
namespace factor
{
aging_collector::aging_collector(factor_vm *myvm_) :
copying_collector<aging_space,aging_policy>
(myvm_,myvm_->data->aging,aging_policy(myvm_)) {}
void factor_vm::collect_aging()
{
std::swap(data->aging,data->aging_semispace);
reset_generation(data->aging);
aging_collector collector(this);
collector.trace_roots();
collector.trace_contexts();
collector.trace_cards(data->tenured,
card_points_to_aging,
complex_unmarker(card_mark_mask,card_points_to_nursery));
collector.trace_code_heap_roots(&code->points_to_aging);
collector.cheneys_algorithm();
update_dirty_code_blocks(&code->points_to_aging);
nursery.here = nursery.start;
code->points_to_nursery.clear();
}
}

23
vm/aging_collector.hpp Normal file
View File

@ -0,0 +1,23 @@
namespace factor
{
struct aging_policy {
factor_vm *myvm;
zone *aging, *tenured;
aging_policy(factor_vm *myvm_) :
myvm(myvm_),
aging(myvm->data->aging),
tenured(myvm->data->tenured) {}
bool should_copy_p(object *untagged)
{
return !(aging->contains_p(untagged) || tenured->contains_p(untagged));
}
};
struct aging_collector : copying_collector<aging_space,aging_policy> {
aging_collector(factor_vm *myvm_);
};
}

12
vm/aging_space.hpp Normal file
View File

@ -0,0 +1,12 @@
namespace factor
{
struct aging_space : old_space {
aging_space(cell size, cell start) : old_space(size,start) {}
bool is_nursery_p() { return false; }
bool is_aging_p() { return true; }
bool is_tenured_p() { return false; }
};
}

8
vm/alien.cpp
View File

@ -14,7 +14,7 @@ char *factor_vm::pinned_alien_offset(cell obj)
alien *ptr = untag<alien>(obj);
if(ptr->expired != F)
general_error(ERROR_EXPIRED,obj,F,NULL);
return pinned_alien_offset(ptr->alien) + ptr->displacement;
return pinned_alien_offset(ptr->base) + ptr->displacement;
}
case F_TYPE:
return NULL;
@ -34,10 +34,10 @@ cell factor_vm::allot_alien(cell delegate_, cell displacement)
{
tagged<alien> delegate_alien = delegate.as<alien>();
displacement += delegate_alien->displacement;
new_alien->alien = delegate_alien->alien;
new_alien->base = delegate_alien->base;
}
else
new_alien->alien = delegate.value();
new_alien->base = delegate.value();
new_alien->displacement = displacement;
new_alien->expired = F;
@ -172,7 +172,7 @@ char *factor_vm::alien_offset(cell obj)
alien *ptr = untag<alien>(obj);
if(ptr->expired != F)
general_error(ERROR_EXPIRED,obj,F,NULL);
return alien_offset(ptr->alien) + ptr->displacement;
return alien_offset(ptr->base) + ptr->displacement;
}
case F_TYPE:
return NULL;

13
vm/callstack.cpp
View File

@ -81,21 +81,12 @@ code_block *factor_vm::frame_code(stack_frame *frame)
cell factor_vm::frame_type(stack_frame *frame)
{
return frame_code(frame)->type;
return frame_code(frame)->type();
}
cell factor_vm::frame_executing(stack_frame *frame)
{
code_block *compiled = frame_code(frame);
if(compiled->literals == F || !stack_traces_p())
return F;
else
{
array *literals = untag<array>(compiled->literals);
cell executing = array_nth(literals,0);
check_data_pointer((object *)executing);
return executing;
}
return frame_code(frame)->owner;
}
stack_frame *factor_vm::frame_successor(stack_frame *frame)

129
vm/code_block.cpp
View File

@ -20,7 +20,7 @@ cell factor_vm::relocation_offset_of(relocation_entry r)
void factor_vm::flush_icache_for(code_block *block)
{
flush_icache((cell)block,block->size);
flush_icache((cell)block,block->size());
}
int factor_vm::number_of_parameters(relocation_type type)
@ -194,9 +194,9 @@ template<typename Iterator> void factor_vm::iterate_relocations(code_block *comp
{
byte_array *relocation = untag<byte_array>(compiled->relocation);
cell index = stack_traces_p() ? 1 : 0;
cell index = 0;
cell length = array_capacity(relocation) / sizeof(relocation_entry);
for(cell i = 0; i < length; i++)
{
relocation_entry rel = relocation->data<relocation_entry>()[i];
@ -290,7 +290,7 @@ struct literal_references_updater {
/* Update pointers to literals from compiled code. */
void factor_vm::update_literal_references(code_block *compiled)
{
if(!compiled->needs_fixup)
if(!code->needs_fixup_p(compiled))
{
literal_references_updater updater(this);
iterate_relocations(compiled,updater);
@ -298,26 +298,6 @@ void factor_vm::update_literal_references(code_block *compiled)
}
}
/* Copy all literals referenced from a code block to newspace. Only for
aging and nursery collections */
void factor_vm::trace_literal_references(code_block *compiled)
{
if(current_gc->collecting_gen >= compiled->last_scan)
{
if(current_gc->collecting_accumulation_gen_p())
compiled->last_scan = current_gc->collecting_gen;
else
compiled->last_scan = current_gc->collecting_gen + 1;
trace_handle(&compiled->literals);
trace_handle(&compiled->relocation);
/* once we finish tracing, re-visit this code block and update
literals */
current_gc->dirty_code_blocks.insert(compiled);
}
}
/* Compute an address to store at a relocation */
void factor_vm::relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled)
{
@ -351,7 +331,7 @@ to update references to other words, without worrying about literals
or dlsyms. */
void factor_vm::update_word_references(code_block *compiled)
{
if(compiled->needs_fixup)
if(code->needs_fixup_p(compiled))
relocate_code_block(compiled);
/* update_word_references() is always applied to every block in
the code heap. Since it resets all call sites to point to
@ -360,8 +340,8 @@ void factor_vm::update_word_references(code_block *compiled)
are referenced after this is done. So instead of polluting
the code heap with dead PICs that will be freed on the next
GC, we add them to the free list immediately. */
else if(compiled->type == PIC_TYPE)
code->heap_free(compiled);
else if(compiled->type() == PIC_TYPE)
code->code_heap_free(compiled);
else
{
word_references_updater updater(this);
@ -377,74 +357,6 @@ void factor_vm::check_code_address(cell address)
#endif
}
/* 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 factor_vm::mark_code_block(code_block *compiled)
{
check_code_address((cell)compiled);
code->mark_block(compiled);
trace_handle(&compiled->literals);
trace_handle(&compiled->relocation);
}
struct stack_frame_marker {
factor_vm *myvm;
explicit stack_frame_marker(factor_vm *myvm_) : myvm(myvm_) {}
void operator()(stack_frame *frame)
{
myvm->mark_code_block(myvm->frame_code(frame));
}
};
/* Mark code blocks executing in currently active stack frames. */
void factor_vm::mark_active_blocks(context *stacks)
{
if(current_gc->collecting_tenured_p())
{
cell top = (cell)stacks->callstack_top;
cell bottom = (cell)stacks->callstack_bottom;
stack_frame_marker marker(this);
iterate_callstack(top,bottom,marker);
}
}
void factor_vm::mark_object_code_block(object *object)
{
switch(object->h.hi_tag())
{
case WORD_TYPE:
{
word *w = (word *)object;
if(w->code)
mark_code_block(w->code);
if(w->profiling)
mark_code_block(w->profiling);
break;
}
case QUOTATION_TYPE:
{
quotation *q = (quotation *)object;
if(q->code)
mark_code_block(q->code);
break;
}
case CALLSTACK_TYPE:
{
callstack *stack = (callstack *)object;
stack_frame_marker marker(this);
iterate_callstack_object(stack,marker);
break;
}
}
}
struct code_block_relocator {
factor_vm *myvm;
@ -460,18 +372,12 @@ struct code_block_relocator {
/* Perform all fixups on a code block */
void factor_vm::relocate_code_block(code_block *compiled)
{
compiled->last_scan = data->nursery();
compiled->needs_fixup = false;
code->needs_fixup.erase(compiled);
code_block_relocator relocator(this);
iterate_relocations(compiled,relocator);
flush_icache_for(compiled);
}
void relocate_code_block(code_block *compiled, factor_vm *myvm)
{
return myvm->relocate_code_block(compiled);
}
/* Fixup labels. This is done at compile time, not image load time */
void factor_vm::fixup_labels(array *labels, code_block *compiled)
{
@ -491,15 +397,15 @@ void factor_vm::fixup_labels(array *labels, code_block *compiled)
}
/* Might GC */
code_block *factor_vm::allot_code_block(cell size)
code_block *factor_vm::allot_code_block(cell size, cell type)
{
heap_block *block = code->heap_allot(size + sizeof(code_block));
heap_block *block = code->heap_allot(size + sizeof(code_block),type);
/* If allocation failed, do a code GC */
if(block == NULL)
{
gc();
block = code->heap_allot(size + sizeof(code_block));
block = code->heap_allot(size + sizeof(code_block),type);
/* Insufficient room even after code GC, give up */
if(block == NULL)
@ -519,20 +425,18 @@ code_block *factor_vm::allot_code_block(cell size)
}
/* Might GC */
code_block *factor_vm::add_code_block(cell type, cell code_, cell labels_, cell relocation_, cell literals_)
code_block *factor_vm::add_code_block(cell type, cell code_, cell labels_, cell owner_, cell relocation_, cell literals_)
{
gc_root<byte_array> code(code_,this);
gc_root<object> labels(labels_,this);
gc_root<object> owner(owner_,this);
gc_root<byte_array> relocation(relocation_,this);
gc_root<array> literals(literals_,this);
cell code_length = align8(array_capacity(code.untagged()));
code_block *compiled = allot_code_block(code_length);
code_block *compiled = allot_code_block(code_length,type);
/* compiled header */
compiled->type = type;
compiled->last_scan = data->nursery();
compiled->needs_fixup = true;
compiled->owner = owner.value();
/* slight space optimization */
if(relocation.type() == BYTE_ARRAY_TYPE && array_capacity(relocation.untagged()) == 0)
@ -554,7 +458,8 @@ code_block *factor_vm::add_code_block(cell type, cell code_, cell labels_, cell
/* next time we do a minor GC, we have to scan the code heap for
literals */
last_code_heap_scan = data->nursery();
this->code->write_barrier(compiled);
this->code->needs_fixup.insert(compiled);
return compiled;
}

77
vm/code_heap.cpp
View File

@ -3,10 +3,31 @@
namespace factor
{
code_heap::code_heap(bool secure_gc, cell size) : heap(secure_gc,size) {}
void code_heap::write_barrier(code_block *compiled)
{
points_to_nursery.insert(compiled);
points_to_aging.insert(compiled);
}
bool code_heap::needs_fixup_p(code_block *compiled)
{
return needs_fixup.count(compiled) > 0;
}
void code_heap::code_heap_free(code_block *compiled)
{
points_to_nursery.erase(compiled);
points_to_aging.erase(compiled);
needs_fixup.erase(compiled);
heap_free(compiled);
}
/* Allocate a code heap during startup */
void factor_vm::init_code_heap(cell size)
{
code = new heap(this,size);
code = new code_heap(secure_gc,size);
}
bool factor_vm::in_code_heap_p(cell ptr)
@ -28,31 +49,16 @@ void factor_vm::jit_compile_word(cell word_, cell def_, bool relocate)
if(word->pic_tail_def != F) jit_compile(word->pic_tail_def,relocate);
}
struct literal_reference_tracer {
struct word_updater {
factor_vm *myvm;
explicit literal_reference_tracer(factor_vm *myvm_) : myvm(myvm_) {}
explicit word_updater(factor_vm *myvm_) : myvm(myvm_) {}
void operator()(code_block *compiled)
{
myvm->trace_literal_references(compiled);
myvm->update_word_references(compiled);
}
};
/* Copy literals referenced from all code blocks to newspace. Only for
aging and nursery collections */
void factor_vm::trace_code_heap_roots()
{
code_heap_scans++;
literal_reference_tracer tracer(this);
iterate_code_heap(tracer);
if(current_gc->collecting_accumulation_gen_p())
last_code_heap_scan = current_gc->collecting_gen;
else
last_code_heap_scan = current_gc->collecting_gen + 1;
}
/* Update pointers to words referenced from all code blocks. Only after
defining a new word. */
void factor_vm::update_code_heap_words()
@ -86,15 +92,17 @@ void factor_vm::primitive_modify_code_heap()
case ARRAY_TYPE:
{
array *compiled_data = data.as<array>().untagged();
cell literals = array_nth(compiled_data,0);
cell relocation = array_nth(compiled_data,1);
cell labels = array_nth(compiled_data,2);
cell code = array_nth(compiled_data,3);
cell owner = array_nth(compiled_data,0);
cell literals = array_nth(compiled_data,1);
cell relocation = array_nth(compiled_data,2);
cell labels = array_nth(compiled_data,3);
cell code = array_nth(compiled_data,4);
code_block *compiled = add_code_block(
WORD_TYPE,
code,
labels,
owner,
relocation,
literals);
@ -125,7 +133,7 @@ void factor_vm::primitive_code_room()
code_block *factor_vm::forward_xt(code_block *compiled)
{
return (code_block *)forwarding[compiled];
return (code_block *)code->forwarding[compiled];
}
struct xt_forwarder {
@ -221,16 +229,16 @@ critical here */
void factor_vm::compact_code_heap()
{
/* Free all unreachable code blocks, don't trace contexts */
garbage_collection(data->tenured(),false,false,0);
garbage_collection(tenured_gen,false,false,0);
/* Figure out where the code heap blocks are going to end up */
cell size = code->compute_heap_forwarding(forwarding);
cell size = code->compute_heap_forwarding();
/* Update word and quotation code pointers */
forward_object_xts();
/* Actually perform the compaction */
code->compact_heap(forwarding);
code->compact_heap();
/* Update word and quotation XTs */
fixup_object_xts();
@ -240,4 +248,19 @@ void factor_vm::compact_code_heap()
code->build_free_list(size);
}
struct stack_trace_stripper {
explicit stack_trace_stripper() {}
void operator()(code_block *compiled)
{
compiled->owner = F;
}
};
void factor_vm::primitive_strip_stack_traces()
{
stack_trace_stripper stripper;
iterate_code_heap(stripper);
}
}

25
vm/code_heap.hpp
View File

@ -1,21 +1,20 @@
namespace factor
{
inline void factor_vm::check_code_pointer(cell ptr)
{
#ifdef FACTOR_DEBUG
assert(in_code_heap_p(ptr));
#endif
}
struct code_heap : heap {
/* Set of blocks which need full relocation. */
std::set<code_block *> needs_fixup;
struct word_updater {
factor_vm *myvm;
/* Code blocks which may reference objects in the nursery */
std::set<code_block *> points_to_nursery;
explicit word_updater(factor_vm *myvm_) : myvm(myvm_) {}
void operator()(code_block *compiled)
{
myvm->update_word_references(compiled);
}
/* Code blocks which may reference objects in aging space or the nursery */
std::set<code_block *> points_to_aging;
explicit code_heap(bool secure_gc, cell size);
void write_barrier(code_block *compiled);
bool needs_fixup_p(code_block *compiled);
void code_heap_free(code_block *compiled);
};
}

155
vm/collector.hpp Normal file
View File

@ -0,0 +1,155 @@
namespace factor
{
template<typename TargetGeneration, typename Policy> struct collector {
factor_vm *myvm;
data_heap *data;
code_heap *code;
gc_state *current_gc;
TargetGeneration *target;
Policy policy;
explicit collector(factor_vm *myvm_, TargetGeneration *target_, Policy policy_) :
myvm(myvm_),
data(myvm_->data),
code(myvm_->code),
current_gc(myvm_->current_gc),
target(target_),
policy(policy_) {}
object *resolve_forwarding(object *untagged)
{
myvm->check_data_pointer(untagged);
/* is there another forwarding pointer? */
while(untagged->h.forwarding_pointer_p())
untagged = untagged->h.forwarding_pointer();
/* we've found the destination */
untagged->h.check_header();
return untagged;
}
bool trace_handle(cell *handle)
{
cell pointer = *handle;
if(immediate_p(pointer)) return false;
object *untagged = myvm->untag<object>(pointer);
if(!policy.should_copy_p(untagged))
return false;
object *forwarding = resolve_forwarding(untagged);
if(forwarding == untagged)
untagged = promote_object(untagged);
else if(policy.should_copy_p(forwarding))
untagged = promote_object(forwarding);
else
untagged = forwarding;
*handle = RETAG(untagged,TAG(pointer));
return true;
}
bool trace_slots(object *ptr)
{
cell *slot = (cell *)ptr;
cell *end = (cell *)((cell)ptr + myvm->binary_payload_start(ptr));
bool copied = false;
if(slot != end)
{
slot++;
for(; slot < end; slot++) copied |= trace_handle(slot);
}
return copied;
}
object *promote_object(object *untagged)
{
cell size = myvm->untagged_object_size(untagged);
object *newpointer = target->allot(size);
/* XXX not exception-safe */
if(!newpointer) longjmp(current_gc->gc_unwind,1);
memcpy(newpointer,untagged,size);
untagged->h.forward_to(newpointer);
generation_statistics *stats = &myvm->gc_stats.generations[current_gc->collecting_gen];
stats->object_count++;
stats->bytes_copied += size;
return newpointer;
}
void trace_stack_elements(segment *region, cell *top)
{
for(cell *ptr = (cell *)region->start; ptr <= top; ptr++)
trace_handle(ptr);
}
void trace_registered_locals()
{
std::vector<cell>::const_iterator iter = myvm->gc_locals.begin();
std::vector<cell>::const_iterator end = myvm->gc_locals.end();
for(; iter < end; iter++)
trace_handle((cell *)(*iter));
}
void trace_registered_bignums()
{
std::vector<cell>::const_iterator iter = myvm->gc_bignums.begin();
std::vector<cell>::const_iterator end = myvm->gc_bignums.end();
for(; iter < end; iter++)
{
cell *handle = (cell *)(*iter);
if(*handle)
{
*handle |= BIGNUM_TYPE;
trace_handle(handle);
*handle &= ~BIGNUM_TYPE;
}
}
}
/* Copy roots over at the start of GC, namely various constants, stacks,
the user environment and extra roots registered by local_roots.hpp */
void trace_roots()
{
trace_handle(&myvm->T);
trace_handle(&myvm->bignum_zero);
trace_handle(&myvm->bignum_pos_one);
trace_handle(&myvm->bignum_neg_one);
trace_registered_locals();
trace_registered_bignums();
for(int i = 0; i < USER_ENV; i++) trace_handle(&myvm->userenv[i]);
}
void trace_contexts()
{
context *stacks = myvm->stack_chain;
while(stacks)
{
trace_stack_elements(stacks->datastack_region,(cell *)stacks->datastack);
trace_stack_elements(stacks->retainstack_region,(cell *)stacks->retainstack);
trace_handle(&stacks->catchstack_save);
trace_handle(&stacks->current_callback_save);
stacks = stacks->next;
}
}
};
}

4
vm/contexts.cpp
View File

@ -44,8 +44,8 @@ context *factor_vm::alloc_context()
else
{
new_context = new context;
new_context->datastack_region = new segment(this,ds_size);
new_context->retainstack_region = new segment(this,rs_size);
new_context->datastack_region = new segment(ds_size);
new_context->retainstack_region = new segment(rs_size);
}
return new_context;

113
vm/copying_collector.hpp Normal file
View File

@ -0,0 +1,113 @@
namespace factor
{
struct dummy_unmarker {
void operator()(bool result, card *ptr) {}
};
struct simple_unmarker {
card unmask;
simple_unmarker(card unmask_) : unmask(unmask_) {}
void operator()(bool result, card *ptr) { *ptr &= ~unmask; }
};
struct complex_unmarker {
card unmask_none, unmask_some;
complex_unmarker(card unmask_none_, card unmask_some_) :
unmask_none(unmask_none_), unmask_some(unmask_some_) {}
void operator()(bool result, card *ptr) {
*ptr &= (result ? ~unmask_some : ~unmask_none);
}
};
template<typename TargetGeneration, typename Policy>
struct copying_collector : collector<TargetGeneration,Policy> {
cell scan;
explicit copying_collector(factor_vm *myvm_, TargetGeneration *target_, Policy policy_) :
collector<TargetGeneration,Policy>(myvm_,target_,policy_), scan(target_->here) {}
template<typename SourceGeneration>
bool trace_objects_between(SourceGeneration *gen, cell scan, cell *end)
{
bool copied = false;
while(scan && scan < *end)
{
copied |= this->trace_slots((object *)scan);
scan = gen->next_object_after(this->myvm,scan);
}
return copied;
}
template<typename SourceGeneration, typename Unmarker>
bool trace_card(SourceGeneration *gen, card *ptr, Unmarker unmarker)
{
cell card_start = this->myvm->card_to_addr(ptr);
cell card_scan = card_start + gen->first_object_in_card(card_start);
cell card_end = this->myvm->card_to_addr(ptr + 1);
bool result = this->trace_objects_between(gen,card_scan,&card_end);
unmarker(result,ptr);
this->myvm->gc_stats.cards_scanned++;
return result;
}
template<typename SourceGeneration, typename Unmarker>
bool trace_card_deck(SourceGeneration *gen, card_deck *deck, card mask, Unmarker unmarker)
{
card *first_card = this->myvm->deck_to_card(deck);
card *last_card = this->myvm->deck_to_card(deck + 1);
bool copied = false;
for(card *ptr = first_card; ptr < last_card; ptr++)
if(*ptr & mask) copied |= trace_card(gen,ptr,unmarker);
this->myvm->gc_stats.decks_scanned++;
return copied;
}
template<typename SourceGeneration, typename Unmarker>
void trace_cards(SourceGeneration *gen, card mask, Unmarker unmarker)
{
u64 start = current_micros();
card_deck *first_deck = this->myvm->addr_to_deck(gen->start);
card_deck *last_deck = this->myvm->addr_to_deck(gen->end);
for(card_deck *ptr = first_deck; ptr < last_deck; ptr++)
if(*ptr & mask) unmarker(trace_card_deck(gen,ptr,mask,unmarker),ptr);
this->myvm->gc_stats.card_scan_time += (current_micros() - start);
}
/* Trace all literals referenced from a code block. Only for aging and nursery collections */
void trace_literal_references(code_block *compiled)
{
this->trace_handle(&compiled->owner);
this->trace_handle(&compiled->literals);
this->trace_handle(&compiled->relocation);
this->myvm->gc_stats.code_blocks_scanned++;
}
void trace_code_heap_roots(std::set<code_block *> *remembered_set)
{
std::set<code_block *>::const_iterator iter = remembered_set->begin();
std::set<code_block *>::const_iterator end = remembered_set->end();
for(; iter != end; iter++) trace_literal_references(*iter);
}
void cheneys_algorithm()
{
trace_objects_between(this->target,scan,&this->target->here);
}
};
}

783
vm/data_gc.cpp
View File

@ -1,783 +0,0 @@
#include "master.hpp"
namespace factor
{
void factor_vm::init_data_gc()
{
last_code_heap_scan = data->nursery();
}
gc_state::gc_state(data_heap *data_, bool growing_data_heap_, cell collecting_gen_) :
data(data_),
growing_data_heap(growing_data_heap_),
collecting_gen(collecting_gen_),
collecting_aging_again(false),
start_time(current_micros()) { }
gc_state::~gc_state() { }
/* Given a pointer to oldspace, copy it to newspace */
object *factor_vm::copy_untagged_object_impl(object *pointer, cell size)
{
if(current_gc->newspace->here + size >= current_gc->newspace->end)
longjmp(current_gc->gc_unwind,1);
object *newpointer = allot_zone(current_gc->newspace,size);
gc_stats *s = &stats[current_gc->collecting_gen];
s->object_count++;
s->bytes_copied += size;
memcpy(newpointer,pointer,size);
return newpointer;
}
object *factor_vm::copy_object_impl(object *untagged)
{
object *newpointer = copy_untagged_object_impl(untagged,untagged_object_size(untagged));
untagged->h.forward_to(newpointer);
return newpointer;
}
bool factor_vm::should_copy_p(object *untagged)
{
if(in_zone(current_gc->newspace,untagged))
return false;
if(current_gc->collecting_tenured_p())
return true;
else if(data->have_aging_p() && current_gc->collecting_gen == data->aging())
return !in_zone(&data->generations[data->tenured()],untagged);
else if(current_gc->collecting_nursery_p())
return in_zone(&nursery,untagged);
else
{
critical_error("Bug in should_copy_p",(cell)untagged);
return false;
}
}
/* Follow a chain of forwarding pointers */
object *factor_vm::resolve_forwarding(object *untagged)
{
check_data_pointer(untagged);
/* is there another forwarding pointer? */
if(untagged->h.forwarding_pointer_p())
return resolve_forwarding(untagged->h.forwarding_pointer());
/* we've found the destination */
else
{
untagged->h.check_header();
if(should_copy_p(untagged))
return copy_object_impl(untagged);
else
return untagged;
}
}
template<typename Type> Type *factor_vm::copy_untagged_object(Type *untagged)
{
check_data_pointer(untagged);
if(untagged->h.forwarding_pointer_p())
untagged = (Type *)resolve_forwarding(untagged->h.forwarding_pointer());
else
{
untagged->h.check_header();
untagged = (Type *)copy_object_impl(untagged);
}
return untagged;
}
cell factor_vm::copy_object(cell pointer)
{
return RETAG(copy_untagged_object(untag<object>(pointer)),TAG(pointer));
}
void factor_vm::trace_handle(cell *handle)
{
cell pointer = *handle;
if(!immediate_p(pointer))
{
object *obj = untag<object>(pointer);
check_data_pointer(obj);
if(should_copy_p(obj))
*handle = copy_object(pointer);
}
}
/* Scan all the objects in the card */
void factor_vm::trace_card(card *ptr, cell gen, cell here)
{
cell card_scan = card_to_addr(ptr) + card_offset(ptr);
cell card_end = card_to_addr(ptr + 1);
if(here < card_end)
card_end = here;
copy_reachable_objects(card_scan,&card_end);
cards_scanned++;
}
void factor_vm::trace_card_deck(card_deck *deck, cell gen, card mask, card unmask)
{
card *first_card = deck_to_card(deck);
card *last_card = deck_to_card(deck + 1);
cell here = data->generations[gen].here;
u32 *quad_ptr;
u32 quad_mask = mask | (mask << 8) | (mask << 16) | (mask << 24);
for(quad_ptr = (u32 *)first_card; quad_ptr < (u32 *)last_card; quad_ptr++)
{
if(*quad_ptr & quad_mask)
{
card *ptr = (card *)quad_ptr;
int card;
for(card = 0; card < 4; card++)
{
if(ptr[card] & mask)
{
trace_card(&ptr[card],gen,here);
ptr[card] &= ~unmask;
}
}
}
}
decks_scanned++;
}
/* Copy all newspace objects referenced from marked cards to the destination */
void factor_vm::trace_generation_cards(cell gen)
{
card_deck *first_deck = addr_to_deck(data->generations[gen].start);
card_deck *last_deck = addr_to_deck(data->generations[gen].end);
card mask, unmask;
/* if we are collecting the nursery, we care about old->nursery pointers
but not old->aging pointers */
if(current_gc->collecting_nursery_p())
{
mask = card_points_to_nursery;
/* after the collection, no old->nursery pointers remain
anywhere, but old->aging pointers might remain in tenured
space */
if(gen == data->tenured())
unmask = card_points_to_nursery;
/* after the collection, all cards in aging space can be
cleared */
else if(data->have_aging_p() && gen == data->aging())
unmask = card_mark_mask;
else
{
critical_error("bug in trace_generation_cards",gen);
return;
}
}
/* if we are collecting aging space into tenured space, we care about
all old->nursery and old->aging pointers. no old->aging pointers can
remain */
else if(data->have_aging_p() && current_gc->collecting_gen == data->aging())
{
if(current_gc->collecting_aging_again)
{
mask = card_points_to_aging;
unmask = card_mark_mask;
}
/* after we collect aging space into the aging semispace, no
old->nursery pointers remain but tenured space might still have
pointers to aging space. */
else
{
mask = card_points_to_aging;
unmask = card_points_to_nursery;
}
}
else
{
critical_error("bug in trace_generation_cards",gen);
return;
}
card_deck *ptr;
for(ptr = first_deck; ptr < last_deck; ptr++)
{
if(*ptr & mask)
{
trace_card_deck(ptr,gen,mask,unmask);
*ptr &= ~unmask;
}
}
}
/* Scan cards in all generations older than the one being collected, copying
old->new references */
void factor_vm::trace_cards()
{
u64 start = current_micros();
cell i;
for(i = current_gc->collecting_gen + 1; i < data->gen_count; i++)
trace_generation_cards(i);
card_scan_time += (current_micros() - start);
}
/* Copy all tagged pointers in a range of memory */
void factor_vm::trace_stack_elements(segment *region, cell top)
{
cell ptr = region->start;
for(; ptr <= top; ptr += sizeof(cell))
trace_handle((cell*)ptr);
}
void factor_vm::trace_registered_locals()
{
std::vector<cell>::const_iterator iter = gc_locals.begin();
std::vector<cell>::const_iterator end = gc_locals.end();
for(; iter < end; iter++)
trace_handle((cell *)(*iter));
}
void factor_vm::trace_registered_bignums()
{
std::vector<cell>::const_iterator iter = gc_bignums.begin();
std::vector<cell>::const_iterator end = gc_bignums.end();
for(; iter < end; iter++)
{
bignum **handle = (bignum **)(*iter);
bignum *pointer = *handle;
if(pointer)
{
check_data_pointer(pointer);
if(should_copy_p(pointer))
*handle = copy_untagged_object(pointer);
#ifdef FACTOR_DEBUG
assert((*handle)->h.hi_tag() == BIGNUM_TYPE);
#endif
}
}
}
/* Copy roots over at the start of GC, namely various constants, stacks,
the user environment and extra roots registered by local_roots.hpp */
void factor_vm::trace_roots()
{
trace_handle(&T);
trace_handle(&bignum_zero);
trace_handle(&bignum_pos_one);
trace_handle(&bignum_neg_one);
trace_registered_locals();
trace_registered_bignums();
int i;
for(i = 0; i < USER_ENV; i++)
trace_handle(&userenv[i]);
}
void factor_vm::trace_contexts()
{
save_stacks();
context *stacks = stack_chain;
while(stacks)
{
trace_stack_elements(stacks->datastack_region,stacks->datastack);
trace_stack_elements(stacks->retainstack_region,stacks->retainstack);
trace_handle(&stacks->catchstack_save);
trace_handle(&stacks->current_callback_save);
mark_active_blocks(stacks);
stacks = stacks->next;
}
}
cell factor_vm::copy_next_from_nursery(cell scan)
{
cell *obj = (cell *)scan;
cell *end = (cell *)(scan + binary_payload_start((object *)scan));
if(obj != end)
{
obj++;
cell nursery_start = nursery.start;
cell nursery_end = nursery.end;
for(; obj < end; obj++)
{
cell pointer = *obj;
if(!immediate_p(pointer))
{
check_data_pointer((object *)pointer);
if(pointer >= nursery_start && pointer < nursery_end)
*obj = copy_object(pointer);
}
}
}
return scan + untagged_object_size((object *)scan);
}
cell factor_vm::copy_next_from_aging(cell scan)
{
cell *obj = (cell *)scan;
cell *end = (cell *)(scan + binary_payload_start((object *)scan));
if(obj != end)
{
obj++;
cell tenured_start = data->generations[data->tenured()].start;
cell tenured_end = data->generations[data->tenured()].end;
cell newspace_start = current_gc->newspace->start;
cell newspace_end = current_gc->newspace->end;
for(; obj < end; obj++)
{
cell pointer = *obj;
if(!immediate_p(pointer))
{
check_data_pointer((object *)pointer);
if(!(pointer >= newspace_start && pointer < newspace_end)
&& !(pointer >= tenured_start && pointer < tenured_end))
*obj = copy_object(pointer);
}
}
}
return scan + untagged_object_size((object *)scan);
}
cell factor_vm::copy_next_from_tenured(cell scan)
{
cell *obj = (cell *)scan;
cell *end = (cell *)(scan + binary_payload_start((object *)scan));
if(obj != end)
{
obj++;
cell newspace_start = current_gc->newspace->start;
cell newspace_end = current_gc->newspace->end;
for(; obj < end; obj++)
{
cell pointer = *obj;
if(!immediate_p(pointer))
{
check_data_pointer((object *)pointer);
if(!(pointer >= newspace_start && pointer < newspace_end))
*obj = copy_object(pointer);
}
}
}
mark_object_code_block((object *)scan);
return scan + untagged_object_size((object *)scan);
}
void factor_vm::copy_reachable_objects(cell scan, cell *end)
{
if(current_gc->collecting_nursery_p())
{
while(scan < *end)
scan = copy_next_from_nursery(scan);
}
else if(data->have_aging_p() && current_gc->collecting_gen == data->aging())
{
while(scan < *end)
scan = copy_next_from_aging(scan);
}
else if(current_gc->collecting_tenured_p())
{
while(scan < *end)
scan = copy_next_from_tenured(scan);
}
}
void factor_vm::update_code_heap_roots()
{
if(current_gc->collecting_gen >= last_code_heap_scan)
{
code_heap_scans++;
trace_code_heap_roots();
if(current_gc->collecting_accumulation_gen_p())
last_code_heap_scan = current_gc->collecting_gen;
else
last_code_heap_scan = current_gc->collecting_gen + 1;
}
}
struct literal_and_word_reference_updater {
factor_vm *myvm;
literal_and_word_reference_updater(factor_vm *myvm_) : myvm(myvm_) {}
void operator()(heap_block *block)
{
code_block *compiled = (code_block *)block;
myvm->update_literal_references(compiled);
myvm->update_word_references(compiled);
}
};
void factor_vm::free_unmarked_code_blocks()
{
literal_and_word_reference_updater updater(this);
code->free_unmarked(updater);
last_code_heap_scan = current_gc->collecting_gen;
}
void factor_vm::update_dirty_code_blocks()
{
std::set<code_block *> dirty_code_blocks = current_gc->dirty_code_blocks;
std::set<code_block *>::const_iterator iter = dirty_code_blocks.begin();
std::set<code_block *>::const_iterator end = dirty_code_blocks.end();
for(; iter != end; iter++)
update_literal_references(*iter);
dirty_code_blocks.clear();
}
/* Prepare to start copying reachable objects into an unused zone */
void factor_vm::begin_gc(cell requested_bytes)
{
if(current_gc->growing_data_heap)
{
assert(current_gc->collecting_tenured_p());
current_gc->old_data_heap = data;
set_data_heap(grow_data_heap(current_gc->old_data_heap,requested_bytes));
current_gc->newspace = &data->generations[data->tenured()];
}
else if(current_gc->collecting_accumulation_gen_p())
{
/* when collecting one of these generations, rotate it
with the semispace */
zone z = data->generations[current_gc->collecting_gen];
data->generations[current_gc->collecting_gen] = data->semispaces[current_gc->collecting_gen];
data->semispaces[current_gc->collecting_gen] = z;
reset_generation(current_gc->collecting_gen);
current_gc->newspace = &data->generations[current_gc->collecting_gen];
clear_cards(current_gc->collecting_gen,current_gc->collecting_gen);
clear_decks(current_gc->collecting_gen,current_gc->collecting_gen);
clear_allot_markers(current_gc->collecting_gen,current_gc->collecting_gen);
}
else
{
/* when collecting a younger generation, we copy
reachable objects to the next oldest generation,
so we set the newspace so the next generation. */
current_gc->newspace = &data->generations[current_gc->collecting_gen + 1];
}
}
void factor_vm::end_gc()
{
gc_stats *s = &stats[current_gc->collecting_gen];
cell gc_elapsed = (current_micros() - current_gc->start_time);
s->collections++;
s->gc_time += gc_elapsed;
if(s->max_gc_time < gc_elapsed)
s->max_gc_time = gc_elapsed;
if(current_gc->growing_data_heap)
delete current_gc->old_data_heap;
if(current_gc->collecting_nursery_p())
{
nursery.here = nursery.start;
}
else if(current_gc->collecting_accumulation_gen_p())
{
reset_generations(data->nursery(),current_gc->collecting_gen - 1);
}
else
{
/* all generations up to and including the one
collected are now empty */
reset_generations(data->nursery(),current_gc->collecting_gen);
}
}
/* Collect gen and all younger generations.
If growing_data_heap_ is true, we must grow the data heap to such a size that
an allocation of requested_bytes won't fail */
void factor_vm::garbage_collection(cell collecting_gen_, bool growing_data_heap_, bool trace_contexts_, cell requested_bytes)
{
if(gc_off)
{
critical_error("GC disabled",collecting_gen_);
return;
}
current_gc = new gc_state(data,growing_data_heap_,collecting_gen_);
/* Keep trying to GC higher and higher generations until we don't run out
of space */
if(setjmp(current_gc->gc_unwind))
{
/* We come back here if a generation is full */
/* We have no older generations we can try collecting, so we
resort to growing the data heap */
if(current_gc->collecting_tenured_p())
{
current_gc->growing_data_heap = true;
/* see the comment in unmark_marked() */
code->unmark_marked();
}
/* we try collecting aging space twice before going on to
collect tenured */
else if(data->have_aging_p()
&& current_gc->collecting_gen == data->aging()
&& !current_gc->collecting_aging_again)
{
current_gc->collecting_aging_again = true;
}
/* Collect the next oldest generation */
else
{
current_gc->collecting_gen++;
}
}
begin_gc(requested_bytes);
/* Initialize chase pointer */
cell scan = current_gc->newspace->here;
/* Trace objects referenced from global environment */
trace_roots();
/* Trace objects referenced from stacks, unless we're doing
save-image-and-exit in which case stack objects are irrelevant */
if(trace_contexts_) trace_contexts();
/* Trace objects referenced from older generations */
trace_cards();
/* On minor GC, trace code heap roots if it has pointers
to this generation or younger. Otherwise, tracing data heap objects
will mark all reachable code blocks, and we free the unmarked ones
after. */
if(!current_gc->collecting_tenured_p() && current_gc->collecting_gen >= last_code_heap_scan)
{
update_code_heap_roots();
}
/* do some copying -- this is where most of the work is done */
copy_reachable_objects(scan,&current_gc->newspace->here);
/* On minor GC, update literal references in code blocks, now that all
data heap objects are in their final location. On a major GC,
free all code blocks that did not get marked during tracing. */
if(current_gc->collecting_tenured_p())
free_unmarked_code_blocks();
else
update_dirty_code_blocks();
/* GC completed without any generations filling up; finish up */
end_gc();
delete current_gc;
current_gc = NULL;
}
void factor_vm::gc()
{
garbage_collection(data->tenured(),false,true,0);
}
void factor_vm::primitive_gc()
{
gc();
}
void factor_vm::primitive_gc_stats()
{
growable_array result(this);
cell i;
u64 total_gc_time = 0;
for(i = 0; i < max_gen_count; i++)
{
gc_stats *s = &stats[i];
result.add(allot_cell(s->collections));
result.add(tag<bignum>(long_long_to_bignum(s->gc_time)));
result.add(tag<bignum>(long_long_to_bignum(s->max_gc_time)));
result.add(allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections));
result.add(allot_cell(s->object_count));
result.add(tag<bignum>(long_long_to_bignum(s->bytes_copied)));
total_gc_time += s->gc_time;
}
result.add(tag<bignum>(ulong_long_to_bignum(total_gc_time)));
result.add(tag<bignum>(ulong_long_to_bignum(cards_scanned)));
result.add(tag<bignum>(ulong_long_to_bignum(decks_scanned)));
result.add(tag<bignum>(ulong_long_to_bignum(card_scan_time)));
result.add(allot_cell(code_heap_scans));
result.trim();
dpush(result.elements.value());
}
void factor_vm::clear_gc_stats()
{
for(cell i = 0; i < max_gen_count; i++)
memset(&stats[i],0,sizeof(gc_stats));
cards_scanned = 0;
decks_scanned = 0;
card_scan_time = 0;
code_heap_scans = 0;
}
void factor_vm::primitive_clear_gc_stats()
{
clear_gc_stats();
}
/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this
to coalesce equal but distinct quotations and wrappers. */
void factor_vm::primitive_become()
{
array *new_objects = untag_check<array>(dpop());
array *old_objects = untag_check<array>(dpop());
cell capacity = array_capacity(new_objects);
if(capacity != array_capacity(old_objects))
critical_error("bad parameters to become",0);
cell i;
for(i = 0; i < capacity; i++)
{
tagged<object> old_obj(array_nth(old_objects,i));
tagged<object> new_obj(array_nth(new_objects,i));
if(old_obj != new_obj)
old_obj->h.forward_to(new_obj.untagged());
}
gc();
/* If a word's definition quotation was in old_objects and the
quotation in new_objects is not compiled, we might leak memory
by referencing the old quotation unless we recompile all
unoptimized words. */
compile_all_words();
}
void factor_vm::inline_gc(cell *gc_roots_base, cell gc_roots_size)
{
for(cell i = 0; i < gc_roots_size; i++)
gc_locals.push_back((cell)&gc_roots_base[i]);
garbage_collection(data->nursery(),false,true,0);
for(cell i = 0; i < gc_roots_size; i++)
gc_locals.pop_back();
}
VM_C_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *myvm)
{
ASSERTVM();
VM_PTR->inline_gc(gc_roots_base,gc_roots_size);
}
inline object *factor_vm::allot_zone(zone *z, cell a)
{
cell h = z->here;
z->here = h + align8(a);
object *obj = (object *)h;
allot_barrier(obj);
return obj;
}
/*
* It is up to the caller to fill in the object's fields in a meaningful
* fashion!
*/
object *factor_vm::allot_object(header header, cell size)
{
#ifdef GC_DEBUG
if(!gc_off)
gc();
#endif
object *obj;
if(nursery.size > size)
{
/* If there is insufficient room, collect the nursery */
if(nursery.here + size > nursery.end)
garbage_collection(data->nursery(),false,true,0);
cell h = nursery.here;
nursery.here = h + align8(size);
obj = (object *)h;
}
/* If the object is bigger than the nursery, allocate it in
tenured space */
else
{
zone *tenured = &data->generations[data->tenured()];
/* If tenured space does not have enough room, collect */
if(tenured->here + size > tenured->end)
{
gc();
tenured = &data->generations[data->tenured()];
}
/* If it still won't fit, grow the heap */
if(tenured->here + size > tenured->end)
{
garbage_collection(data->tenured(),true,true,size);
tenured = &data->generations[data->tenured()];
}
obj = allot_zone(tenured,size);
/* Allows initialization code to store old->new pointers
without hitting the write barrier in the common case of
a nursery allocation */
write_barrier(obj);
}
obj->h = header;
return obj;
}
}

146
vm/data_heap.cpp
View File

@ -6,12 +6,11 @@ namespace factor
void factor_vm::init_card_decks()
{
cell start = align(data->seg->start,deck_size);
allot_markers_offset = (cell)data->allot_markers - (start >> card_bits);
cards_offset = (cell)data->cards - (start >> card_bits);
decks_offset = (cell)data->decks - (start >> deck_bits);
}
data_heap::data_heap(factor_vm *myvm, cell gen_count_, cell young_size_, cell aging_size_, cell tenured_size_)
data_heap::data_heap(factor_vm *myvm, cell young_size_, cell aging_size_, cell tenured_size_)
{
young_size_ = align(young_size_,deck_size);
aging_size_ = align(aging_size_,deck_size);
@ -20,29 +19,14 @@ data_heap::data_heap(factor_vm *myvm, cell gen_count_, cell young_size_, cell ag
young_size = young_size_;
aging_size = aging_size_;
tenured_size = tenured_size_;
gen_count = gen_count_;
cell total_size;
if(gen_count == 2)
total_size = young_size + 2 * tenured_size;
else if(gen_count == 3)
total_size = young_size + 2 * aging_size + 2 * tenured_size;
else
{
total_size = 0;
fatal_error("Invalid number of generations",gen_count);
}
cell total_size = young_size + 2 * aging_size + 2 * tenured_size;
total_size += deck_size;
seg = new segment(myvm,total_size);
generations = new zone[gen_count];
semispaces = new zone[gen_count];
seg = new segment(total_size);
cell cards_size = total_size >> card_bits;
allot_markers = new char[cards_size];
allot_markers_end = allot_markers + cards_size;
cards = new char[cards_size];
cards_end = cards + cards_size;
@ -51,25 +35,29 @@ data_heap::data_heap(factor_vm *myvm, cell gen_count_, cell young_size_, cell ag
decks = new char[decks_size];
decks_end = decks + decks_size;
cell alloter = align(seg->start,deck_size);
cell start = align(seg->start,deck_size);
alloter = generations[tenured()].init_zone(tenured_size,alloter);
alloter = semispaces[tenured()].init_zone(tenured_size,alloter);
tenured = new tenured_space(tenured_size,start);
tenured_semispace = new tenured_space(tenured_size,tenured->end);
if(gen_count == 3)
{
alloter = generations[aging()].init_zone(aging_size,alloter);
alloter = semispaces[aging()].init_zone(aging_size,alloter);
}
aging = new aging_space(aging_size,tenured_semispace->end);
aging_semispace = new aging_space(aging_size,aging->end);
if(gen_count >= 2)
{
alloter = generations[nursery()].init_zone(young_size,alloter);
alloter = semispaces[nursery()].init_zone(0,alloter);
}
nursery = new zone(young_size,aging_semispace->end);
if(seg->end - alloter > deck_size)
myvm->critical_error("Bug in alloc_data_heap",alloter);
assert(seg->end - nursery->end <= deck_size);
}
data_heap::~data_heap()
{
delete seg;
delete nursery;
delete aging;
delete aging_semispace;
delete tenured;
delete tenured_semispace;
delete[] cards;
delete[] decks;
}
data_heap *factor_vm::grow_data_heap(data_heap *data, cell requested_bytes)
@ -77,83 +65,53 @@ data_heap *factor_vm::grow_data_heap(data_heap *data, cell requested_bytes)
cell new_tenured_size = (data->tenured_size * 2) + requested_bytes;
return new data_heap(this,
data->gen_count,
data->young_size,
data->aging_size,
new_tenured_size);
}
data_heap::~data_heap()
{
delete seg;
delete[] generations;
delete[] semispaces;
delete[] allot_markers;
delete[] cards;
delete[] decks;
}
void factor_vm::clear_cards(cell from, cell to)
void factor_vm::clear_cards(old_space *gen)
{
/* NOTE: reverse order due to heap layout. */
card *first_card = addr_to_card(data->generations[to].start);
card *last_card = addr_to_card(data->generations[from].end);
card *first_card = addr_to_card(gen->start);
card *last_card = addr_to_card(gen->end);
memset(first_card,0,last_card - first_card);
}
void factor_vm::clear_decks(cell from, cell to)
void factor_vm::clear_decks(old_space *gen)
{
/* NOTE: reverse order due to heap layout. */
card_deck *first_deck = addr_to_deck(data->generations[to].start);
card_deck *last_deck = addr_to_deck(data->generations[from].end);
card_deck *first_deck = addr_to_deck(gen->start);
card_deck *last_deck = addr_to_deck(gen->end);
memset(first_deck,0,last_deck - first_deck);
}
void factor_vm::clear_allot_markers(cell from, cell to)
{
/* NOTE: reverse order due to heap layout. */
card *first_card = addr_to_allot_marker((object *)data->generations[to].start);
card *last_card = addr_to_allot_marker((object *)data->generations[from].end);
memset(first_card,invalid_allot_marker,last_card - first_card);
}
void factor_vm::reset_generation(cell i)
{
zone *z = (i == data->nursery() ? &nursery : &data->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 factor_vm::reset_generations(cell from, cell to)
void factor_vm::reset_generation(old_space *gen)
{
cell i;
for(i = from; i <= to; i++)
reset_generation(i);
gen->here = gen->start;
if(secure_gc) memset((void*)gen->start,69,gen->size);
clear_cards(from,to);
clear_decks(from,to);
clear_allot_markers(from,to);
clear_cards(gen);
clear_decks(gen);
gen->clear_object_start_offsets();
}
void factor_vm::set_data_heap(data_heap *data_)
{
data = data_;
nursery = data->generations[data->nursery()];
nursery = *data->nursery;
nursery.here = nursery.start;
init_card_decks();
clear_cards(data->nursery(),data->tenured());
clear_decks(data->nursery(),data->tenured());
clear_allot_markers(data->nursery(),data->tenured());
reset_generation(data->aging);
reset_generation(data->tenured);
}
void factor_vm::init_data_heap(cell gens,cell young_size,cell aging_size,cell tenured_size,bool secure_gc_)
void factor_vm::init_data_heap(cell young_size, cell aging_size, cell tenured_size, bool secure_gc_)
{
set_data_heap(new data_heap(this,gens,young_size,aging_size,tenured_size));
set_data_heap(new data_heap(this,young_size,aging_size,tenured_size));
secure_gc = secure_gc_;
init_data_gc();
}
/* Size of the object pointed to by a tagged pointer */
@ -256,13 +214,14 @@ void factor_vm::primitive_data_room()
growable_array a(this);
cell gen;
for(gen = 0; gen < data->gen_count; gen++)
{
zone *z = (gen == data->nursery() ? &nursery : &data->generations[gen]);
a.add(tag_fixnum((z->end - z->here) >> 10));
a.add(tag_fixnum((z->size) >> 10));
}
a.add(tag_fixnum((nursery.end - nursery.here) >> 10));
a.add(tag_fixnum((nursery.size) >> 10));
a.add(tag_fixnum((data->aging->end - data->aging->here) >> 10));
a.add(tag_fixnum((data->aging->size) >> 10));
a.add(tag_fixnum((data->tenured->end - data->tenured->here) >> 10));
a.add(tag_fixnum((data->tenured->size) >> 10));
a.trim();
dpush(a.elements.value());
@ -271,7 +230,7 @@ void factor_vm::primitive_data_room()
/* Disables GC and activates next-object ( -- obj ) primitive */
void factor_vm::begin_scan()
{
heap_scan_ptr = data->generations[data->tenured()].start;
heap_scan_ptr = data->tenured->start;
gc_off = true;
}
@ -290,7 +249,7 @@ cell factor_vm::next_object()
if(!gc_off)
general_error(ERROR_HEAP_SCAN,F,F,NULL);
if(heap_scan_ptr >= data->generations[data->tenured()].here)
if(heap_scan_ptr >= data->tenured->here)
return F;
object *obj = (object *)heap_scan_ptr;
@ -319,9 +278,6 @@ template<typename Iterator> void factor_vm::each_object(Iterator &iterator)
end_scan();
}
namespace
{
struct word_counter {
cell count;
explicit word_counter() : count(0) {}
@ -334,8 +290,6 @@ struct word_accumulator {
void operator()(tagged<object> obj) { if(obj.type_p(WORD_TYPE)) words.add(obj.value()); }
};
}
cell factor_vm::find_all_words()
{
word_counter counter;

55
vm/data_heap.hpp
View File

@ -1,38 +1,18 @@
namespace factor
{
/* generational copying GC divides memory into zones */
struct zone {
/* allocation pointer is 'here'; its offset is hardcoded in the
compiler backends */
cell start;
cell here;
cell size;
cell end;
cell init_zone(cell size_, cell start_)
{
size = size_;
start = here = start_;
end = start_ + size_;
return end;
}
};
struct data_heap {
segment *seg;
cell young_size;
cell aging_size;
cell tenured_size;
cell gen_count;
segment *seg;
zone *generations;
zone *semispaces;
char *allot_markers;
char *allot_markers_end;
zone *nursery;
aging_space *aging;
aging_space *aging_semispace;
tenured_space *tenured;
tenured_space *tenured_semispace;
char *cards;
char *cards_end;
@ -40,26 +20,13 @@ struct data_heap {
char *decks;
char *decks_end;
/* the 0th generation is where new objects are allocated. */
cell nursery() { return 0; }
/* where objects hang around */
cell aging() { return gen_count - 2; }
/* the oldest generation */
cell tenured() { return gen_count - 1; }
bool have_aging_p() { return gen_count > 2; }
explicit data_heap(factor_vm *myvm, cell gen_count, cell young_size, cell aging_size, cell tenured_size);
explicit data_heap(factor_vm *myvm, cell young_size, cell aging_size, cell tenured_size);
~data_heap();
};
static const cell max_gen_count = 3;
inline static bool in_zone(zone *z, object *pointer)
{
return (cell)pointer >= z->start && (cell)pointer < z->end;
}
static const cell nursery_gen = 0;
static const cell aging_gen = 1;
static const cell tenured_gen = 2;
static const cell gen_count = 3;
}

47
vm/debug.cpp
View File

@ -211,8 +211,9 @@ void factor_vm::dump_memory(cell from, cell to)
dump_cell(from);
}
void factor_vm::dump_zone(zone *z)
void factor_vm::dump_zone(cell gen, zone *z)
{
print_string("Generation "); print_cell(gen); print_string(": ");
print_string("Start="); print_cell(z->start);
print_string(", size="); print_cell(z->size);
print_string(", here="); print_cell(z->here - z->start); nl();
@ -220,22 +221,9 @@ void factor_vm::dump_zone(zone *z)
void factor_vm::dump_generations()
{
cell i;
print_string("Nursery: ");
dump_zone(&nursery);
for(i = 1; i < data->gen_count; i++)
{
print_string("Generation "); print_cell(i); print_string(": ");
dump_zone(&data->generations[i]);
}
for(i = 0; i < data->gen_count; i++)
{
print_string("Semispace "); print_cell(i); print_string(": ");
dump_zone(&data->semispaces[i]);
}
dump_zone(nursery_gen,&nursery);
dump_zone(aging_gen,data->aging);
dump_zone(tenured_gen,data->tenured);
print_string("Cards: base=");
print_cell((cell)data->cards);
@ -308,28 +296,23 @@ void factor_vm::dump_code_heap()
while(scan)
{
const char *status;
switch(scan->status)
{
case B_FREE:
if(scan->type() == FREE_BLOCK_TYPE)
status = "free";
break;
case B_ALLOCATED:
reloc_size += object_size(((code_block *)scan)->relocation);
literal_size += object_size(((code_block *)scan)->literals);
status = "allocated";
break;
case B_MARKED:
else if(scan->marked_p())
{
reloc_size += object_size(((code_block *)scan)->relocation);
literal_size += object_size(((code_block *)scan)->literals);
status = "marked";
break;
default:
status = "invalid";
break;
}
else
{
reloc_size += object_size(((code_block *)scan)->relocation);
literal_size += object_size(((code_block *)scan)->literals);
status = "allocated";
}
print_cell_hex((cell)scan); print_string(" ");
print_cell_hex(scan->size); print_string(" ");
print_cell_hex(scan->size()); print_string(" ");
print_string(status); print_string("\n");
scan = code->next_block(scan);

22
vm/errors.cpp
View File

@ -3,33 +3,33 @@
namespace factor
{
void factor_vm::out_of_memory()
{
print_string("Out of memory\n\n");
dump_generations();
exit(1);
}
void fatal_error(const char* msg, cell tagged)
void fatal_error(const char *msg, cell tagged)
{
print_string("fatal_error: "); print_string(msg);
print_string(": "); print_cell_hex(tagged); nl();
exit(1);
}
void factor_vm::critical_error(const char* msg, cell tagged)
void critical_error(const char *msg, cell tagged)
{
print_string("You have triggered a bug in Factor. Please report.\n");
print_string("critical_error: "); print_string(msg);
print_string(": "); print_cell_hex(tagged); nl();
factorbug();
SIGNAL_VM_PTR()->factorbug();
}
void out_of_memory()
{
print_string("Out of memory\n\n");
SIGNAL_VM_PTR()->dump_generations();
exit(1);
}
void factor_vm::throw_error(cell error, stack_frame *callstack_top)
{
/* If the error handler is set, we rewind any C stack frames and
pass the error to user-space. */
if(userenv[BREAK_ENV] != F)
if(!current_gc && userenv[BREAK_ENV] != F)
{
/* If error was thrown during heap scan, we re-enable the GC */
gc_off = false;

4
vm/errors.hpp
View File

@ -23,7 +23,9 @@ enum vm_error_type
ERROR_FP_TRAP,
};
void fatal_error(const char* msg, cell tagged);
void fatal_error(const char *msg, cell tagged);
void critical_error(const char *msg, cell tagged);
void out_of_memory();
void memory_signal_handler_impl();
void fp_signal_handler_impl();
void misc_signal_handler_impl();

9
vm/factor.cpp
View File

@ -21,7 +21,6 @@ void factor_vm::default_parameters(vm_parameters *p)
p->ds_size = 8 * sizeof(cell);
p->rs_size = 8 * sizeof(cell);
p->gen_count = 2;
p->code_size = 4;
p->young_size = 1;
p->aging_size = 1;
@ -30,7 +29,6 @@ void factor_vm::default_parameters(vm_parameters *p)
p->ds_size = 32 * sizeof(cell);
p->rs_size = 32 * sizeof(cell);
p->gen_count = 3;
p->code_size = 8 * sizeof(cell);
p->young_size = sizeof(cell) / 4;
p->aging_size = sizeof(cell) / 2;
@ -51,8 +49,6 @@ void factor_vm::default_parameters(vm_parameters *p)
p->console = false;
#endif
p->stack_traces = true;
}
bool factor_vm::factor_arg(const vm_char* str, const vm_char* arg, cell* value)
@ -78,7 +74,6 @@ void factor_vm::init_parameters_from_args(vm_parameters *p, int argc, vm_char **
{
if(factor_arg(argv[i],STRING_LITERAL("-datastack=%d"),&p->ds_size));
else if(factor_arg(argv[i],STRING_LITERAL("-retainstack=%d"),&p->rs_size));
else if(factor_arg(argv[i],STRING_LITERAL("-generations=%d"),&p->gen_count));
else if(factor_arg(argv[i],STRING_LITERAL("-young=%d"),&p->young_size));
else if(factor_arg(argv[i],STRING_LITERAL("-aging=%d"),&p->aging_size));
else if(factor_arg(argv[i],STRING_LITERAL("-tenured=%d"),&p->tenured_size));
@ -88,7 +83,6 @@ void factor_vm::init_parameters_from_args(vm_parameters *p, int argc, vm_char **
else if(STRCMP(argv[i],STRING_LITERAL("-fep")) == 0) p->fep = true;
else if(STRNCMP(argv[i],STRING_LITERAL("-i="),3) == 0) p->image_path = argv[i] + 3;
else if(STRCMP(argv[i],STRING_LITERAL("-console")) == 0) p->console = true;
else if(STRCMP(argv[i],STRING_LITERAL("-no-stack-traces")) == 0) p->stack_traces = false;
}
}
@ -155,10 +149,7 @@ void factor_vm::init_factor(vm_parameters *p)
gc_off = false;
if(userenv[STAGE2_ENV] == F)
{
userenv[STACK_TRACES_ENV] = tag_boolean(p->stack_traces);
do_stage1_init();
}
}
/* May allocate memory */

128
vm/full_collector.cpp Normal file
View File

@ -0,0 +1,128 @@
#include "master.hpp"
namespace factor
{
full_collector::full_collector(factor_vm *myvm_) :
copying_collector<tenured_space,full_policy>(myvm_,myvm_->data->tenured,full_policy(myvm_)) {}
struct stack_frame_marker {
factor_vm *myvm;
full_collector *collector;
explicit stack_frame_marker(full_collector *collector_) :
myvm(collector_->myvm), collector(collector_) {}
void operator()(stack_frame *frame)
{
collector->mark_code_block(myvm->frame_code(frame));
}
};
/* Mark code blocks executing in currently active stack frames. */
void full_collector::mark_active_blocks()
{
context *stacks = this->myvm->stack_chain;
while(stacks)
{
cell top = (cell)stacks->callstack_top;
cell bottom = (cell)stacks->callstack_bottom;
stack_frame_marker marker(this);
myvm->iterate_callstack(top,bottom,marker);
stacks = stacks->next;
}
}
void full_collector::mark_object_code_block(object *obj)
{
switch(obj->h.hi_tag())
{
case WORD_TYPE:
{
word *w = (word *)obj;
if(w->code)
mark_code_block(w->code);
if(w->profiling)
mark_code_block(w->profiling);
break;
}
case QUOTATION_TYPE:
{
quotation *q = (quotation *)obj;
if(q->code)
mark_code_block(q->code);
break;
}
case CALLSTACK_TYPE:
{
callstack *stack = (callstack *)obj;
stack_frame_marker marker(this);
myvm->iterate_callstack_object(stack,marker);
break;
}
}
}
/* Trace all literals referenced from a code block. Only for aging and nursery collections */
void full_collector::trace_literal_references(code_block *compiled)
{
this->trace_handle(&compiled->owner);
this->trace_handle(&compiled->literals);
this->trace_handle(&compiled->relocation);
}
/* Mark all literals referenced from a word XT. Only for tenured
collections */
void full_collector::mark_code_block(code_block *compiled)
{
this->code->mark_block(compiled);
trace_literal_references(compiled);
}
void full_collector::cheneys_algorithm()
{
while(scan && scan < target->here)
{
object *obj = (object *)scan;
this->trace_slots(obj);
this->mark_object_code_block(obj);
scan = target->next_object_after(this->myvm,scan);
}
}
void factor_vm::collect_full(cell requested_bytes, bool trace_contexts_p)
{
if(current_gc->growing_data_heap)
{
current_gc->old_data_heap = data;
set_data_heap(grow_data_heap(current_gc->old_data_heap,requested_bytes));
}
else
{
std::swap(data->tenured,data->tenured_semispace);
reset_generation(data->tenured);
}
full_collector collector(this);
collector.trace_roots();
if(trace_contexts_p)
{
collector.trace_contexts();
collector.mark_active_blocks();
}
collector.cheneys_algorithm();
free_unmarked_code_blocks();
reset_generation(data->aging);
nursery.here = nursery.start;
if(current_gc->growing_data_heap)
delete current_gc->old_data_heap;
}
}

27
vm/full_collector.hpp Normal file
View File

@ -0,0 +1,27 @@
namespace factor
{
struct full_policy {
factor_vm *myvm;
zone *tenured;
full_policy(factor_vm *myvm_) : myvm(myvm_), tenured(myvm->data->tenured) {}
bool should_copy_p(object *untagged)
{
return !tenured->contains_p(untagged);
}
};
struct full_collector : copying_collector<tenured_space,full_policy> {
bool trace_contexts_p;
full_collector(factor_vm *myvm_);
void mark_active_blocks();
void mark_object_code_block(object *object);
void trace_literal_references(code_block *compiled);
void mark_code_block(code_block *compiled);
void cheneys_algorithm();
};
}

259
vm/gc.cpp Executable file
View File

@ -0,0 +1,259 @@
#include "master.hpp"
namespace factor
{
gc_state::gc_state(data_heap *data_, bool growing_data_heap_, cell collecting_gen_) :
data(data_),
growing_data_heap(growing_data_heap_),
collecting_gen(collecting_gen_),
collecting_aging_again(false),
start_time(current_micros()) { }
gc_state::~gc_state() { }
struct literal_and_word_reference_updater {
factor_vm *myvm;
literal_and_word_reference_updater(factor_vm *myvm_) : myvm(myvm_) {}
void operator()(heap_block *block)
{
code_block *compiled = (code_block *)block;
myvm->update_literal_references(compiled);
myvm->update_word_references(compiled);
}
};
void factor_vm::free_unmarked_code_blocks()
{
literal_and_word_reference_updater updater(this);
code->free_unmarked(updater);
code->points_to_nursery.clear();
code->points_to_aging.clear();
}
void factor_vm::update_dirty_code_blocks(std::set<code_block *> *remembered_set)
{
/* The youngest generation that any code block can now reference */
std::set<code_block *>::const_iterator iter = remembered_set->begin();
std::set<code_block *>::const_iterator end = remembered_set->end();
for(; iter != end; iter++) update_literal_references(*iter);
}
void factor_vm::record_gc_stats()
{
generation_statistics *s = &gc_stats.generations[current_gc->collecting_gen];
cell gc_elapsed = (current_micros() - current_gc->start_time);
s->collections++;
s->gc_time += gc_elapsed;
if(s->max_gc_time < gc_elapsed)
s->max_gc_time = gc_elapsed;
}
/* Collect gen and all younger generations.
If growing_data_heap_ is true, we must grow the data heap to such a size that
an allocation of requested_bytes won't fail */
void factor_vm::garbage_collection(cell collecting_gen_, bool growing_data_heap_, bool trace_contexts_p, cell requested_bytes)
{
assert(!gc_off);
assert(!current_gc);
save_stacks();
current_gc = new gc_state(data,growing_data_heap_,collecting_gen_);
/* Keep trying to GC higher and higher generations until we don't run out
of space */
if(setjmp(current_gc->gc_unwind))
{
/* We come back here if a generation is full */
/* We have no older generations we can try collecting, so we
resort to growing the data heap */
if(current_gc->collecting_tenured_p())
{
current_gc->growing_data_heap = true;
/* Since we start tracing again, any previously
marked code blocks must be re-marked and re-traced */
code->clear_mark_bits();
}
/* we try collecting aging space twice before going on to
collect tenured */
else if(current_gc->collecting_aging_p()
&& !current_gc->collecting_aging_again)
{
current_gc->collecting_aging_again = true;
}
/* Collect the next oldest generation */
else
{
current_gc->collecting_gen++;
}
}
if(current_gc->collecting_nursery_p())
collect_nursery();
else if(current_gc->collecting_aging_p())
{
if(current_gc->collecting_aging_again)
collect_to_tenured();
else
collect_aging();
}
else if(current_gc->collecting_tenured_p())
collect_full(requested_bytes,trace_contexts_p);
record_gc_stats();
delete current_gc;
current_gc = NULL;
}
void factor_vm::gc()
{
garbage_collection(tenured_gen,false,true,0);
}
void factor_vm::primitive_gc()
{
gc();
}
void factor_vm::primitive_gc_stats()
{
growable_array result(this);
cell i;
u64 total_gc_time = 0;
for(i = 0; i < gen_count; i++)
{
generation_statistics *s = &gc_stats.generations[i];
result.add(allot_cell(s->collections));
result.add(tag<bignum>(long_long_to_bignum(s->gc_time)));
result.add(tag<bignum>(long_long_to_bignum(s->max_gc_time)));
result.add(allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections));
result.add(allot_cell(s->object_count));
result.add(tag<bignum>(long_long_to_bignum(s->bytes_copied)));
total_gc_time += s->gc_time;
}
result.add(tag<bignum>(ulong_long_to_bignum(total_gc_time)));
result.add(tag<bignum>(ulong_long_to_bignum(gc_stats.cards_scanned)));
result.add(tag<bignum>(ulong_long_to_bignum(gc_stats.decks_scanned)));
result.add(tag<bignum>(ulong_long_to_bignum(gc_stats.card_scan_time)));
result.add(allot_cell(gc_stats.code_blocks_scanned));
result.trim();
dpush(result.elements.value());
}
void factor_vm::clear_gc_stats()
{
memset(&gc_stats,0,sizeof(gc_statistics));
}
void factor_vm::primitive_clear_gc_stats()
{
clear_gc_stats();
}
/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this
to coalesce equal but distinct quotations and wrappers. */
void factor_vm::primitive_become()
{
array *new_objects = untag_check<array>(dpop());
array *old_objects = untag_check<array>(dpop());
cell capacity = array_capacity(new_objects);
if(capacity != array_capacity(old_objects))
critical_error("bad parameters to become",0);
cell i;
for(i = 0; i < capacity; i++)
{
tagged<object> old_obj(array_nth(old_objects,i));
tagged<object> new_obj(array_nth(new_objects,i));
if(old_obj != new_obj)
old_obj->h.forward_to(new_obj.untagged());
}
gc();
/* If a word's definition quotation was in old_objects and the
quotation in new_objects is not compiled, we might leak memory
by referencing the old quotation unless we recompile all
unoptimized words. */
compile_all_words();
}
void factor_vm::inline_gc(cell *gc_roots_base, cell gc_roots_size)
{
for(cell i = 0; i < gc_roots_size; i++)
gc_locals.push_back((cell)&gc_roots_base[i]);
garbage_collection(nursery_gen,false,true,0);
for(cell i = 0; i < gc_roots_size; i++)
gc_locals.pop_back();
}
VM_C_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *myvm)
{
ASSERTVM();
VM_PTR->inline_gc(gc_roots_base,gc_roots_size);
}
/*
* It is up to the caller to fill in the object's fields in a meaningful
* fashion!
*/
object *factor_vm::allot_object(header header, cell size)
{
#ifdef GC_DEBUG
if(!gc_off)
gc();
#endif
object *obj;
if(nursery.size > size)
{
/* If there is insufficient room, collect the nursery */
if(nursery.here + size > nursery.end)
garbage_collection(nursery_gen,false,true,0);
obj = nursery.allot(size);
}
/* If the object is bigger than the nursery, allocate it in
tenured space */
else
{
/* If tenured space does not have enough room, collect */
if(data->tenured->here + size > data->tenured->end)
gc();
/* If it still won't fit, grow the heap */
if(data->tenured->here + size > data->tenured->end)
garbage_collection(tenured_gen,true,true,size);
obj = data->tenured->allot(size);
/* Allows initialization code to store old->new pointers
without hitting the write barrier in the common case of
a nursery allocation */
write_barrier(obj);
}
obj->h = header;
return obj;
}
}

31
vm/data_gc.hpp → vm/gc.hpp
View File

@ -2,7 +2,7 @@ namespace factor
{
/* statistics */
struct gc_stats {
struct generation_statistics {
cell collections;
u64 gc_time;
u64 max_gc_time;
@ -10,13 +10,18 @@ struct gc_stats {
u64 bytes_copied;
};
struct gc_statistics {
generation_statistics generations[gen_count];
u64 cards_scanned;
u64 decks_scanned;
u64 card_scan_time;
u64 code_blocks_scanned;
};
struct gc_state {
/* The data heap we're collecting */
data_heap *data;
/* New objects are copied here */
zone *newspace;
/* sometimes we grow the heap */
bool growing_data_heap;
data_heap *old_data_heap;
@ -28,9 +33,6 @@ struct gc_state {
full, we go on to collect tenured */
bool collecting_aging_again;
/* A set of code blocks which need to have their literals updated */
std::set<code_block *> dirty_code_blocks;
/* GC start time, for benchmarking */
u64 start_time;
@ -41,20 +43,23 @@ struct gc_state {
inline bool collecting_nursery_p()
{
return collecting_gen == data->nursery();
return collecting_gen == nursery_gen;
}
inline bool collecting_aging_p()
{
return collecting_gen == aging_gen;
}
inline bool collecting_tenured_p()
{
return collecting_gen == data->tenured();
return collecting_gen == tenured_gen;
}
inline bool collecting_accumulation_gen_p()
{
return ((data->have_aging_p()
&& collecting_gen == data->aging()
&& !collecting_aging_again)
|| collecting_gen == data->tenured());
return ((collecting_aging_p() && !collecting_aging_again)
|| collecting_tenured_p());
}
};

2
vm/generic_arrays.hpp
View File

@ -28,7 +28,7 @@ template<typename Array> Array *factor_vm::allot_array_internal(cell capacity)
template<typename Array> bool factor_vm::reallot_array_in_place_p(Array *array, cell capacity)
{
return in_zone(&nursery,array) && capacity <= array_capacity(array);
return nursery.contains_p(array) && capacity <= array_capacity(array);
}
template<typename Array> Array *factor_vm::reallot_array(Array *array_, cell capacity)

120
vm/heap.cpp
View File

@ -11,19 +11,19 @@ void heap::clear_free_list()
memset(&free,0,sizeof(heap_free_list));
}
heap::heap(factor_vm *myvm_, cell size)
heap::heap(bool secure_gc_, cell size) : secure_gc(secure_gc_)
{
myvm = myvm_;
seg = new segment(myvm,align_page(size));
if(!seg) fatal_error("Out of memory in new_heap",size);
if(size > (1L << (sizeof(cell) * 8 - 6))) fatal_error("Heap too large",size);
seg = new segment(align_page(size));
if(!seg) fatal_error("Out of memory in heap allocator",size);
clear_free_list();
}
void heap::add_to_free_list(free_heap_block *block)
{
if(block->size < free_list_count * block_size_increment)
if(block->size() < free_list_count * block_size_increment)
{
int index = block->size / block_size_increment;
int index = block->size() / block_size_increment;
block->next_free = free.small_blocks[index];
free.small_blocks[index] = block;
}
@ -52,17 +52,8 @@ void heap::build_free_list(cell size)
/* Add all free blocks to the free list */
while(scan && scan < (heap_block *)end)
{
switch(scan->status)
{
case B_FREE:
if(scan->type() == FREE_BLOCK_TYPE)
add_to_free_list((free_heap_block *)scan);
break;
case B_ALLOCATED:
break;
default:
myvm->critical_error("Invalid scan->status",(cell)scan);
break;
}
prev = scan;
scan = next_block(scan);
@ -72,8 +63,9 @@ void heap::build_free_list(cell size)
branch is only taken after loading a new image, not after code GC */
if((cell)(end + 1) <= seg->end)
{
end->status = B_FREE;
end->size = seg->end - (cell)end;
end->set_marked_p(false);
end->set_type(FREE_BLOCK_TYPE);
end->set_size(seg->end - (cell)end);
/* add final free block */
add_to_free_list(end);
@ -85,18 +77,17 @@ void heap::build_free_list(cell size)
/* even if there's no room at the end of the heap for a new
free block, we might have to jigger it up by a few bytes in
case prev + prev->size */
if(prev) prev->size = seg->end - (cell)prev;
if(prev) prev->set_size(seg->end - (cell)prev);
}
}
void heap::assert_free_block(free_heap_block *block)
{
if(block->status != B_FREE)
myvm->critical_error("Invalid block in free list",(cell)block);
if(block->type() != FREE_BLOCK_TYPE)
critical_error("Invalid block in free list",(cell)block);
}
free_heap_block *heap::find_free_block(cell size)
{
cell attempt = size;
@ -121,7 +112,7 @@ free_heap_block *heap::find_free_block(cell size)
while(block)
{
assert_free_block(block);
if(block->size >= size)
if(block->size() >= size)
{
if(prev)
prev->next_free = block->next_free;
@ -139,14 +130,14 @@ free_heap_block *heap::find_free_block(cell size)
free_heap_block *heap::split_free_block(free_heap_block *block, cell size)
{
if(block->size != size )
if(block->size() != size )
{
/* split the block in two */
free_heap_block *split = (free_heap_block *)((cell)block + size);
split->status = B_FREE;
split->size = block->size - size;
split->set_type(FREE_BLOCK_TYPE);
split->set_size(block->size() - size);
split->next_free = block->next_free;
block->size = size;
block->set_size(size);
add_to_free_list(split);
}
@ -154,7 +145,7 @@ free_heap_block *heap::split_free_block(free_heap_block *block, cell size)
}
/* Allocate a block of memory from the mark and sweep GC heap */
heap_block *heap::heap_allot(cell size)
heap_block *heap::heap_allot(cell size, cell type)
{
size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
@ -162,8 +153,8 @@ heap_block *heap::heap_allot(cell size)
if(block)
{
block = split_free_block(block,size);
block->status = B_ALLOCATED;
block->set_type(type);
block->set_marked_p(false);
return block;
}
else
@ -173,37 +164,22 @@ heap_block *heap::heap_allot(cell size)
/* Deallocates a block manually */
void heap::heap_free(heap_block *block)
{
block->status = B_FREE;
block->set_type(FREE_BLOCK_TYPE);
add_to_free_list((free_heap_block *)block);
}
void heap::mark_block(heap_block *block)
{
/* If already marked, do nothing */
switch(block->status)
{
case B_MARKED:
return;
case B_ALLOCATED:
block->status = B_MARKED;
break;
default:
myvm->critical_error("Marking the wrong block",(cell)block);
break;
}
block->set_marked_p(true);
}
/* 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 heap::unmark_marked()
void heap::clear_mark_bits()
{
heap_block *scan = first_block();
while(scan)
{
if(scan->status == B_MARKED)
scan->status = B_ALLOCATED;
scan->set_marked_p(false);
scan = next_block(scan);
}
}
@ -219,19 +195,16 @@ void heap::heap_usage(cell *used, cell *total_free, cell *max_free)
while(scan)
{
switch(scan->status)
cell size = scan->size();
if(scan->type() == FREE_BLOCK_TYPE)
{
case B_ALLOCATED:
*used += scan->size;
break;
case B_FREE:
*total_free += scan->size;
if(scan->size > *max_free)
*max_free = scan->size;
break;
default:
myvm->critical_error("Invalid scan->status",(cell)scan);
*total_free += size;
if(size > *max_free)
*max_free = size;
}
else
*used += size;
scan = next_block(scan);
}
@ -246,7 +219,7 @@ cell heap::heap_size()
scan = next_block(scan);
/* this is the last block in the heap, and it is free */
if(scan->status == B_FREE)
if(scan->type() == FREE_BLOCK_TYPE)
return (cell)scan - seg->start;
/* otherwise the last block is allocated */
else
@ -254,28 +227,25 @@ cell heap::heap_size()
}
/* Compute where each block is going to go, after compaction */
cell heap::compute_heap_forwarding(unordered_map<heap_block *,char *> &forwarding)
cell heap::compute_heap_forwarding()
{
heap_block *scan = first_block();
char *address = (char *)first_block();
while(scan)
{
if(scan->status == B_ALLOCATED)
if(scan->type() != FREE_BLOCK_TYPE)
{
forwarding[scan] = address;
address += scan->size;
address += scan->size();
}
else if(scan->status == B_MARKED)
myvm->critical_error("Why is the block marked?",0);
scan = next_block(scan);
}
return (cell)address - seg->start;
}
void heap::compact_heap(unordered_map<heap_block *,char *> &forwarding)
void heap::compact_heap()
{
heap_block *scan = first_block();
@ -283,25 +253,25 @@ void heap::compact_heap(unordered_map<heap_block *,char *> &forwarding)
{
heap_block *next = next_block(scan);
if(scan->status == B_ALLOCATED)
memmove(forwarding[scan],scan,scan->size);
if(scan->type() != FREE_BLOCK_TYPE)
memmove(forwarding[scan],scan,scan->size());
scan = next;
}
}
heap_block *heap::free_allocated(heap_block *prev, heap_block *scan)
{
if(myvm->secure_gc)
memset(scan + 1,0,scan->size - sizeof(heap_block));
if(secure_gc)
memset(scan + 1,0,scan->size() - sizeof(heap_block));
if(prev && prev->status == B_FREE)
if(prev && prev->type() == FREE_BLOCK_TYPE)
{
prev->size += scan->size;
prev->set_size(prev->size() + scan->size());
return prev;
}
else
{
scan->status = B_FREE;
scan->set_type(FREE_BLOCK_TYPE);
return scan;
}
}

43
vm/heap.hpp
View File

@ -10,15 +10,16 @@ struct heap_free_list {
};
struct heap {
factor_vm *myvm;
bool secure_gc;
segment *seg;
heap_free_list free;
unordered_map<heap_block *, char *> forwarding;
explicit heap(factor_vm *myvm, cell size);
explicit heap(bool secure_gc_, cell size);
inline heap_block *next_block(heap_block *block)
{
cell next = ((cell)block + block->size);
cell next = ((cell)block + block->size());
if(next == seg->end)
return NULL;
else
@ -42,14 +43,14 @@ struct heap {
void assert_free_block(free_heap_block *block);
free_heap_block *find_free_block(cell size);
free_heap_block *split_free_block(free_heap_block *block, cell size);
heap_block *heap_allot(cell size);
heap_block *heap_allot(cell size, cell type);
void heap_free(heap_block *block);
void mark_block(heap_block *block);
void unmark_marked();
void clear_mark_bits();
void heap_usage(cell *used, cell *total_free, cell *max_free);
cell heap_size();
cell compute_heap_forwarding(unordered_map<heap_block *,char *> &forwarding);
void compact_heap(unordered_map<heap_block *,char *> &forwarding);
cell compute_heap_forwarding();
void compact_heap();
heap_block *free_allocated(heap_block *prev, heap_block *scan);
@ -64,30 +65,28 @@ struct heap {
while(scan)
{
switch(scan->status)
if(scan->type() == FREE_BLOCK_TYPE)
{
case B_ALLOCATED:
prev = free_allocated(prev,scan);
break;
case B_FREE:
if(prev && prev->status == B_FREE)
prev->size += scan->size;
if(prev && prev->type() == FREE_BLOCK_TYPE)
prev->set_size(prev->size() + scan->size());
else
prev = scan;
break;
case B_MARKED:
if(prev && prev->status == B_FREE)
}
else if(scan->marked_p())
{
if(prev && prev->type() == FREE_BLOCK_TYPE)
add_to_free_list((free_heap_block *)prev);
scan->status = B_ALLOCATED;
scan->set_marked_p(false);
prev = scan;
iter(scan);
break;
}
else
prev = free_allocated(prev,scan);
scan = next_block(scan);
}
if(prev && prev->status == B_FREE)
if(prev && prev->type() == FREE_BLOCK_TYPE)
add_to_free_list((free_heap_block *)prev);
}
};

128
vm/image.cpp
View File

@ -21,17 +21,14 @@ void factor_vm::load_data_heap(FILE *file, image_header *h, vm_parameters *p)
if(good_size > p->tenured_size)
p->tenured_size = good_size;
init_data_heap(p->gen_count,
p->young_size,
init_data_heap(p->young_size,
p->aging_size,
p->tenured_size,
p->secure_gc);
clear_gc_stats();
zone *tenured = &data->generations[data->tenured()];
fixnum bytes_read = fread((void*)tenured->start,1,h->data_size,file);
fixnum bytes_read = fread((void*)data->tenured->start,1,h->data_size,file);
if((cell)bytes_read != h->data_size)
{
@ -43,8 +40,7 @@ void factor_vm::load_data_heap(FILE *file, image_header *h, vm_parameters *p)
fatal_error("load_data_heap failed",0);
}
tenured->here = tenured->start + h->data_size;
data_relocation_base = h->data_relocation_base;
data->tenured->here = data->tenured->start + h->data_size;
}
void factor_vm::load_code_heap(FILE *file, image_header *h, vm_parameters *p)
@ -68,7 +64,6 @@ void factor_vm::load_code_heap(FILE *file, image_header *h, vm_parameters *p)
}
}
code_relocation_base = h->code_relocation_base;
code->build_free_list(h->code_size);
}
@ -86,12 +81,10 @@ bool factor_vm::save_image(const vm_char *filename)
return false;
}
zone *tenured = &data->generations[data->tenured()];
h.magic = image_magic;
h.version = image_version;
h.data_relocation_base = tenured->start;
h.data_size = tenured->here - tenured->start;
h.data_relocation_base = data->tenured->start;
h.data_size = data->tenured->here - data->tenured->start;
h.code_relocation_base = code->seg->start;
h.code_size = code->heap_size();
@ -106,7 +99,7 @@ bool factor_vm::save_image(const vm_char *filename)
bool ok = true;
if(fwrite(&h,sizeof(image_header),1,file) != 1) ok = false;
if(fwrite((void*)tenured->start,h.data_size,1,file) != 1) ok = false;
if(fwrite((void*)data->tenured->start,h.data_size,1,file) != 1) ok = false;
if(fwrite(code->first_block(),h.code_size,1,file) != 1) ok = false;
if(fclose(file)) ok = false;
@ -152,37 +145,36 @@ void factor_vm::primitive_save_image_and_exit()
exit(1);
}
void factor_vm::data_fixup(cell *cell)
void factor_vm::data_fixup(cell *handle, cell data_relocation_base)
{
if(immediate_p(*cell))
if(immediate_p(*handle))
return;
zone *tenured = &data->generations[data->tenured()];
*cell += (tenured->start - data_relocation_base);
*handle += (data->tenured->start - data_relocation_base);
}
template<typename Type> void factor_vm::code_fixup(Type **handle)
template<typename Type> void factor_vm::code_fixup(Type **handle, cell code_relocation_base)
{
Type *ptr = *handle;
Type *new_ptr = (Type *)(((cell)ptr) + (code->seg->start - code_relocation_base));
*handle = new_ptr;
}
void factor_vm::fixup_word(word *word)
void factor_vm::fixup_word(word *word, cell code_relocation_base)
{
if(word->code)
code_fixup(&word->code);
code_fixup(&word->code,code_relocation_base);
if(word->profiling)
code_fixup(&word->profiling);
code_fixup(&word->xt);
code_fixup(&word->profiling,code_relocation_base);
code_fixup(&word->xt,code_relocation_base);
}
void factor_vm::fixup_quotation(quotation *quot)
void factor_vm::fixup_quotation(quotation *quot, cell code_relocation_base)
{
if(quot->code)
{
code_fixup(&quot->xt);
code_fixup(&quot->code);
code_fixup(&quot->xt,code_relocation_base);
code_fixup(&quot->code,code_relocation_base);
}
else
quot->xt = (void *)lazy_jit_compile;
@ -190,39 +182,45 @@ void factor_vm::fixup_quotation(quotation *quot)
void factor_vm::fixup_alien(alien *d)
{
d->expired = T;
if(d->base == F) d->expired = T;
}
struct stack_frame_fixupper {
factor_vm *myvm;
cell code_relocation_base;
explicit stack_frame_fixupper(factor_vm *myvm_) : myvm(myvm_) {}
explicit stack_frame_fixupper(factor_vm *myvm_, cell code_relocation_base_) :
myvm(myvm_), code_relocation_base(code_relocation_base_) {}
void operator()(stack_frame *frame)
{
myvm->code_fixup(&frame->xt);
myvm->code_fixup(&FRAME_RETURN_ADDRESS(frame,myvm));
myvm->code_fixup(&frame->xt,code_relocation_base);
myvm->code_fixup(&FRAME_RETURN_ADDRESS(frame,myvm),code_relocation_base);
}
};
void factor_vm::fixup_callstack_object(callstack *stack)
void factor_vm::fixup_callstack_object(callstack *stack, cell code_relocation_base)
{
stack_frame_fixupper fixupper(this);
stack_frame_fixupper fixupper(this,code_relocation_base);
iterate_callstack_object(stack,fixupper);
}
struct object_fixupper {
factor_vm *myvm;
cell data_relocation_base;
explicit object_fixupper(factor_vm *myvm_) : myvm(myvm_) { }
explicit object_fixupper(factor_vm *myvm_, cell data_relocation_base_) :
myvm(myvm_), data_relocation_base(data_relocation_base_) { }
void operator()(cell *scan)
{
myvm->data_fixup(scan);
myvm->data_fixup(scan,data_relocation_base);
}
};
/* Initialize an object in a newly-loaded image */
void factor_vm::relocate_object(object *object)
void factor_vm::relocate_object(object *object,
cell data_relocation_base,
cell code_relocation_base)
{
cell hi_tag = object->h.hi_tag();
@ -232,26 +230,26 @@ void factor_vm::relocate_object(object *object)
if(hi_tag == TUPLE_TYPE)
{
tuple *t = (tuple *)object;
data_fixup(&t->layout);
data_fixup(&t->layout,data_relocation_base);
cell *scan = t->data();
cell *end = (cell *)((cell)object + untagged_object_size(object));
for(; scan < end; scan++)
data_fixup(scan);
data_fixup(scan,data_relocation_base);
}
else
{
object_fixupper fixupper(this);
object_fixupper fixupper(this,data_relocation_base);
do_slots((cell)object,fixupper);
switch(hi_tag)
{
case WORD_TYPE:
fixup_word((word *)object);
fixup_word((word *)object,code_relocation_base);
break;
case QUOTATION_TYPE:
fixup_quotation((quotation *)object);
fixup_quotation((quotation *)object,code_relocation_base);
break;
case DLL_TYPE:
ffi_dlopen((dll *)object);
@ -260,7 +258,7 @@ void factor_vm::relocate_object(object *object)
fixup_alien((alien *)object);
break;
case CALLSTACK_TYPE:
fixup_callstack_object((callstack *)object);
fixup_callstack_object((callstack *)object,code_relocation_base);
break;
}
}
@ -268,54 +266,52 @@ void factor_vm::relocate_object(object *object)
/* Since the image might have been saved with a different base address than
where it is loaded, we need to fix up pointers in the image. */
void factor_vm::relocate_data()
void factor_vm::relocate_data(cell data_relocation_base, cell code_relocation_base)
{
cell relocating;
for(cell i = 0; i < USER_ENV; i++)
data_fixup(&userenv[i],data_relocation_base);
cell i;
for(i = 0; i < USER_ENV; i++)
data_fixup(&userenv[i]);
data_fixup(&T,data_relocation_base);
data_fixup(&bignum_zero,data_relocation_base);
data_fixup(&bignum_pos_one,data_relocation_base);
data_fixup(&bignum_neg_one,data_relocation_base);
data_fixup(&T);
data_fixup(&bignum_zero);
data_fixup(&bignum_pos_one);
data_fixup(&bignum_neg_one);
cell obj = data->tenured->start;
zone *tenured = &data->generations[data->tenured()];
for(relocating = tenured->start;
relocating < tenured->here;
relocating += untagged_object_size((object *)relocating))
while(obj)
{
object *obj = (object *)relocating;
allot_barrier(obj);
relocate_object(obj);
relocate_object((object *)obj,data_relocation_base,code_relocation_base);
data->tenured->record_object_start_offset((object *)obj);
obj = data->tenured->next_object_after(this,obj);
}
}
void factor_vm::fixup_code_block(code_block *compiled)
void factor_vm::fixup_code_block(code_block *compiled, cell data_relocation_base)
{
/* relocate literal table data */
data_fixup(&compiled->relocation);
data_fixup(&compiled->literals);
data_fixup(&compiled->owner,data_relocation_base);
data_fixup(&compiled->literals,data_relocation_base);
data_fixup(&compiled->relocation,data_relocation_base);
relocate_code_block(compiled);
}
struct code_block_fixupper {
factor_vm *myvm;
cell data_relocation_base;
code_block_fixupper(factor_vm *myvm_) : myvm(myvm_) { }
code_block_fixupper(factor_vm *myvm_, cell data_relocation_base_) :
myvm(myvm_), data_relocation_base(data_relocation_base_) { }
void operator()(code_block *compiled)
{
myvm->fixup_code_block(compiled);
myvm->fixup_code_block(compiled,data_relocation_base);
}
};
void factor_vm::relocate_code()
void factor_vm::relocate_code(cell data_relocation_base)
{
code_block_fixupper fixupper(this);
code_block_fixupper fixupper(this,data_relocation_base);
iterate_code_heap(fixupper);
}
@ -348,8 +344,8 @@ void factor_vm::load_image(vm_parameters *p)
init_objects(&h);
relocate_data();
relocate_code();
relocate_data(h.data_relocation_base,h.code_relocation_base);
relocate_code(h.data_relocation_base);
/* Store image path name */
userenv[IMAGE_ENV] = allot_alien(F,(cell)p->image_path);

3
vm/image.hpp
View File

@ -32,12 +32,11 @@ struct vm_parameters {
const vm_char *image_path;
const vm_char *executable_path;
cell ds_size, rs_size;
cell gen_count, young_size, aging_size, tenured_size;
cell young_size, aging_size, tenured_size;
cell code_size;
bool secure_gc;
bool fep;
bool console;
bool stack_traces;
cell max_pic_size;
};

8
vm/inline_cache.cpp
View File

@ -6,6 +6,10 @@ namespace factor
void factor_vm::init_inline_caching(int max_size)
{
max_pic_size = max_size;
cold_call_to_ic_transitions = 0;
ic_to_pic_transitions = 0;
pic_to_mega_transitions = 0;
for(int i = 0; i < 4; i++) pic_counts[i] = 0;
}
void factor_vm::deallocate_inline_cache(cell return_address)
@ -15,7 +19,7 @@ void factor_vm::deallocate_inline_cache(cell return_address)
check_code_pointer((cell)old_xt);
code_block *old_block = (code_block *)old_xt - 1;
cell old_type = old_block->type;
cell old_type = old_block->type();
#ifdef FACTOR_DEBUG
/* The call target was either another PIC,
@ -24,7 +28,7 @@ void factor_vm::deallocate_inline_cache(cell return_address)
#endif
if(old_type == PIC_TYPE)
code->heap_free(old_block);
code->code_heap_free(old_block);
}
/* Figure out what kind of type check the PIC needs based on the methods

5
vm/jit.cpp
View File

@ -20,9 +20,7 @@ jit::jit(cell type_, cell owner_, factor_vm *vm)
position(0),
offset(0),
parent_vm(vm)
{
if(parent_vm->stack_traces_p()) literal(owner.value());
}
{}
void jit::emit_relocation(cell code_template_)
{
@ -106,6 +104,7 @@ code_block *jit::to_code_block()
type,
code.elements.value(),
F, /* no labels */
owner.value(),
relocation.elements.value(),
literals.elements.value());
}

51
vm/layouts.hpp
View File

@ -64,8 +64,9 @@ inline static cell align8(cell a)
#define TYPE_COUNT 15
/* Not a real type, but code_block's type field can be set to this */
#define PIC_TYPE 69
/* Not real types, but code_block's type can be set to this */
#define PIC_TYPE 16
#define FREE_BLOCK_TYPE 17
/* Constants used when floating-point trap exceptions are thrown */
enum
@ -196,34 +197,46 @@ struct string : public object {
};
/* The compiled code heap is structured into blocks. */
enum block_status
{
B_FREE,
B_ALLOCATED,
B_MARKED
};
struct heap_block
{
unsigned char status; /* free or allocated? */
unsigned char type; /* this is WORD_TYPE or QUOTATION_TYPE */
unsigned char last_scan; /* the youngest generation in which this block's literals may live */
unsigned char needs_fixup; /* is this a new block that needs full fixup? */
/* Bit 0: mark
Bit 1-7: type
Bit 8-...: size */
cell header;
/* In bytes, includes this header */
cell size;
bool marked_p() { return header & 1; }
void set_marked_p(bool marked)
{
if(marked)
header |= 1;
else
header &= ~1;
}
cell type() { return (header >> 1) & 0x1f; }
void set_type(cell type)
{
header = ((header & ~(0x1f << 1)) | (type << 1));
}
cell size() { return (header >> 6); }
void set_size(cell size)
{
header = (header & 0x2f) | (size << 6);
}
};
struct free_heap_block : public heap_block
{
free_heap_block *next_free;
free_heap_block *next_free;
};
struct code_block : public heap_block
{
cell literals; /* # bytes */
cell owner; /* tagged pointer to word, quotation or f */
cell literals; /* tagged pointer to array or f */
cell relocation; /* tagged pointer to byte-array or f */
void *xt() { return (void *)(this + 1); }
};
@ -292,7 +305,7 @@ struct quotation : public object {
struct alien : public object {
static const cell type_number = ALIEN_TYPE;
/* tagged */
cell alien;
cell base;
/* tagged */
cell expired;
/* untagged */

5
vm/local_roots.cpp
View File

@ -1,5 +0,0 @@
#include "master.hpp"
namespace factor
{
}

19
vm/master.hpp
View File

@ -24,8 +24,9 @@
#include <time.h>
/* C++ headers */
#include <vector>
#include <algorithm>
#include <set>
#include <vector>
#if __GNUC__ == 4
#include <tr1/unordered_map>
@ -64,9 +65,13 @@ namespace factor
#include "bignumint.hpp"
#include "bignum.hpp"
#include "code_block.hpp"
#include "data_heap.hpp"
#include "zone.hpp"
#include "write_barrier.hpp"
#include "data_gc.hpp"
#include "old_space.hpp"
#include "aging_space.hpp"
#include "tenured_space.hpp"
#include "data_heap.hpp"
#include "gc.hpp"
#include "debug.hpp"
#include "strings.hpp"
#include "tuples.hpp"
@ -76,15 +81,21 @@ namespace factor
#include "heap.hpp"
#include "image.hpp"
#include "alien.hpp"
#include "code_heap.hpp"
#include "vm.hpp"
#include "tagged.hpp"
#include "local_roots.hpp"
#include "collector.hpp"
#include "copying_collector.hpp"
#include "nursery_collector.hpp"
#include "aging_collector.hpp"
#include "to_tenured_collector.hpp"
#include "full_collector.hpp"
#include "callstack.hpp"
#include "generic_arrays.hpp"
#include "arrays.hpp"
#include "math.hpp"
#include "booleans.hpp"
#include "code_heap.hpp"
#include "byte_arrays.hpp"
#include "jit.hpp"
#include "quotations.hpp"

30
vm/nursery_collector.cpp Normal file
View File

@ -0,0 +1,30 @@
#include "master.hpp"
namespace factor
{
nursery_collector::nursery_collector(factor_vm *myvm_) :
copying_collector<aging_space,nursery_policy>
(myvm_,myvm_->data->aging,nursery_policy(myvm_)) {}
void factor_vm::collect_nursery()
{
nursery_collector collector(this);
collector.trace_roots();
collector.trace_contexts();
collector.trace_cards(data->tenured,
card_points_to_nursery,
simple_unmarker(card_points_to_nursery));
collector.trace_cards(data->aging,
card_points_to_nursery,
simple_unmarker(card_mark_mask));
collector.trace_code_heap_roots(&code->points_to_nursery);
collector.cheneys_algorithm();
update_dirty_code_blocks(&code->points_to_nursery);
nursery.here = nursery.start;
code->points_to_nursery.clear();
}
}

19
vm/nursery_collector.hpp Normal file
View File

@ -0,0 +1,19 @@
namespace factor
{
struct nursery_policy {
factor_vm *myvm;
nursery_policy(factor_vm *myvm_) : myvm(myvm_) {}
bool should_copy_p(object *untagged)
{
return myvm->nursery.contains_p(untagged);
}
};
struct nursery_collector : copying_collector<aging_space,nursery_policy> {
nursery_collector(factor_vm *myvm_);
};
}

49
vm/old_space.cpp Normal file
View File

@ -0,0 +1,49 @@
#include "master.hpp"
namespace factor
{
old_space::old_space(cell size_, cell start_) : zone(size_,start_)
{
cell cards_size = size_ >> card_bits;
object_start_offsets = new card[cards_size];
object_start_offsets_end = object_start_offsets + cards_size;
}
old_space::~old_space()
{
delete[] object_start_offsets;
}
/* we need to remember the first object allocated in the card */
void old_space::record_object_start_offset(object *obj)
{
card *ptr = (card *)((((cell)obj - start) >> card_bits) + (cell)object_start_offsets);
if(*ptr == card_starts_inside_object)
*ptr = ((cell)obj & addr_card_mask);
}
object *old_space::allot(cell size)
{
if(here + size > end) return NULL;
object *obj = zone::allot(size);
record_object_start_offset(obj);
return obj;
}
void old_space::clear_object_start_offsets()
{
memset(object_start_offsets,card_starts_inside_object,size >> card_bits);
}
cell old_space::next_object_after(factor_vm *myvm, cell scan)
{
cell size = myvm->untagged_object_size((object *)scan);
if(scan + size < here)
return scan + size;
else
return NULL;
}
}

24
vm/old_space.hpp Normal file
View File

@ -0,0 +1,24 @@
namespace factor
{
static const cell card_starts_inside_object = 0xff;
struct old_space : zone {
card *object_start_offsets;
card *object_start_offsets_end;
old_space(cell size_, cell start_);
~old_space();
cell first_object_in_card(cell address)
{
return object_start_offsets[(address - start) >> card_bits];
}
void record_object_start_offset(object *obj);
object *allot(cell size);
void clear_object_start_offsets();
cell next_object_after(factor_vm *myvm, cell scan);
};
}

6
vm/os-unix.cpp
View File

@ -83,9 +83,8 @@ void factor_vm::primitive_existsp()
box_boolean(stat(path,&sb) >= 0);
}
segment::segment(factor_vm *myvm_, cell size_)
segment::segment(cell size_)
{
myvm = myvm_;
size = size_;
int pagesize = getpagesize();
@ -94,8 +93,7 @@ segment::segment(factor_vm *myvm_, cell size_)
PROT_READ | PROT_WRITE | PROT_EXEC,
MAP_ANON | MAP_PRIVATE,-1,0);
if(array == (char*)-1)
myvm->out_of_memory();
if(array == (char*)-1) out_of_memory();
if(mprotect(array,pagesize,PROT_NONE) == -1)
fatal_error("Cannot protect low guard page",(cell)array);

5
vm/os-windows.cpp
View File

@ -96,9 +96,8 @@ void factor_vm::primitive_existsp()
box_boolean(windows_stat(path));
}
segment::segment(factor_vm *myvm_, cell size_)
segment::segment(cell size_)
{
myvm = myvm_;
size = size_;
char *mem;
@ -106,7 +105,7 @@ segment::segment(factor_vm *myvm_, cell size_)
if((mem = (char *)VirtualAlloc(NULL, getpagesize() * 2 + size,
MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == 0)
myvm->out_of_memory();
out_of_memory();
if (!VirtualProtect(mem, getpagesize(), PAGE_NOACCESS, &ignore))
fatal_error("Cannot allocate low guard page", (cell)mem);

2
vm/primitives.cpp
View File

@ -164,6 +164,7 @@ const primitive_type primitives[] = {
primitive_optimized_p,
primitive_quot_compiled_p,
primitive_vm_ptr,
primitive_strip_stack_traces,
};
PRIMITIVE_FORWARD(bignum_to_fixnum)
@ -289,5 +290,6 @@ PRIMITIVE_FORWARD(inline_cache_stats)
PRIMITIVE_FORWARD(optimized_p)
PRIMITIVE_FORWARD(quot_compiled_p)
PRIMITIVE_FORWARD(vm_ptr)
PRIMITIVE_FORWARD(strip_stack_traces)
}

1
vm/primitives.hpp
View File

@ -172,5 +172,6 @@ PRIMITIVE(inline_cache_stats);
PRIMITIVE(optimized_p);
PRIMITIVE(quot_compiled_p);
PRIMITIVE(vm_ptr);
PRIMITIVE(strip_stack_traces);
}

4
vm/profiler.cpp
View File

@ -43,9 +43,7 @@ void factor_vm::set_profiling(bool profiling)
update_word_xt(word.value());
}
/* Update XTs in code heap */
word_updater updater(this);
iterate_code_heap(updater);
update_code_heap_words();
}
void factor_vm::primitive_profiling()

6
vm/quotations.cpp
View File

@ -281,7 +281,7 @@ void quotation_jit::iterate_quotation()
void factor_vm::set_quot_xt(quotation *quot, code_block *code)
{
if(code->type != QUOTATION_TYPE)
if(code->type() != QUOTATION_TYPE)
critical_error("Bad param to set_quot_xt",(cell)code);
quot->code = code;
@ -343,9 +343,7 @@ void factor_vm::compile_all_words()
}
/* Update XTs in code heap */
word_updater updater(this);
iterate_code_heap(updater);
update_code_heap_words();
}
/* Allocates memory */

4
vm/run.hpp
View File

@ -87,8 +87,6 @@ enum special_object {
THREADS_ENV = 64,
RUN_QUEUE_ENV = 65,
SLEEP_QUEUE_ENV = 66,
STACK_TRACES_ENV = 67,
};
#define FIRST_SAVE_ENV BOOT_ENV
@ -96,7 +94,7 @@ enum special_object {
inline static bool save_env_p(cell i)
{
return (i >= FIRST_SAVE_ENV && i <= LAST_SAVE_ENV) || i == STACK_TRACES_ENV;
return (i >= FIRST_SAVE_ENV && i <= LAST_SAVE_ENV);
}
}

3
vm/segments.hpp
View File

@ -9,12 +9,11 @@ inline cell align_page(cell a)
/* segments set up guard pages to check for under/overflow.
size must be a multiple of the page size */
struct segment {
factor_vm *myvm;
cell start;
cell size;
cell end;
explicit segment(factor_vm *myvm, cell size);
explicit segment(cell size);
~segment();
};

Some files were not shown because too many files have changed in this diff Show More