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-05-05 17:14:51 -07:00
parent 5eb51aa0b3 58d0e17936
commit 513df36002
95 changed files with 457 additions and 351 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
README.txt
View File

@ -20,25 +20,18 @@ implementation. It is not an introduction to the language itself.
* Compiling the Factor VM * Compiling the Factor VM
The Factor runtime is written in GNU C++, and is built with GNU make and
gcc.
Factor supports various platforms. For an up-to-date list, see Factor supports various platforms. For an up-to-date list, see
<http://factorcode.org>. <http://factorcode.org>.
Factor requires gcc 3.4 or later. 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
On x86, Factor /will not/ build using gcc 3.3 or earlier. uses std::tr1::unordered_map which is shipped as part of GCC.
If you are using gcc 4.3, you might get an unusable Factor binary unless
you add 'SITE_CFLAGS=-fno-forward-propagate' to the command-line
arguments for make.
Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM. Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM.
* Bootstrapping the Factor image * Bootstrapping the Factor image
Once you have compiled the Factor runtime, you must bootstrap the Factor Once you have compiled the Factor VM, you must bootstrap the Factor
system using the image that corresponds to your CPU architecture. system using the image that corresponds to your CPU architecture.
Boot images can be obtained from <http://factorcode.org/images/latest/>. Boot images can be obtained from <http://factorcode.org/images/latest/>.
@ -97,7 +90,7 @@ When compiling Factor, pass the X11=1 parameter:
Then bootstrap with the following switches: Then bootstrap with the following switches:
./factor -i=boot.<cpu>.image -ui-backend=x11 -ui-text-backend=pango ./factor -i=boot.<cpu>.image -ui-backend=x11
Now if $DISPLAY is set, running ./factor will start the UI. Now if $DISPLAY is set, running ./factor will start the UI.
@ -138,7 +131,7 @@ usage documentation, enter the following in the UI listener:
The Factor source tree is organized as follows: The Factor source tree is organized as follows:
build-support/ - scripts used for compiling Factor build-support/ - scripts used for compiling Factor
vm/ - sources for the Factor VM, written in C++ vm/ - Factor VM
core/ - Factor core library core/ - Factor core library
basis/ - Factor basis library, compiler, tools basis/ - Factor basis library, compiler, tools
extra/ - more libraries and applications extra/ - more libraries and applications

8
basis/alien/c-types/c-types.factor
View File

@ -409,10 +409,10 @@ CONSTANT: primitive-types
"uchar" define-primitive-type "uchar" define-primitive-type
<c-type> <c-type>
[ alien-unsigned-4 zero? not ] >>getter [ alien-unsigned-1 zero? not ] >>getter
[ [ 1 0 ? ] 2dip set-alien-unsigned-4 ] >>setter [ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter
4 >>size 1 >>size
4 >>align 1 >>align
"box_boolean" >>boxer "box_boolean" >>boxer
"to_boolean" >>unboxer "to_boolean" >>unboxer
"bool" define-primitive-type "bool" define-primitive-type

2
basis/alien/libraries/libraries.factor Normal file → Executable file
View File

@ -5,7 +5,7 @@ IN: alien.libraries
: dlopen ( path -- dll ) native-string>alien (dlopen) ; : dlopen ( path -- dll ) native-string>alien (dlopen) ;
: dlsym ( name dll -- alien ) [ native-string>alien ] dip (dlsym) ; : dlsym ( name dll -- alien ) [ string>symbol ] dip (dlsym) ;
SYMBOL: libraries SYMBOL: libraries

2
basis/bootstrap/compiler/compiler.factor Normal file → Executable file
View File

@ -41,7 +41,7 @@ nl
! which are also quick to compile are replaced by ! which are also quick to compile are replaced by
! compiled definitions as soon as possible. ! compiled definitions as soon as possible.
{ {
roll -roll declare not not
array? hashtable? vector? array? hashtable? vector?
tuple? sbuf? tombstone? tuple? sbuf? tombstone?

12
basis/cocoa/cocoa.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2006 Slava Pestov ! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: compiler io kernel cocoa.runtime cocoa.subclassing USING: compiler io kernel cocoa.runtime cocoa.subclassing
cocoa.messages cocoa.types sequences words vocabs parser cocoa.messages cocoa.types sequences words vocabs parser
@ -27,22 +27,16 @@ SYMBOL: frameworks
frameworks [ V{ } clone ] initialize frameworks [ V{ } clone ] initialize
[ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook [ frameworks get [ load-framework ] each ] "cocoa" add-init-hook
SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ; SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ;
SYNTAX: IMPORT: scan [ ] import-objc-class ; SYNTAX: IMPORT: scan [ ] import-objc-class ;
"Compiling Objective C bridge..." print "Importing Cocoa classes..." print
"cocoa.classes" create-vocab drop "cocoa.classes" create-vocab drop
{
"cocoa" "cocoa.runtime" "cocoa.messages" "cocoa.subclassing"
} [ words ] map concat compile
"Importing Cocoa classes..." print
[ [
{ {
"NSApplication" "NSApplication"

17
basis/compiler/compiler.factor
View File

@ -112,19 +112,18 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
} cond ; } cond ;
: optimize? ( word -- ? ) : optimize? ( word -- ? )
{ { [ predicate-engine-word? ] [ single-generic? ] } 1|| not ;
[ predicate-engine-word? ]
[ contains-breakpoints? ] : contains-breakpoints? ( -- ? )
[ single-generic? ] dependencies get keys [ "break?" word-prop ] any? ;
} 1|| not ;
: frontend ( word -- nodes ) : frontend ( word -- nodes )
#! If the word contains breakpoints, don't optimize it, since #! If the word contains breakpoints, don't optimize it, since
#! the walker does not support this. #! the walker does not support this.
dup optimize? dup optimize? [
[ [ build-tree ] [ deoptimize ] recover optimize-tree ] [ [ build-tree ] [ deoptimize ] recover optimize-tree ] keep
[ dup def>> deoptimize-with ] contains-breakpoints? [ nip dup def>> deoptimize-with ] [ drop ] if
if ; ] [ dup def>> deoptimize-with ] if ;
: compile-dependency ( word -- ) : compile-dependency ( word -- )
#! If a word calls an unoptimized word, try to compile the callee. #! If a word calls an unoptimized word, try to compile the callee.

2
basis/compiler/constants/constants.factor
View File

@ -23,7 +23,7 @@ CONSTANT: deck-bits 18
: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline : quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline
: word-code-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline : word-code-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
: array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline : array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline
: compiled-header-size ( -- n ) 5 bootstrap-cells ; inline : compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
! Relocation classes ! Relocation classes
CONSTANT: rc-absolute-cell 0 CONSTANT: rc-absolute-cell 0

13
basis/compiler/tests/alien.factor
View File

@ -588,3 +588,16 @@ FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
C{ 1.0 2.0 } C{ 1.0 2.0 }
C{ 1.5 1.0 } ffi_test_47 C{ 1.5 1.0 } ffi_test_47
] unit-test ] unit-test
! Reported by jedahu
C-STRUCT: bool-field-test
{ "char*" "name" }
{ "bool" "on" }
{ "short" "parents" } ;
FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
[ 123 ] [
"bool-field-test" <c-object> 123 over set-bool-field-test-parents
ffi_test_48
] unit-test

2
basis/compiler/tree/builder/builder.factor
View File

@ -65,5 +65,3 @@ PRIVATE>
] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover
] with-variable ; ] with-variable ;
: contains-breakpoints? ( word -- ? )
def>> [ word? ] filter [ "break?" word-prop ] any? ;

6
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -157,11 +157,7 @@ DEFER: (flat-length)
] sum-outputs ; ] sum-outputs ;
: should-inline? ( #call word -- ? ) : should-inline? ( #call word -- ? )
{ dup inline? [ 2drop t ] [ inlining-rank 5 >= ] if ;
{ [ dup contains-breakpoints? ] [ 2drop f ] }
{ [ dup "inline" word-prop ] [ 2drop t ] }
[ inlining-rank 5 >= ]
} cond ;
SYMBOL: history SYMBOL: history

6
basis/literals/literals-tests.factor Normal file → Executable file
View File

@ -20,8 +20,10 @@ IN: literals.tests
[ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test [ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test
<<
CONSTANT: constant-a 3 CONSTANT: constant-a 3
>>
[ { 3 10 "ftw" } ] [ ${ constant-a 10 "ftw" } ] unit-test [ { 3 10 "ftw" } ] [ ${ constant-a 10 "ftw" } ] unit-test
: sixty-nine ( -- a b ) 6 9 ;
[ { 6 9 } ] [ ${ sixty-nine } ] unit-test

19
basis/literals/literals.factor Normal file → Executable file
View File

@ -1,8 +1,21 @@
! (c) Joe Groff, see license for details ! (c) Joe Groff, see license for details
USING: accessors continuations kernel parser words quotations USING: accessors continuations kernel parser words quotations
combinators.smart vectors sequences ; combinators.smart vectors sequences fry ;
IN: literals IN: literals
SYNTAX: $ scan-word [ def>> call ] curry with-datastack >vector ; <PRIVATE
! Use def>> call so that CONSTANT:s defined in the same file can
! be called
: expand-literal ( seq obj -- seq' )
'[ _ dup word? [ def>> call ] when ] with-datastack ;
: expand-literals ( seq -- seq' )
[ [ { } ] dip expand-literal ] map concat ;
PRIVATE>
SYNTAX: $ scan-word expand-literal >vector ;
SYNTAX: $[ parse-quotation with-datastack >vector ; SYNTAX: $[ parse-quotation with-datastack >vector ;
SYNTAX: ${ \ } [ [ ?execute ] { } map-as ] parse-literal ; SYNTAX: ${ \ } [ expand-literals ] parse-literal ;

2
basis/math/polynomials/polynomials.factor
View File

@ -16,7 +16,7 @@ IN: math.polynomials
PRIVATE> PRIVATE>
: powers ( n x -- seq ) : powers ( n x -- seq )
<array> 1 [ * ] accumulate nip ; <repetition> 1 [ * ] accumulate nip ;
: p= ( p q -- ? ) pextend = ; : p= ( p q -- ? ) pextend = ;

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

@ -651,7 +651,7 @@ M: object infer-call*
\ become { array array } { } define-primitive \ become { array array } { } define-primitive
\ innermost-frame-quot { callstack } { quotation } define-primitive \ innermost-frame-executing { callstack } { object } define-primitive
\ innermost-frame-scan { callstack } { fixnum } define-primitive \ innermost-frame-scan { callstack } { fixnum } define-primitive

30
basis/tools/continuations/continuations.factor
View File

@ -4,7 +4,7 @@ USING: threads kernel namespaces continuations combinators
sequences math namespaces.private continuations.private sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words concurrency.messaging quotations kernel.private words
sequences.private assocs models models.arrow arrays accessors sequences.private assocs models models.arrow arrays accessors
generic generic.single definitions make sbufs tools.crossref ; generic generic.single definitions make sbufs tools.crossref fry ;
IN: tools.continuations IN: tools.continuations
<PRIVATE <PRIVATE
@ -79,21 +79,18 @@ M: object add-breakpoint ;
(step-into-call-next-method) (step-into-call-next-method)
} [ t "no-compile" set-word-prop ] each >> } [ t "no-compile" set-word-prop ] each >>
: >innermost-frame< ( callstack -- n quot )
[ innermost-frame-scan 1 + ] [ innermost-frame-executing ] bi ;
: (change-frame) ( callstack quot -- callstack' )
[ dup innermost-frame-executing quotation? ] dip '[
clone [ >innermost-frame< @ ] [ set-innermost-frame-quot ] [ ] tri
] when ; inline
: change-frame ( continuation quot -- continuation' ) : change-frame ( continuation quot -- continuation' )
#! Applies quot to innermost call frame of the #! Applies quot to innermost call frame of the
#! continuation. #! continuation.
[ clone ] dip [ [ clone ] dip '[ _ (change-frame) ] change-call ; inline
[ clone ] dip
[
[
[ innermost-frame-scan 1+ ]
[ innermost-frame-quot ] bi
] dip call
]
[ drop set-innermost-frame-quot ]
[ drop ]
2tri
] curry change-call ; inline
PRIVATE> PRIVATE>
@ -109,7 +106,6 @@ PRIVATE>
: continuation-step-out ( continuation -- continuation' ) : continuation-step-out ( continuation -- continuation' )
[ nip \ break suffix ] change-frame ; [ nip \ break suffix ] change-frame ;
{ {
{ call [ (step-into-quot) ] } { call [ (step-into-quot) ] }
{ dip [ (step-into-dip) ] } { dip [ (step-into-dip) ] }
@ -124,7 +120,7 @@ PRIVATE>
! Never step into these words ! Never step into these words
: don't-step-into ( word -- ) : don't-step-into ( word -- )
dup [ execute break ] curry "step-into" set-word-prop ; dup '[ _ execute break ] "step-into" set-word-prop ;
{ {
>n ndrop >c c> >n ndrop >c c>
@ -151,6 +147,4 @@ PRIVATE>
] change-frame ; ] change-frame ;
: continuation-current ( continuation -- obj ) : continuation-current ( continuation -- obj )
call>> call>> >innermost-frame< ?nth ;
[ innermost-frame-scan 1+ ]
[ innermost-frame-quot ] bi ?nth ;

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

@ -346,13 +346,6 @@ IN: tools.deploy.shaker
: compress-wrappers ( -- ) : compress-wrappers ( -- )
[ wrapper? ] [ ] "wrappers" compress ; [ wrapper? ] [ ] "wrappers" compress ;
: finish-deploy ( final-image -- )
"Finishing up" show
V{ } set-namestack
V{ } set-catchstack
"Saving final image" show
save-image-and-exit ;
SYMBOL: deploy-vocab SYMBOL: deploy-vocab
: [:c] ( -- word ) ":c" "debugger" lookup ; : [:c] ( -- word ) ":c" "debugger" lookup ;
@ -437,7 +430,8 @@ SYMBOL: deploy-vocab
"Vocabulary has no MAIN: word." print flush 1 exit "Vocabulary has no MAIN: word." print flush 1 exit
] unless ] unless
strip strip
finish-deploy "Saving final image" show
save-image-and-exit
] deploy-error-handler ] deploy-error-handler
] bind ; ] bind ;

9
basis/tools/disassembler/udis/udis-tests.factor Normal file
View File

@ -0,0 +1,9 @@
IN: tools.disassembler.udis.tests
USING: tools.disassembler.udis tools.test alien.c-types system combinators kernel ;
{
{ [ os linux? cpu x86.64? and ] [ [ 656 ] [ "ud" heap-size ] unit-test ] }
{ [ os macosx? cpu x86.32? and ] [ [ 592 ] [ "ud" heap-size ] unit-test ] }
{ [ os macosx? cpu x86.64? and ] [ [ 656 ] [ "ud" heap-size ] unit-test ] }
[ ]
} cond

52
basis/tools/disassembler/udis/udis.factor
View File

@ -16,7 +16,57 @@ IN: tools.disassembler.udis
LIBRARY: libudis86 LIBRARY: libudis86
TYPEDEF: char[592] ud C-STRUCT: ud_operand
{ "int" "type" }
{ "uchar" "size" }
{ "ulonglong" "lval" }
{ "int" "base" }
{ "int" "index" }
{ "uchar" "offset" }
{ "uchar" "scale" } ;
C-STRUCT: ud
{ "void*" "inp_hook" }
{ "uchar" "inp_curr" }
{ "uchar" "inp_fill" }
{ "FILE*" "inp_file" }
{ "uchar" "inp_ctr" }
{ "uchar*" "inp_buff" }
{ "uchar*" "inp_buff_end" }
{ "uchar" "inp_end" }
{ "void*" "translator" }
{ "ulonglong" "insn_offset" }
{ "char[32]" "insn_hexcode" }
{ "char[64]" "insn_buffer" }
{ "uint" "insn_fill" }
{ "uchar" "dis_mode" }
{ "ulonglong" "pc" }
{ "uchar" "vendor" }
{ "struct map_entry*" "mapen" }
{ "int" "mnemonic" }
{ "ud_operand[3]" "operand" }
{ "uchar" "error" }
{ "uchar" "pfx_rex" }
{ "uchar" "pfx_seg" }
{ "uchar" "pfx_opr" }
{ "uchar" "pfx_adr" }
{ "uchar" "pfx_lock" }
{ "uchar" "pfx_rep" }
{ "uchar" "pfx_repe" }
{ "uchar" "pfx_repne" }
{ "uchar" "pfx_insn" }
{ "uchar" "default64" }
{ "uchar" "opr_mode" }
{ "uchar" "adr_mode" }
{ "uchar" "br_far" }
{ "uchar" "br_near" }
{ "uchar" "implicit_addr" }
{ "uchar" "c1" }
{ "uchar" "c2" }
{ "uchar" "c3" }
{ "uchar[256]" "inp_cache" }
{ "uchar[64]" "inp_sess" }
{ "ud_itab_entry*" "itab_entry" } ;
FUNCTION: void ud_translate_intel ( ud* u ) ; FUNCTION: void ud_translate_intel ( ud* u ) ;
FUNCTION: void ud_translate_att ( ud* u ) ; FUNCTION: void ud_translate_att ( ud* u ) ;

16
basis/tools/walker/walker-tests.factor
View File

@ -2,7 +2,7 @@ USING: tools.walker io io.streams.string kernel math
math.private namespaces prettyprint sequences tools.test math.private namespaces prettyprint sequences tools.test
continuations math.parser threads arrays tools.walker.debug continuations math.parser threads arrays tools.walker.debug
generic.single sequences.private kernel.private generic.single sequences.private kernel.private
tools.continuations accessors words ; tools.continuations accessors words combinators ;
IN: tools.walker.tests IN: tools.walker.tests
[ { } ] [ [ { } ] [
@ -132,3 +132,17 @@ M: method-breakpoint-tuple method-breakpoint-test break drop 1 2 + ;
[ { 3 } ] [ { 3 } ]
[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] test-walker ] unit-test [ [ T{ method-breakpoint-tuple } method-breakpoint-test ] test-walker ] unit-test
: case-breakpoint-test ( -- x )
5 { [ break 1 + ] } case ;
\ case-breakpoint-test don't-step-into
[ { 6 } ] [ [ case-breakpoint-test ] test-walker ] unit-test
: call(-breakpoint-test ( -- x )
[ break 1 ] call( -- x ) 2 + ;
\ call(-breakpoint-test don't-step-into
[ { 3 } ] [ [ call(-breakpoint-test ] test-walker ] unit-test

27
core/alien/strings/strings.factor
View File

@ -34,25 +34,32 @@ M: string string>alien
HOOK: alien>native-string os ( alien -- string ) HOOK: alien>native-string os ( alien -- string )
HOOK: native-string>alien os ( string -- alien )
M: windows alien>native-string utf16n alien>string ; M: windows alien>native-string utf16n alien>string ;
M: wince native-string>alien utf16n string>alien ;
M: winnt native-string>alien utf8 string>alien ;
M: unix alien>native-string utf8 alien>string ; M: unix alien>native-string utf8 alien>string ;
HOOK: native-string>alien os ( string -- alien )
M: windows native-string>alien utf16n string>alien ;
M: unix native-string>alien utf8 string>alien ; M: unix native-string>alien utf8 string>alien ;
: dll-path ( dll -- string ) : dll-path ( dll -- string )
path>> alien>native-string ; path>> alien>native-string ;
: string>symbol ( str -- alien ) HOOK: string>symbol* os ( str/seq -- alien )
dup string?
[ native-string>alien ] M: winnt string>symbol* utf8 string>alien ;
[ [ native-string>alien ] map ] if ;
M: wince string>symbol* utf16n string>alien ;
M: unix string>symbol* utf8 string>alien ;
GENERIC: string>symbol ( str -- alien )
M: string string>symbol string>symbol* ;
M: sequence string>symbol [ string>symbol* ] map ;
[ [
8 getenv utf8 alien>string string>cpu \ cpu set-global 8 getenv utf8 alien>string string>cpu \ cpu set-global

2
core/bootstrap/primitives.factor
View File

@ -493,7 +493,7 @@ tuple
{ "(sleep)" "threads.private" (( us -- )) } { "(sleep)" "threads.private" (( us -- )) }
{ "<tuple-boa>" "classes.tuple.private" (( ... layout -- tuple )) } { "<tuple-boa>" "classes.tuple.private" (( ... layout -- tuple )) }
{ "callstack>array" "kernel" (( callstack -- array )) } { "callstack>array" "kernel" (( callstack -- array )) }
{ "innermost-frame-quot" "kernel.private" (( callstack -- quot )) } { "innermost-frame-executing" "kernel.private" (( callstack -- obj )) }
{ "innermost-frame-scan" "kernel.private" (( callstack -- n )) } { "innermost-frame-scan" "kernel.private" (( callstack -- n )) }
{ "set-innermost-frame-quot" "kernel.private" (( n callstack -- )) } { "set-innermost-frame-quot" "kernel.private" (( n callstack -- )) }
{ "call-clear" "kernel" (( quot -- )) } { "call-clear" "kernel" (( quot -- )) }

6
core/checksums/crc32/crc32.factor
View File

@ -12,12 +12,12 @@ CONSTANT: crc32-table V{ }
256 iota [ 256 iota [
8 [ 8 [
[ 2/ ] [ even? ] bi [ crc32-polynomial bitxor ] unless [ 2/ ] [ even? ] bi [ crc32-polynomial bitxor ] unless
] times >bignum ] times
] map 0 crc32-table copy ] map 0 crc32-table copy
: (crc32) ( crc ch -- crc ) : (crc32) ( crc ch -- crc )
>bignum dupd bitxor dupd bitxor
mask-byte crc32-table nth-unsafe >bignum mask-byte crc32-table nth-unsafe
swap -8 shift bitxor ; inline swap -8 shift bitxor ; inline
SINGLETON: crc32 SINGLETON: crc32

2
core/continuations/continuations-tests.factor
View File

@ -64,7 +64,7 @@ IN: continuations.tests
[ 1 2 ] [ bar ] unit-test [ 1 2 ] [ bar ] unit-test
[ t ] [ \ bar def>> "c" get innermost-frame-quot = ] unit-test [ t ] [ \ bar def>> "c" get innermost-frame-executing = ] unit-test
[ 1 ] [ "c" get innermost-frame-scan ] unit-test [ 1 ] [ "c" get innermost-frame-scan ] unit-test

4
core/generic/standard/standard.factor
View File

@ -8,9 +8,7 @@ IN: generic.standard
TUPLE: standard-combination < single-combination # ; TUPLE: standard-combination < single-combination # ;
: <standard-combination> ( n -- standard-combination ) C: <standard-combination> standard-combination
dup 0 2 between? [ "Bad dispatch position" throw ] unless
standard-combination boa ;
PREDICATE: standard-generic < generic PREDICATE: standard-generic < generic
"combination" word-prop standard-combination? ; "combination" word-prop standard-combination? ;

2
core/memory/memory.factor
View File

@ -26,6 +26,6 @@ IN: memory
normalize-path native-string>alien (save-image) ; normalize-path native-string>alien (save-image) ;
: save-image-and-exit ( path -- ) : save-image-and-exit ( path -- )
normalize-path native-string>alien (save-image) ; normalize-path native-string>alien (save-image-and-exit) ;
: save ( -- ) image save-image ; : save ( -- ) image save-image ;

27
extra/images/viewer/viewer.factor
View File

@ -5,23 +5,28 @@ opengl opengl.gl opengl.textures sequences strings ui ui.gadgets
ui.gadgets.panes ui.render ui.images ; ui.gadgets.panes ui.render ui.images ;
IN: images.viewer IN: images.viewer
TUPLE: image-gadget < gadget image-name ; TUPLE: image-gadget < gadget image texture ;
M: image-gadget pref-dim* M: image-gadget pref-dim* image>> dim>> ;
image-name>> image-dim ;
: image-gadget-texture ( gadget -- texture )
dup texture>> [ ] [ dup image>> { 0 0 } <texture> >>texture texture>> ] ?if ;
M: image-gadget draw-gadget* ( gadget -- ) M: image-gadget draw-gadget* ( gadget -- )
image-name>> draw-image ; [ dim>> ] [ image-gadget-texture ] bi draw-scaled-texture ;
: <image-gadget> ( image-name -- gadget ) ! Todo: delete texture on ungraft
GENERIC: <image-gadget> ( object -- gadget )
M: image <image-gadget>
\ image-gadget new \ image-gadget new
swap >>image-name ; swap >>image ;
: image-window ( path -- gadget ) M: string <image-gadget> load-image <image-gadget> ;
[ <image-name> <image-gadget> dup ] [ open-window ] bi ;
GENERIC: image. ( object -- ) M: pathname <image-gadget> load-image <image-gadget> ;
M: string image. ( image -- ) <image-name> <image-gadget> gadget. ; : image-window ( object -- ) <image-gadget> "Image" open-window ;
M: pathname image. ( image -- ) <image-name> <image-gadget> gadget. ; : image. ( object -- ) <image-gadget> gadget. ;

2
vm/Config.windows
View File

@ -6,5 +6,5 @@ EXE_EXTENSION=.exe
CONSOLE_EXTENSION=.com CONSOLE_EXTENSION=.com
DLL_EXTENSION=.dll DLL_EXTENSION=.dll
SHARED_DLL_EXTENSION=.dll SHARED_DLL_EXTENSION=.dll
LINKER = $(CC) -shared -mno-cygwin -o LINKER = $(CPP) -shared -mno-cygwin -o
LINK_WITH_ENGINE = -l$(DLL_PREFIX)factor$(DLL_SUFFIX) LINK_WITH_ENGINE = -l$(DLL_PREFIX)factor$(DLL_SUFFIX)

6
vm/alien.cpp
View File

@ -77,7 +77,7 @@ PRIMITIVE(alien_address)
} }
/* pop ( alien n ) from datastack, return alien's address plus n */ /* pop ( alien n ) from datastack, return alien's address plus n */
static void *alien_pointer(void) static void *alien_pointer()
{ {
fixnum offset = to_fixnum(dpop()); fixnum offset = to_fixnum(dpop());
return unbox_alien() + offset; return unbox_alien() + offset;
@ -128,7 +128,7 @@ PRIMITIVE(dlsym)
gc_root<byte_array> name(dpop()); gc_root<byte_array> name(dpop());
name.untag_check(); name.untag_check();
vm_char *sym = (vm_char *)(name.untagged() + 1); symbol_char *sym = name->data<symbol_char>();
if(library.value() == F) if(library.value() == F)
box_alien(ffi_dlsym(NULL,sym)); box_alien(ffi_dlsym(NULL,sym));
@ -182,7 +182,7 @@ VM_C_API char *alien_offset(cell obj)
} }
/* pop an object representing a C pointer */ /* pop an object representing a C pointer */
VM_C_API char *unbox_alien(void) VM_C_API char *unbox_alien()
{ {
return alien_offset(dpop()); return alien_offset(dpop());
} }

2
vm/alien.hpp
View File

@ -39,7 +39,7 @@ PRIMITIVE(dlclose);
PRIMITIVE(dll_validp); PRIMITIVE(dll_validp);
VM_C_API char *alien_offset(cell object); VM_C_API char *alien_offset(cell object);
VM_C_API char *unbox_alien(void); VM_C_API char *unbox_alien();
VM_C_API void box_alien(void *ptr); VM_C_API void box_alien(void *ptr);
VM_C_API void to_value_struct(cell src, void *dest, cell size); VM_C_API void to_value_struct(cell src, void *dest, cell size);
VM_C_API void box_value_struct(void *src, cell size); VM_C_API void box_value_struct(void *src, cell size);

8
vm/callstack.cpp
View File

@ -54,7 +54,7 @@ This means that if 'callstack' is called in tail position, we
will have popped a necessary frame... however this word is only will have popped a necessary frame... however this word is only
called by continuation implementation, and user code shouldn't called by continuation implementation, and user code shouldn't
be calling it at all, so we leave it as it is for now. */ be calling it at all, so we leave it as it is for now. */
stack_frame *capture_start(void) stack_frame *capture_start()
{ {
stack_frame *frame = stack_chain->callstack_bottom - 1; stack_frame *frame = stack_chain->callstack_bottom - 1;
while(frame >= stack_chain->callstack_top while(frame >= stack_chain->callstack_top
@ -100,7 +100,7 @@ code_block *frame_code(stack_frame *frame)
cell frame_type(stack_frame *frame) cell frame_type(stack_frame *frame)
{ {
return frame_code(frame)->block.type; return frame_code(frame)->type;
} }
cell frame_executing(stack_frame *frame) cell frame_executing(stack_frame *frame)
@ -195,9 +195,9 @@ stack_frame *innermost_stack_frame_quot(callstack *callstack)
/* Some primitives implementing a limited form of callstack mutation. /* Some primitives implementing a limited form of callstack mutation.
Used by the single stepper. */ Used by the single stepper. */
PRIMITIVE(innermost_stack_frame_quot) PRIMITIVE(innermost_stack_frame_executing)
{ {
dpush(frame_executing(innermost_stack_frame_quot(untag_check<callstack>(dpop())))); dpush(frame_executing(innermost_stack_frame(untag_check<callstack>(dpop()))));
} }
PRIMITIVE(innermost_stack_frame_scan) PRIMITIVE(innermost_stack_frame_scan)

2
vm/callstack.hpp
View File

@ -22,7 +22,7 @@ cell frame_type(stack_frame *frame);
PRIMITIVE(callstack); PRIMITIVE(callstack);
PRIMITIVE(set_callstack); PRIMITIVE(set_callstack);
PRIMITIVE(callstack_to_array); PRIMITIVE(callstack_to_array);
PRIMITIVE(innermost_stack_frame_quot); PRIMITIVE(innermost_stack_frame_executing);
PRIMITIVE(innermost_stack_frame_scan); PRIMITIVE(innermost_stack_frame_scan);
PRIMITIVE(set_innermost_stack_frame_quot); PRIMITIVE(set_innermost_stack_frame_quot);

31
vm/code_block.cpp Normal file → Executable file
View File

@ -5,7 +5,7 @@ namespace factor
void flush_icache_for(code_block *block) void flush_icache_for(code_block *block)
{ {
flush_icache((cell)block,block->block.size); flush_icache((cell)block,block->size);
} }
void iterate_relocations(code_block *compiled, relocation_iterator iter) void iterate_relocations(code_block *compiled, relocation_iterator iter)
@ -122,7 +122,7 @@ void update_literal_references_step(relocation_entry rel, cell index, code_block
/* Update pointers to literals from compiled code. */ /* Update pointers to literals from compiled code. */
void update_literal_references(code_block *compiled) void update_literal_references(code_block *compiled)
{ {
if(!compiled->block.needs_fixup) if(!compiled->needs_fixup)
{ {
iterate_relocations(compiled,update_literal_references_step); iterate_relocations(compiled,update_literal_references_step);
flush_icache_for(compiled); flush_icache_for(compiled);
@ -133,12 +133,12 @@ void update_literal_references(code_block *compiled)
aging and nursery collections */ aging and nursery collections */
void copy_literal_references(code_block *compiled) void copy_literal_references(code_block *compiled)
{ {
if(collecting_gen >= compiled->block.last_scan) if(collecting_gen >= compiled->last_scan)
{ {
if(collecting_accumulation_gen_p()) if(collecting_accumulation_gen_p())
compiled->block.last_scan = collecting_gen; compiled->last_scan = collecting_gen;
else else
compiled->block.last_scan = collecting_gen + 1; compiled->last_scan = collecting_gen + 1;
/* initialize chase pointer */ /* initialize chase pointer */
cell scan = newspace->here; cell scan = newspace->here;
@ -208,7 +208,7 @@ to update references to other words, without worrying about literals
or dlsyms. */ or dlsyms. */
void update_word_references(code_block *compiled) void update_word_references(code_block *compiled)
{ {
if(compiled->block.needs_fixup) if(compiled->needs_fixup)
relocate_code_block(compiled); relocate_code_block(compiled);
/* update_word_references() is always applied to every block in /* update_word_references() is always applied to every block in
the code heap. Since it resets all call sites to point to the code heap. Since it resets all call sites to point to
@ -217,8 +217,8 @@ void update_word_references(code_block *compiled)
are referenced after this is done. So instead of polluting are referenced after this is done. So instead of polluting
the code heap with dead PICs that will be freed on the next the code heap with dead PICs that will be freed on the next
GC, we add them to the free list immediately. */ GC, we add them to the free list immediately. */
else if(compiled->block.type == PIC_TYPE) else if(compiled->type == PIC_TYPE)
heap_free(&code,&compiled->block); heap_free(&code,compiled);
else else
{ {
iterate_relocations(compiled,update_word_references_step); iterate_relocations(compiled,update_word_references_step);
@ -248,7 +248,7 @@ void mark_code_block(code_block *compiled)
{ {
check_code_address((cell)compiled); check_code_address((cell)compiled);
mark_block(&compiled->block); mark_block(compiled);
copy_handle(&compiled->literals); copy_handle(&compiled->literals);
copy_handle(&compiled->relocation); copy_handle(&compiled->relocation);
@ -302,7 +302,7 @@ void mark_object_code_block(object *object)
/* References to undefined symbols are patched up to call this function on /* References to undefined symbols are patched up to call this function on
image load */ image load */
void undefined_symbol(void) void undefined_symbol()
{ {
general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL); general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
} }
@ -329,7 +329,6 @@ void *get_rel_symbol(array *literals, cell index)
return sym; return sym;
else else
{ {
printf("%s\n",name);
return (void *)undefined_symbol; return (void *)undefined_symbol;
} }
} }
@ -405,8 +404,8 @@ void relocate_code_block_step(relocation_entry rel, cell index, code_block *comp
/* Perform all fixups on a code block */ /* Perform all fixups on a code block */
void relocate_code_block(code_block *compiled) void relocate_code_block(code_block *compiled)
{ {
compiled->block.last_scan = NURSERY; compiled->last_scan = NURSERY;
compiled->block.needs_fixup = false; compiled->needs_fixup = false;
iterate_relocations(compiled,relocate_code_block_step); iterate_relocations(compiled,relocate_code_block_step);
flush_icache_for(compiled); flush_icache_for(compiled);
} }
@ -474,9 +473,9 @@ code_block *add_code_block(
code_block *compiled = allot_code_block(code_length); code_block *compiled = allot_code_block(code_length);
/* compiled header */ /* compiled header */
compiled->block.type = type; compiled->type = type;
compiled->block.last_scan = NURSERY; compiled->last_scan = NURSERY;
compiled->block.needs_fixup = true; compiled->needs_fixup = true;
compiled->relocation = relocation.value(); compiled->relocation = relocation.value();
/* slight space optimization */ /* slight space optimization */

2
vm/code_block.hpp
View File

@ -82,7 +82,7 @@ void mark_object_code_block(object *scan);
void relocate_code_block(code_block *relocating); void relocate_code_block(code_block *relocating);
inline static bool stack_traces_p(void) inline static bool stack_traces_p()
{ {
return userenv[STACK_TRACES_ENV] != F; return userenv[STACK_TRACES_ENV] != F;
} }

38
vm/code_gc.cpp
View File

@ -22,9 +22,9 @@ void new_heap(heap *heap, cell size)
static void add_to_free_list(heap *heap, free_heap_block *block) static void add_to_free_list(heap *heap, free_heap_block *block)
{ {
if(block->block.size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT) if(block->size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
{ {
int index = block->block.size / BLOCK_SIZE_INCREMENT; int index = block->size / BLOCK_SIZE_INCREMENT;
block->next_free = heap->free.small_blocks[index]; block->next_free = heap->free.small_blocks[index];
heap->free.small_blocks[index] = block; heap->free.small_blocks[index] = block;
} }
@ -73,8 +73,8 @@ void build_free_list(heap *heap, cell size)
branch is only taken after loading a new image, not after code GC */ branch is only taken after loading a new image, not after code GC */
if((cell)(end + 1) <= heap->seg->end) if((cell)(end + 1) <= heap->seg->end)
{ {
end->block.status = B_FREE; end->status = B_FREE;
end->block.size = heap->seg->end - (cell)end; end->size = heap->seg->end - (cell)end;
/* add final free block */ /* add final free block */
add_to_free_list(heap,end); add_to_free_list(heap,end);
@ -93,7 +93,7 @@ void build_free_list(heap *heap, cell size)
static void assert_free_block(free_heap_block *block) static void assert_free_block(free_heap_block *block)
{ {
if(block->block.status != B_FREE) if(block->status != B_FREE)
critical_error("Invalid block in free list",(cell)block); critical_error("Invalid block in free list",(cell)block);
} }
@ -121,7 +121,7 @@ static free_heap_block *find_free_block(heap *heap, cell size)
while(block) while(block)
{ {
assert_free_block(block); assert_free_block(block);
if(block->block.size >= size) if(block->size >= size)
{ {
if(prev) if(prev)
prev->next_free = block->next_free; prev->next_free = block->next_free;
@ -139,14 +139,14 @@ static free_heap_block *find_free_block(heap *heap, cell size)
static free_heap_block *split_free_block(heap *heap, free_heap_block *block, cell size) static free_heap_block *split_free_block(heap *heap, free_heap_block *block, cell size)
{ {
if(block->block.size != size ) if(block->size != size )
{ {
/* split the block in two */ /* split the block in two */
free_heap_block *split = (free_heap_block *)((cell)block + size); free_heap_block *split = (free_heap_block *)((cell)block + size);
split->block.status = B_FREE; split->status = B_FREE;
split->block.size = block->block.size - size; split->size = block->size - size;
split->next_free = block->next_free; split->next_free = block->next_free;
block->block.size = size; block->size = size;
add_to_free_list(heap,split); add_to_free_list(heap,split);
} }
@ -163,8 +163,8 @@ heap_block *heap_allot(heap *heap, cell size)
{ {
block = split_free_block(heap,block,size); block = split_free_block(heap,block,size);
block->block.status = B_ALLOCATED; block->status = B_ALLOCATED;
return &block->block; return block;
} }
else else
return NULL; return NULL;
@ -303,16 +303,16 @@ cell heap_size(heap *heap)
} }
/* Compute where each block is going to go, after compaction */ /* Compute where each block is going to go, after compaction */
cell compute_heap_forwarding(heap *heap) cell compute_heap_forwarding(heap *heap, unordered_map<heap_block *,char *> &forwarding)
{ {
heap_block *scan = first_block(heap); heap_block *scan = first_block(heap);
cell address = (cell)first_block(heap); char *address = (char *)first_block(heap);
while(scan) while(scan)
{ {
if(scan->status == B_ALLOCATED) if(scan->status == B_ALLOCATED)
{ {
scan->forwarding = (heap_block *)address; forwarding[scan] = address;
address += scan->size; address += scan->size;
} }
else if(scan->status == B_MARKED) else if(scan->status == B_MARKED)
@ -321,10 +321,10 @@ cell compute_heap_forwarding(heap *heap)
scan = next_block(heap,scan); scan = next_block(heap,scan);
} }
return address - heap->seg->start; return (cell)address - heap->seg->start;
} }
void compact_heap(heap *heap) void compact_heap(heap *heap, unordered_map<heap_block *,char *> &forwarding)
{ {
heap_block *scan = first_block(heap); heap_block *scan = first_block(heap);
@ -332,8 +332,8 @@ void compact_heap(heap *heap)
{ {
heap_block *next = next_block(heap,scan); heap_block *next = next_block(heap,scan);
if(scan->status == B_ALLOCATED && scan != scan->forwarding) if(scan->status == B_ALLOCATED)
memcpy(scan->forwarding,scan,scan->size); memmove(forwarding[scan],scan,scan->size);
scan = next; scan = next;
} }
} }

4
vm/code_gc.hpp
View File

@ -25,8 +25,8 @@ void unmark_marked(heap *heap);
void free_unmarked(heap *heap, heap_iterator iter); void free_unmarked(heap *heap, heap_iterator iter);
void heap_usage(heap *h, cell *used, cell *total_free, cell *max_free); void heap_usage(heap *h, cell *used, cell *total_free, cell *max_free);
cell heap_size(heap *h); cell heap_size(heap *h);
cell compute_heap_forwarding(heap *h); cell compute_heap_forwarding(heap *h, unordered_map<heap_block *,char *> &forwarding);
void compact_heap(heap *h); void compact_heap(heap *h, unordered_map<heap_block *,char *> &forwarding);
inline static heap_block *next_block(heap *h, heap_block *block) inline static heap_block *next_block(heap *h, heap_block *block)
{ {

18
vm/code_heap.cpp
View File

@ -45,14 +45,14 @@ void iterate_code_heap(code_heap_iterator iter)
/* Copy literals referenced from all code blocks to newspace. Only for /* Copy literals referenced from all code blocks to newspace. Only for
aging and nursery collections */ aging and nursery collections */
void copy_code_heap_roots(void) void copy_code_heap_roots()
{ {
iterate_code_heap(copy_literal_references); iterate_code_heap(copy_literal_references);
} }
/* Update pointers to words referenced from all code blocks. Only after /* Update pointers to words referenced from all code blocks. Only after
defining a new word. */ defining a new word. */
void update_code_heap_words(void) void update_code_heap_words()
{ {
iterate_code_heap(update_word_references); iterate_code_heap(update_word_references);
} }
@ -119,9 +119,11 @@ PRIMITIVE(code_room)
dpush(tag_fixnum(max_free / 1024)); dpush(tag_fixnum(max_free / 1024));
} }
static unordered_map<heap_block *,char *> forwarding;
code_block *forward_xt(code_block *compiled) code_block *forward_xt(code_block *compiled)
{ {
return (code_block *)compiled->block.forwarding; return (code_block *)forwarding[compiled];
} }
void forward_frame_xt(stack_frame *frame) void forward_frame_xt(stack_frame *frame)
@ -132,7 +134,7 @@ void forward_frame_xt(stack_frame *frame)
FRAME_RETURN_ADDRESS(frame) = (void *)((cell)forwarded + offset); FRAME_RETURN_ADDRESS(frame) = (void *)((cell)forwarded + offset);
} }
void forward_object_xts(void) void forward_object_xts()
{ {
begin_scan(); begin_scan();
@ -176,7 +178,7 @@ void forward_object_xts(void)
} }
/* Set the XT fields now that the heap has been compacted */ /* Set the XT fields now that the heap has been compacted */
void fixup_object_xts(void) void fixup_object_xts()
{ {
begin_scan(); begin_scan();
@ -209,19 +211,19 @@ void fixup_object_xts(void)
since it makes several passes over the code and data heaps, but we only ever since it makes several passes over the code and data heaps, but we only ever
do this before saving a deployed image and exiting, so performaance is not do this before saving a deployed image and exiting, so performaance is not
critical here */ critical here */
void compact_code_heap(void) void compact_code_heap()
{ {
/* Free all unreachable code blocks */ /* Free all unreachable code blocks */
gc(); gc();
/* Figure out where the code heap blocks are going to end up */ /* Figure out where the code heap blocks are going to end up */
cell size = compute_heap_forwarding(&code); cell size = compute_heap_forwarding(&code, forwarding);
/* Update word and quotation code pointers */ /* Update word and quotation code pointers */
forward_object_xts(); forward_object_xts();
/* Actually perform the compaction */ /* Actually perform the compaction */
compact_heap(&code); compact_heap(&code,forwarding);
/* Update word and quotation XTs */ /* Update word and quotation XTs */
fixup_object_xts(); fixup_object_xts();

4
vm/code_heap.hpp
View File

@ -14,13 +14,13 @@ typedef void (*code_heap_iterator)(code_block *compiled);
void iterate_code_heap(code_heap_iterator iter); void iterate_code_heap(code_heap_iterator iter);
void copy_code_heap_roots(void); void copy_code_heap_roots();
PRIMITIVE(modify_code_heap); PRIMITIVE(modify_code_heap);
PRIMITIVE(code_room); PRIMITIVE(code_room);
void compact_code_heap(void); void compact_code_heap();
inline static void check_code_pointer(cell ptr) inline static void check_code_pointer(cell ptr)
{ {

14
vm/contexts.cpp
View File

@ -8,19 +8,19 @@ namespace factor
cell ds_size, rs_size; cell ds_size, rs_size;
context *unused_contexts; context *unused_contexts;
void reset_datastack(void) void reset_datastack()
{ {
ds = ds_bot - sizeof(cell); ds = ds_bot - sizeof(cell);
} }
void reset_retainstack(void) void reset_retainstack()
{ {
rs = rs_bot - sizeof(cell); rs = rs_bot - sizeof(cell);
} }
#define RESERVED (64 * sizeof(cell)) #define RESERVED (64 * sizeof(cell))
void fix_stacks(void) void fix_stacks()
{ {
if(ds + sizeof(cell) < ds_bot || ds + RESERVED >= ds_top) reset_datastack(); if(ds + sizeof(cell) < ds_bot || ds + RESERVED >= ds_top) reset_datastack();
if(rs + sizeof(cell) < rs_bot || rs + RESERVED >= rs_top) reset_retainstack(); if(rs + sizeof(cell) < rs_bot || rs + RESERVED >= rs_top) reset_retainstack();
@ -28,7 +28,7 @@ void fix_stacks(void)
/* called before entry into foreign C code. Note that ds and rs might /* called before entry into foreign C code. Note that ds and rs might
be stored in registers, so callbacks must save and restore the correct values */ be stored in registers, so callbacks must save and restore the correct values */
void save_stacks(void) void save_stacks()
{ {
if(stack_chain) if(stack_chain)
{ {
@ -37,7 +37,7 @@ void save_stacks(void)
} }
} }
context *alloc_context(void) context *alloc_context()
{ {
context *new_context; context *new_context;
@ -63,7 +63,7 @@ void dealloc_context(context *old_context)
} }
/* called on entry into a compiled callback */ /* called on entry into a compiled callback */
void nest_stacks(void) void nest_stacks()
{ {
context *new_context = alloc_context(); context *new_context = alloc_context();
@ -95,7 +95,7 @@ void nest_stacks(void)
} }
/* called when leaving a compiled callback */ /* called when leaving a compiled callback */
void unnest_stacks(void) void unnest_stacks()
{ {
ds = stack_chain->datastack_save; ds = stack_chain->datastack_save;
rs = stack_chain->retainstack_save; rs = stack_chain->retainstack_save;

12
vm/contexts.hpp
View File

@ -46,9 +46,9 @@ extern cell ds_size, rs_size;
DEFPUSHPOP(d,ds) DEFPUSHPOP(d,ds)
DEFPUSHPOP(r,rs) DEFPUSHPOP(r,rs)
void reset_datastack(void); void reset_datastack();
void reset_retainstack(void); void reset_retainstack();
void fix_stacks(void); void fix_stacks();
void init_stacks(cell ds_size, cell rs_size); void init_stacks(cell ds_size, cell rs_size);
PRIMITIVE(datastack); PRIMITIVE(datastack);
@ -57,9 +57,9 @@ PRIMITIVE(set_datastack);
PRIMITIVE(set_retainstack); PRIMITIVE(set_retainstack);
PRIMITIVE(check_datastack); PRIMITIVE(check_datastack);
VM_C_API void save_stacks(void); VM_C_API void save_stacks();
VM_C_API void nest_stacks(void); VM_C_API void nest_stacks();
VM_C_API void unnest_stacks(void); VM_C_API void unnest_stacks();
} }

2
vm/cpu-x86.32.hpp
View File

@ -6,6 +6,6 @@ namespace factor
register cell ds asm("esi"); register cell ds asm("esi");
register cell rs asm("edi"); register cell rs asm("edi");
#define VM_ASM_API extern "C" __attribute__ ((regparm (2))) #define VM_ASM_API VM_C_API __attribute__ ((regparm (2)))
} }

2
vm/cpu-x86.64.hpp Normal file → Executable file
View File

@ -6,6 +6,6 @@ namespace factor
register cell ds asm("r14"); register cell ds asm("r14");
register cell rs asm("r15"); register cell rs asm("r15");
#define VM_ASM_API extern "C" #define VM_ASM_API VM_C_API
} }

16
vm/data_gc.cpp
View File

@ -33,7 +33,7 @@ cell last_code_heap_scan;
bool growing_data_heap; bool growing_data_heap;
data_heap *old_data_heap; data_heap *old_data_heap;
void init_data_gc(void) void init_data_gc()
{ {
performing_gc = false; performing_gc = false;
last_code_heap_scan = NURSERY; last_code_heap_scan = NURSERY;
@ -244,7 +244,7 @@ static void copy_gen_cards(cell gen)
/* Scan cards in all generations older than the one being collected, copying /* Scan cards in all generations older than the one being collected, copying
old->new references */ old->new references */
static void copy_cards(void) static void copy_cards()
{ {
u64 start = current_micros(); u64 start = current_micros();
@ -264,7 +264,7 @@ static void copy_stack_elements(segment *region, cell top)
copy_handle((cell*)ptr); copy_handle((cell*)ptr);
} }
static void copy_registered_locals(void) static void copy_registered_locals()
{ {
cell scan = gc_locals_region->start; cell scan = gc_locals_region->start;
@ -272,7 +272,7 @@ static void copy_registered_locals(void)
copy_handle(*(cell **)scan); copy_handle(*(cell **)scan);
} }
static void copy_registered_bignums(void) static void copy_registered_bignums()
{ {
cell scan = gc_bignums_region->start; cell scan = gc_bignums_region->start;
@ -295,7 +295,7 @@ static void copy_registered_bignums(void)
/* Copy roots over at the start of GC, namely various constants, stacks, /* Copy roots over at the start of GC, namely various constants, stacks,
the user environment and extra roots registered by local_roots.hpp */ the user environment and extra roots registered by local_roots.hpp */
static void copy_roots(void) static void copy_roots()
{ {
copy_handle(&T); copy_handle(&T);
copy_handle(&bignum_zero); copy_handle(&bignum_zero);
@ -593,7 +593,7 @@ void garbage_collection(cell gen,
performing_gc = false; performing_gc = false;
} }
void gc(void) void gc()
{ {
garbage_collection(TENURED,false,0); garbage_collection(TENURED,false,0);
} }
@ -633,7 +633,7 @@ PRIMITIVE(gc_stats)
dpush(result.elements.value()); dpush(result.elements.value());
} }
void clear_gc_stats(void) void clear_gc_stats()
{ {
int i; int i;
for(i = 0; i < MAX_GEN_COUNT; i++) for(i = 0; i < MAX_GEN_COUNT; i++)
@ -681,7 +681,7 @@ PRIMITIVE(become)
compile_all_words(); compile_all_words();
} }
VM_C_API void minor_gc(void) VM_C_API void minor_gc()
{ {
garbage_collection(NURSERY,false,0); garbage_collection(NURSERY,false,0);
} }

10
vm/data_gc.hpp
View File

@ -18,11 +18,11 @@ extern bool collecting_aging_again;
extern cell last_code_heap_scan; extern cell last_code_heap_scan;
void init_data_gc(void); void init_data_gc();
void gc(void); void gc();
inline static bool collecting_accumulation_gen_p(void) inline static bool collecting_accumulation_gen_p()
{ {
return ((HAVE_AGING_P return ((HAVE_AGING_P
&& collecting_gen == AGING && collecting_gen == AGING
@ -114,7 +114,7 @@ void copy_reachable_objects(cell scan, cell *end);
PRIMITIVE(gc); PRIMITIVE(gc);
PRIMITIVE(gc_stats); PRIMITIVE(gc_stats);
void clear_gc_stats(void); void clear_gc_stats();
PRIMITIVE(clear_gc_stats); PRIMITIVE(clear_gc_stats);
PRIMITIVE(become); PRIMITIVE(become);
@ -143,6 +143,6 @@ inline static void check_tagged_pointer(cell tagged)
#endif #endif
} }
VM_C_API void minor_gc(void); VM_C_API void minor_gc();
} }

12
vm/data_heap.cpp Normal file → Executable file
View File

@ -24,7 +24,7 @@ cell init_zone(zone *z, cell size, cell start)
return z->end; return z->end;
} }
void init_card_decks(void) void init_card_decks()
{ {
cell start = align(data->seg->start,DECK_SIZE); cell start = align(data->seg->start,DECK_SIZE);
allot_markers_offset = (cell)data->allot_markers - (start >> CARD_BITS); allot_markers_offset = (cell)data->allot_markers - (start >> CARD_BITS);
@ -241,7 +241,7 @@ cell unaligned_object_size(object *pointer)
return callstack_size(untag_fixnum(((callstack *)pointer)->length)); return callstack_size(untag_fixnum(((callstack *)pointer)->length));
default: default:
critical_error("Invalid header",(cell)pointer); critical_error("Invalid header",(cell)pointer);
return -1; /* can't happen */ return 0; /* can't happen */
} }
} }
@ -283,7 +283,7 @@ cell binary_payload_start(object *pointer)
return sizeof(wrapper); return sizeof(wrapper);
default: default:
critical_error("Invalid header",(cell)pointer); critical_error("Invalid header",(cell)pointer);
return -1; /* can't happen */ return 0; /* can't happen */
} }
} }
@ -312,7 +312,7 @@ references to an object for debugging purposes. */
cell heap_scan_ptr; cell heap_scan_ptr;
/* Disables GC and activates next-object ( -- obj ) primitive */ /* Disables GC and activates next-object ( -- obj ) primitive */
void begin_scan(void) void begin_scan()
{ {
heap_scan_ptr = data->generations[TENURED].start; heap_scan_ptr = data->generations[TENURED].start;
gc_off = true; gc_off = true;
@ -323,7 +323,7 @@ PRIMITIVE(begin_scan)
begin_scan(); begin_scan();
} }
cell next_object(void) cell next_object()
{ {
if(!gc_off) if(!gc_off)
general_error(ERROR_HEAP_SCAN,F,F,NULL); general_error(ERROR_HEAP_SCAN,F,F,NULL);
@ -348,7 +348,7 @@ PRIMITIVE(end_scan)
gc_off = false; gc_off = false;
} }
cell find_all_words(void) cell find_all_words()
{ {
growable_array words; growable_array words;

8
vm/data_heap.hpp
View File

@ -56,7 +56,7 @@ inline static bool in_zone(zone *z, object *pointer)
cell init_zone(zone *z, cell size, cell base); cell init_zone(zone *z, cell size, cell base);
void init_card_decks(void); void init_card_decks();
data_heap *grow_data_heap(data_heap *data, cell requested_bytes); data_heap *grow_data_heap(data_heap *data, cell requested_bytes);
@ -86,8 +86,8 @@ cell unaligned_object_size(object *pointer);
cell binary_payload_start(object *pointer); cell binary_payload_start(object *pointer);
cell object_size(cell tagged); cell object_size(cell tagged);
void begin_scan(void); void begin_scan();
cell next_object(void); cell next_object();
PRIMITIVE(data_room); PRIMITIVE(data_room);
PRIMITIVE(size); PRIMITIVE(size);
@ -99,7 +99,7 @@ PRIMITIVE(end_scan);
/* GC is off during heap walking */ /* GC is off during heap walking */
extern bool gc_off; extern bool gc_off;
cell find_all_words(void); cell find_all_words();
/* Every object has a regular representation in the runtime, which makes GC /* Every object has a regular representation in the runtime, which makes GC
much simpler. Every slot of the object until binary_payload_start is a pointer much simpler. Every slot of the object until binary_payload_start is a pointer

12
vm/debug.cpp
View File

@ -155,13 +155,13 @@ void print_objects(cell *start, cell *end)
} }
} }
void print_datastack(void) void print_datastack()
{ {
print_string("==== DATA STACK:\n"); print_string("==== DATA STACK:\n");
print_objects((cell *)ds_bot,(cell *)ds); print_objects((cell *)ds_bot,(cell *)ds);
} }
void print_retainstack(void) void print_retainstack()
{ {
print_string("==== RETAIN STACK:\n"); print_string("==== RETAIN STACK:\n");
print_objects((cell *)rs_bot,(cell *)rs); print_objects((cell *)rs_bot,(cell *)rs);
@ -179,7 +179,7 @@ void print_stack_frame(stack_frame *frame)
print_string("\n"); print_string("\n");
} }
void print_callstack(void) void print_callstack()
{ {
print_string("==== CALL STACK:\n"); print_string("==== CALL STACK:\n");
cell bottom = (cell)stack_chain->callstack_bottom; cell bottom = (cell)stack_chain->callstack_bottom;
@ -210,7 +210,7 @@ void dump_zone(zone *z)
print_string(", here="); print_cell(z->here - z->start); nl(); print_string(", here="); print_cell(z->here - z->start); nl();
} }
void dump_generations(void) void dump_generations()
{ {
cell i; cell i;
@ -285,7 +285,7 @@ void find_data_references(cell look_for_)
} }
/* Dump all code blocks for debugging */ /* Dump all code blocks for debugging */
void dump_code_heap(void) void dump_code_heap()
{ {
cell reloc_size = 0, literal_size = 0; cell reloc_size = 0, literal_size = 0;
@ -325,7 +325,7 @@ void dump_code_heap(void)
print_cell(literal_size); print_string(" bytes of literal data\n"); print_cell(literal_size); print_string(" bytes of literal data\n");
} }
void factorbug(void) void factorbug()
{ {
if(fep_disabled) if(fep_disabled)
{ {

4
vm/debug.hpp
View File

@ -3,8 +3,8 @@ namespace factor
void print_obj(cell obj); void print_obj(cell obj);
void print_nested_obj(cell obj, fixnum nesting); void print_nested_obj(cell obj, fixnum nesting);
void dump_generations(void); void dump_generations();
void factorbug(void); void factorbug();
void dump_zone(zone *z); void dump_zone(zone *z);
PRIMITIVE(die); PRIMITIVE(die);

2
vm/dispatch.cpp Normal file → Executable file
View File

@ -103,7 +103,7 @@ static cell lookup_hairy_method(cell obj, cell methods)
break; break;
default: default:
critical_error("Bad methods array",methods); critical_error("Bad methods array",methods);
return -1; return 0;
} }
} }
} }

10
vm/errors.cpp
View File

@ -9,7 +9,7 @@ cell signal_number;
cell signal_fault_addr; cell signal_fault_addr;
stack_frame *signal_callstack_top; stack_frame *signal_callstack_top;
void out_of_memory(void) void out_of_memory()
{ {
print_string("Out of memory\n\n"); print_string("Out of memory\n\n");
dump_generations(); dump_generations();
@ -88,7 +88,7 @@ void type_error(cell type, cell tagged)
general_error(ERROR_TYPE,tag_fixnum(type),tagged,NULL); general_error(ERROR_TYPE,tag_fixnum(type),tagged,NULL);
} }
void not_implemented_error(void) void not_implemented_error()
{ {
general_error(ERROR_NOT_IMPLEMENTED,F,F,NULL); general_error(ERROR_NOT_IMPLEMENTED,F,F,NULL);
} }
@ -125,7 +125,7 @@ void signal_error(int signal, stack_frame *native_stack)
general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack); general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack);
} }
void divide_by_zero_error(void) void divide_by_zero_error()
{ {
general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL); general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL);
} }
@ -141,12 +141,12 @@ PRIMITIVE(unimplemented)
not_implemented_error(); not_implemented_error();
} }
void memory_signal_handler_impl(void) void memory_signal_handler_impl()
{ {
memory_protection_error(signal_fault_addr,signal_callstack_top); memory_protection_error(signal_fault_addr,signal_callstack_top);
} }
void misc_signal_handler_impl(void) void misc_signal_handler_impl()
{ {
signal_error(signal_number,signal_callstack_top); signal_error(signal_number,signal_callstack_top);
} }

10
vm/errors.hpp
View File

@ -22,7 +22,7 @@ enum vm_error_type
ERROR_MEMORY, ERROR_MEMORY,
}; };
void out_of_memory(void); void out_of_memory();
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 critical_error(const char* msg, cell tagged);
@ -30,11 +30,11 @@ PRIMITIVE(die);
void throw_error(cell error, stack_frame *native_stack); void throw_error(cell error, stack_frame *native_stack);
void general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *native_stack); void general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *native_stack);
void divide_by_zero_error(void); void divide_by_zero_error();
void memory_protection_error(cell addr, stack_frame *native_stack); void memory_protection_error(cell addr, stack_frame *native_stack);
void signal_error(int signal, stack_frame *native_stack); void signal_error(int signal, stack_frame *native_stack);
void type_error(cell type, cell tagged); void type_error(cell type, cell tagged);
void not_implemented_error(void); void not_implemented_error();
PRIMITIVE(call_clear); PRIMITIVE(call_clear);
PRIMITIVE(unimplemented); PRIMITIVE(unimplemented);
@ -45,7 +45,7 @@ extern cell signal_number;
extern cell signal_fault_addr; extern cell signal_fault_addr;
extern stack_frame *signal_callstack_top; extern stack_frame *signal_callstack_top;
void memory_signal_handler_impl(void); void memory_signal_handler_impl();
void misc_signal_handler_impl(void); void misc_signal_handler_impl();
} }

8
vm/factor.cpp
View File

@ -81,7 +81,7 @@ VM_C_API void init_parameters_from_args(vm_parameters *p, int argc, vm_char **ar
} }
/* Do some initialization that we do once only */ /* Do some initialization that we do once only */
static void do_stage1_init(void) static void do_stage1_init()
{ {
print_string("*** Stage 2 early init... "); print_string("*** Stage 2 early init... ");
fflush(stdout); fflush(stdout);
@ -134,7 +134,7 @@ VM_C_API void init_factor(vm_parameters *p)
userenv[CPU_ENV] = allot_alien(F,(cell)FACTOR_CPU_STRING); userenv[CPU_ENV] = allot_alien(F,(cell)FACTOR_CPU_STRING);
userenv[OS_ENV] = allot_alien(F,(cell)FACTOR_OS_STRING); userenv[OS_ENV] = allot_alien(F,(cell)FACTOR_OS_STRING);
userenv[cell_SIZE_ENV] = tag_fixnum(sizeof(cell)); userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(cell));
userenv[EXECUTABLE_ENV] = allot_alien(F,(cell)p->executable_path); userenv[EXECUTABLE_ENV] = allot_alien(F,(cell)p->executable_path);
userenv[ARGS_ENV] = F; userenv[ARGS_ENV] = F;
userenv[EMBEDDED_ENV] = F; userenv[EMBEDDED_ENV] = F;
@ -198,9 +198,9 @@ VM_C_API void factor_eval_free(char *result)
free(result); free(result);
} }
VM_C_API void factor_yield(void) VM_C_API void factor_yield()
{ {
void (*callback)(void) = (void (*)(void))alien_offset(userenv[YIELD_CALLBACK_ENV]); void (*callback)() = (void (*)())alien_offset(userenv[YIELD_CALLBACK_ENV]);
callback(); callback();
} }

2
vm/factor.hpp
View File

@ -10,7 +10,7 @@ VM_C_API void start_standalone_factor(int argc, vm_char **argv);
VM_C_API char *factor_eval_string(char *string); VM_C_API char *factor_eval_string(char *string);
VM_C_API void factor_eval_free(char *result); VM_C_API void factor_eval_free(char *result);
VM_C_API void factor_yield(void); VM_C_API void factor_yield();
VM_C_API void factor_sleep(long ms); VM_C_API void factor_sleep(long ms);
} }

5
vm/ffi_test.c
View File

@ -319,3 +319,8 @@ _Complex float ffi_test_47(_Complex float x, _Complex double y)
{ {
return x + 2 * y; return x + 2 * y;
} }
short ffi_test_48(struct bool_field_test x)
{
return x.parents;
}

10
vm/ffi_test.h
View File

@ -1,3 +1,5 @@
#include <stdbool.h>
#if defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32) #if defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32)
#define F_STDCALL __attribute__((stdcall)) #define F_STDCALL __attribute__((stdcall))
#else #else
@ -102,3 +104,11 @@ F_EXPORT _Complex float ffi_test_45(int x);
F_EXPORT _Complex double ffi_test_46(int x); F_EXPORT _Complex double ffi_test_46(int x);
F_EXPORT _Complex float ffi_test_47(_Complex float x, _Complex double y); F_EXPORT _Complex float ffi_test_47(_Complex float x, _Complex double y);
struct bool_field_test {
char *name;
bool on;
short parents;
};
F_EXPORT short ffi_test_48(struct bool_field_test x);

20
vm/image.cpp
View File

@ -106,14 +106,8 @@ bool save_image(const vm_char *filename)
h.bignum_pos_one = bignum_pos_one; h.bignum_pos_one = bignum_pos_one;
h.bignum_neg_one = bignum_neg_one; h.bignum_neg_one = bignum_neg_one;
cell i; for(cell i = 0; i < USER_ENV; i++)
for(i = 0; i < USER_ENV; i++) h.userenv[i] = (save_env_p(i) ? userenv[i] : F);
{
if(i < FIRST_SAVE_ENV)
h.userenv[i] = F;
else
h.userenv[i] = userenv[i];
}
bool ok = true; bool ok = true;
@ -149,12 +143,10 @@ PRIMITIVE(save_image_and_exit)
path.untag_check(); path.untag_check();
/* strip out userenv data which is set on startup anyway */ /* strip out userenv data which is set on startup anyway */
cell i; for(cell i = 0; i < USER_ENV; i++)
for(i = 0; i < FIRST_SAVE_ENV; i++) {
userenv[i] = F; if(!save_env_p(i)) userenv[i] = F;
}
for(i = LAST_SAVE_ENV + 1; i < STACK_TRACES_ENV; i++)
userenv[i] = F;
/* do a full GC + code heap compaction */ /* do a full GC + code heap compaction */
performing_compaction = true; performing_compaction = true;

6
vm/inline_cache.cpp Normal file → Executable file
View File

@ -22,7 +22,7 @@ void deallocate_inline_cache(cell return_address)
/* Find the call target. */ /* Find the call target. */
void *old_xt = get_call_target(return_address); void *old_xt = get_call_target(return_address);
code_block *old_block = (code_block *)old_xt - 1; code_block *old_block = (code_block *)old_xt - 1;
cell old_type = old_block->block.type; cell old_type = old_block->type;
#ifdef FACTOR_DEBUG #ifdef FACTOR_DEBUG
/* The call target was either another PIC, /* The call target was either another PIC,
@ -31,7 +31,7 @@ void deallocate_inline_cache(cell return_address)
#endif #endif
if(old_type == PIC_TYPE) if(old_type == PIC_TYPE)
heap_free(&code,&old_block->block); heap_free(&code,old_block);
} }
/* Figure out what kind of type check the PIC needs based on the methods /* Figure out what kind of type check the PIC needs based on the methods
@ -70,7 +70,7 @@ static cell determine_inline_cache_type(array *cache_entries)
if(!seen_hi_tag && !seen_tuple) return PIC_TAG; if(!seen_hi_tag && !seen_tuple) return PIC_TAG;
critical_error("Oops",0); critical_error("Oops",0);
return -1; return 0;
} }
static void update_pic_count(cell type) static void update_pic_count(cell type)

8
vm/io.cpp
View File

@ -14,14 +14,14 @@ The Factor library provides platform-specific code for Unix and Windows
with many more capabilities so these words are not usually used in with many more capabilities so these words are not usually used in
normal operation. */ normal operation. */
void init_c_io(void) void init_c_io()
{ {
userenv[STDIN_ENV] = allot_alien(F,(cell)stdin); userenv[STDIN_ENV] = allot_alien(F,(cell)stdin);
userenv[STDOUT_ENV] = allot_alien(F,(cell)stdout); userenv[STDOUT_ENV] = allot_alien(F,(cell)stdout);
userenv[STDERR_ENV] = allot_alien(F,(cell)stderr); userenv[STDERR_ENV] = allot_alien(F,(cell)stderr);
} }
void io_error(void) void io_error()
{ {
#ifndef WINCE #ifndef WINCE
if(errno == EINTR) if(errno == EINTR)
@ -216,12 +216,12 @@ PRIMITIVE(fclose)
/* This function is used by FFI I/O. Accessing the errno global directly is /* This function is used by FFI I/O. Accessing the errno global directly is
not portable, since on some libc's errno is not a global but a funky macro that not portable, since on some libc's errno is not a global but a funky macro that
reads thread-local storage. */ reads thread-local storage. */
VM_C_API int err_no(void) VM_C_API int err_no()
{ {
return errno; return errno;
} }
VM_C_API void clear_err_no(void) VM_C_API void clear_err_no()
{ {
errno = 0; errno = 0;
} }

8
vm/io.hpp
View File

@ -1,8 +1,8 @@
namespace factor namespace factor
{ {
void init_c_io(void); void init_c_io();
void io_error(void); void io_error();
PRIMITIVE(fopen); PRIMITIVE(fopen);
PRIMITIVE(fgetc); PRIMITIVE(fgetc);
@ -18,7 +18,7 @@ PRIMITIVE(open_file);
PRIMITIVE(existsp); PRIMITIVE(existsp);
PRIMITIVE(read_dir); PRIMITIVE(read_dir);
VM_C_API int err_no(void); VM_C_API int err_no();
VM_C_API void clear_err_no(void); VM_C_API void clear_err_no();
} }

16
vm/layouts.hpp
View File

@ -93,6 +93,9 @@ class object;
struct header { struct header {
cell value; cell value;
/* Default ctor to make gcc 3.x happy */
header() { abort(); }
header(cell value_) : value(value_ << TAG_BITS) {} header(cell value_) : value(value_ << TAG_BITS) {}
void check_header() { void check_header() {
@ -193,26 +196,19 @@ struct heap_block
unsigned char status; /* free or allocated? */ unsigned char status; /* free or allocated? */
unsigned char type; /* this is WORD_TYPE or QUOTATION_TYPE */ 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 last_scan; /* the youngest generation in which this block's literals may live */
char needs_fixup; /* is this a new block that needs full fixup? */ unsigned char needs_fixup; /* is this a new block that needs full fixup? */
/* In bytes, includes this header */ /* In bytes, includes this header */
cell size; cell size;
/* Used during compaction */
heap_block *forwarding;
}; };
struct free_heap_block struct free_heap_block : public heap_block
{ {
heap_block block;
/* Filled in on image load */
free_heap_block *next_free; free_heap_block *next_free;
}; };
struct code_block struct code_block : public heap_block
{ {
heap_block block;
cell literals; /* # bytes */ cell literals; /* # bytes */
cell relocation; /* tagged pointer to byte-array or f */ cell relocation; /* tagged pointer to byte-array or f */

2
vm/mach_signal.cpp
View File

@ -169,7 +169,7 @@ mach_exception_thread (void *arg)
} }
/* Initialize the Mach exception handler thread. */ /* Initialize the Mach exception handler thread. */
void mach_initialize (void) void mach_initialize ()
{ {
mach_port_t self; mach_port_t self;
exception_mask_t mask; exception_mask_t mask;

2
vm/mach_signal.hpp
View File

@ -79,6 +79,6 @@ catch_exception_raise_state_identity (mach_port_t exception_port,
namespace factor namespace factor
{ {
void mach_initialize (void); void mach_initialize ();
} }

13
vm/master.hpp Normal file → Executable file
View File

@ -9,6 +9,7 @@
#include <assert.h> #include <assert.h>
#endif #endif
/* C headers */
#include <fcntl.h> #include <fcntl.h>
#include <limits.h> #include <limits.h>
#include <math.h> #include <math.h>
@ -20,6 +21,18 @@
#include <time.h> #include <time.h>
#include <sys/param.h> #include <sys/param.h>
/* C++ headers */
#if __GNUC__ == 4
#include <tr1/unordered_map>
#define unordered_map std::tr1::unordered_map
#elif __GNUC__ == 3
#include <boost/unordered_map.hpp>
#define unordered_map boost::unordered_map
#else
#error Factor requires GCC 3.x or later
#endif
/* Factor headers */
#include "layouts.hpp" #include "layouts.hpp"
#include "platform.hpp" #include "platform.hpp"
#include "primitives.hpp" #include "primitives.hpp"

8
vm/math.cpp Normal file → Executable file
View File

@ -219,7 +219,7 @@ PRIMITIVE(byte_array_to_bignum)
drepl(tag<bignum>(result)); drepl(tag<bignum>(result));
} }
cell unbox_array_size(void) cell unbox_array_size()
{ {
switch(tagged<object>(dpeek()).type()) switch(tagged<object>(dpeek()).type())
{ {
@ -377,7 +377,7 @@ VM_C_API fixnum to_fixnum(cell tagged)
return bignum_to_fixnum(untag<bignum>(tagged)); return bignum_to_fixnum(untag<bignum>(tagged));
default: default:
type_error(FIXNUM_TYPE,tagged); type_error(FIXNUM_TYPE,tagged);
return -1; /* can't happen */ return 0; /* can't happen */
} }
} }
@ -444,7 +444,7 @@ VM_C_API s64 to_signed_8(cell obj)
return bignum_to_long_long(untag<bignum>(obj)); return bignum_to_long_long(untag<bignum>(obj));
default: default:
type_error(BIGNUM_TYPE,obj); type_error(BIGNUM_TYPE,obj);
return -1; return 0;
} }
} }
@ -466,7 +466,7 @@ VM_C_API u64 to_unsigned_8(cell obj)
return bignum_to_ulong_long(untag<bignum>(obj)); return bignum_to_ulong_long(untag<bignum>(obj));
default: default:
type_error(BIGNUM_TYPE,obj); type_error(BIGNUM_TYPE,obj);
return -1; return 0;
} }
} }

2
vm/math.hpp
View File

@ -59,7 +59,7 @@ inline static cell allot_cell(cell x)
return tag_fixnum(x); return tag_fixnum(x);
} }
cell unbox_array_size(void); cell unbox_array_size();
inline static double untag_float(cell tagged) inline static double untag_float(cell tagged)
{ {

2
vm/os-freebsd.cpp
View File

@ -4,7 +4,7 @@ namespace factor
{ {
/* From SBCL */ /* From SBCL */
const char *vm_executable_path(void) const char *vm_executable_path()
{ {
char path[PATH_MAX + 1]; char path[PATH_MAX + 1];

2
vm/os-freebsd.hpp
View File

@ -1,7 +1,7 @@
#include <osreldate.h> #include <osreldate.h>
#include <sys/sysctl.h> #include <sys/sysctl.h>
extern "C" int getosreldate(void); extern "C" int getosreldate();
#ifndef KERN_PROC_PATHNAME #ifndef KERN_PROC_PATHNAME
#define KERN_PROC_PATHNAME 12 #define KERN_PROC_PATHNAME 12

6
vm/os-genunix.cpp
View File

@ -8,17 +8,17 @@ void c_to_factor_toplevel(cell quot)
c_to_factor(quot); c_to_factor(quot);
} }
void init_signals(void) void init_signals()
{ {
unix_init_signals(); unix_init_signals();
} }
void early_init(void) { } void early_init() { }
#define SUFFIX ".image" #define SUFFIX ".image"
#define SUFFIX_LEN 6 #define SUFFIX_LEN 6
const char *default_image_path(void) const char *default_image_path()
{ {
const char *path = vm_executable_path(); const char *path = vm_executable_path();

8
vm/os-genunix.hpp
View File

@ -5,9 +5,9 @@ namespace factor
#define NULL_DLL NULL #define NULL_DLL NULL
void c_to_factor_toplevel(cell quot); void c_to_factor_toplevel(cell quot);
void init_signals(void); void init_signals();
void early_init(void); void early_init();
const char *vm_executable_path(void); const char *vm_executable_path();
const char *default_image_path(void); const char *default_image_path();
} }

6
vm/os-linux.cpp
View File

@ -4,7 +4,7 @@ namespace factor
{ {
/* Snarfed from SBCL linux-so.c. You must free() this yourself. */ /* Snarfed from SBCL linux-so.c. You must free() this yourself. */
const char *vm_executable_path(void) const char *vm_executable_path()
{ {
char *path = (char *)safe_malloc(PATH_MAX + 1); char *path = (char *)safe_malloc(PATH_MAX + 1);
@ -23,7 +23,7 @@ const char *vm_executable_path(void)
#ifdef SYS_inotify_init #ifdef SYS_inotify_init
int inotify_init(void) int inotify_init()
{ {
return syscall(SYS_inotify_init); return syscall(SYS_inotify_init);
} }
@ -40,7 +40,7 @@ int inotify_rm_watch(int fd, u32 wd)
#else #else
int inotify_init(void) int inotify_init()
{ {
not_implemented_error(); not_implemented_error();
return -1; return -1;

2
vm/os-linux.hpp
View File

@ -3,7 +3,7 @@
namespace factor namespace factor
{ {
int inotify_init(void); int inotify_init();
int inotify_add_watch(int fd, const char *name, u32 mask); int inotify_add_watch(int fd, const char *name, u32 mask);
int inotify_rm_watch(int fd, u32 wd); int inotify_rm_watch(int fd, u32 wd);

8
vm/os-macosx.hpp
View File

@ -5,11 +5,11 @@ namespace factor
#define FACTOR_OS_STRING "macosx" #define FACTOR_OS_STRING "macosx"
#define NULL_DLL "libfactor.dylib" #define NULL_DLL "libfactor.dylib"
void init_signals(void); void init_signals();
void early_init(void); void early_init();
const char *vm_executable_path(void); const char *vm_executable_path();
const char *default_image_path(void); const char *default_image_path();
inline static void *ucontext_stack_pointer(void *uap) inline static void *ucontext_stack_pointer(void *uap)
{ {

2
vm/os-netbsd.cpp
View File

@ -5,7 +5,7 @@ namespace factor
extern "C" int main(); extern "C" int main();
const char *vm_executable_path(void) const char *vm_executable_path()
{ {
static Dl_info info = {0}; static Dl_info info = {0};
if (!info.dli_fname) if (!info.dli_fname)

2
vm/os-openbsd.cpp
View File

@ -3,7 +3,7 @@
namespace factor namespace factor
{ {
const char *vm_executable_path(void) const char *vm_executable_path()
{ {
return NULL; return NULL;
} }

2
vm/os-solaris.cpp
View File

@ -3,7 +3,7 @@
namespace factor namespace factor
{ {
const char *vm_executable_path(void) const char *vm_executable_path()
{ {
return NULL; return NULL;
} }

10
vm/os-unix.cpp
View File

@ -19,7 +19,7 @@ void start_thread(void *(*start_routine)(void *))
static void *null_dll; static void *null_dll;
s64 current_micros(void) s64 current_micros()
{ {
struct timeval t; struct timeval t;
gettimeofday(&t,NULL); gettimeofday(&t,NULL);
@ -31,7 +31,7 @@ void sleep_micros(cell usec)
usleep(usec); usleep(usec);
} }
void init_ffi(void) void init_ffi()
{ {
/* NULL_DLL is "libfactor.dylib" for OS X and NULL for generic unix */ /* NULL_DLL is "libfactor.dylib" for OS X and NULL for generic unix */
null_dll = dlopen(NULL_DLL,RTLD_LAZY); null_dll = dlopen(NULL_DLL,RTLD_LAZY);
@ -145,7 +145,7 @@ static void sigaction_safe(int signum, const struct sigaction *act, struct sigac
fatal_error("sigaction failed", 0); fatal_error("sigaction failed", 0);
} }
void unix_init_signals(void) void unix_init_signals()
{ {
struct sigaction memory_sigaction; struct sigaction memory_sigaction;
struct sigaction misc_sigaction; struct sigaction misc_sigaction;
@ -279,7 +279,7 @@ void *stdin_loop(void *arg)
return NULL; return NULL;
} }
void open_console(void) void open_console()
{ {
int filedes[2]; int filedes[2];
@ -304,7 +304,7 @@ void open_console(void)
start_thread(stdin_loop); start_thread(stdin_loop);
} }
VM_C_API void wait_for_stdin(void) VM_C_API void wait_for_stdin()
{ {
if(write(control_write,"X",1) != 1) if(write(control_write,"X",1) != 1)
{ {

8
vm/os-unix.hpp
View File

@ -42,18 +42,18 @@ typedef char symbol_char;
void start_thread(void *(*start_routine)(void *)); void start_thread(void *(*start_routine)(void *));
void init_ffi(void); void init_ffi();
void ffi_dlopen(dll *dll); void ffi_dlopen(dll *dll);
void *ffi_dlsym(dll *dll, symbol_char *symbol); void *ffi_dlsym(dll *dll, symbol_char *symbol);
void ffi_dlclose(dll *dll); void ffi_dlclose(dll *dll);
void unix_init_signals(void); void unix_init_signals();
void signal_handler(int signal, siginfo_t* siginfo, void* uap); void signal_handler(int signal, siginfo_t* siginfo, void* uap);
void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap); void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap);
s64 current_micros(void); s64 current_micros();
void sleep_micros(cell usec); void sleep_micros(cell usec);
void open_console(void); void open_console();
} }

4
vm/os-windows-ce.cpp
View File

@ -3,7 +3,7 @@
namespace factor namespace factor
{ {
s64 current_micros(void) s64 current_micros()
{ {
SYSTEMTIME st; SYSTEMTIME st;
FILETIME ft; FILETIME ft;
@ -40,6 +40,6 @@ void c_to_factor_toplevel(cell quot)
c_to_factor(quot); c_to_factor(quot);
} }
void open_console(void) { } void open_console() { }
} }

4
vm/os-windows-ce.hpp
View File

@ -22,8 +22,8 @@ char *getenv(char *name);
#define snprintf _snprintf #define snprintf _snprintf
#define snwprintf _snwprintf #define snwprintf _snwprintf
s64 current_micros(void); s64 current_micros();
void c_to_factor_toplevel(cell quot); void c_to_factor_toplevel(cell quot);
void open_console(void); void open_console();
} }

10
vm/os-windows-nt.cpp
View File

@ -3,7 +3,7 @@
namespace factor namespace factor
{ {
s64 current_micros(void) s64 current_micros()
{ {
FILETIME t; FILETIME t;
GetSystemTimeAsFileTime(&t); GetSystemTimeAsFileTime(&t);
@ -11,13 +11,13 @@ s64 current_micros(void)
- EPOCH_OFFSET) / 10; - EPOCH_OFFSET) / 10;
} }
long exception_handler(PEXCEPTION_POINTERS pe) FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe)
{ {
PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord; PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord;
CONTEXT *c = (CONTEXT*)pe->ContextRecord; CONTEXT *c = (CONTEXT*)pe->ContextRecord;
if(in_code_heap_p(c->EIP)) if(in_code_heap_p(c->EIP))
signal_callstack_top = (void *)c->ESP; signal_callstack_top = (stack_frame *)c->ESP;
else else
signal_callstack_top = NULL; signal_callstack_top = NULL;
@ -43,13 +43,13 @@ long exception_handler(PEXCEPTION_POINTERS pe)
void c_to_factor_toplevel(cell quot) void c_to_factor_toplevel(cell quot)
{ {
if(!AddVectoredExceptionHandler(0, (void*)exception_handler)) if(!AddVectoredExceptionHandler(0, (PVECTORED_EXCEPTION_HANDLER)exception_handler))
fatal_error("AddVectoredExceptionHandler failed", 0); fatal_error("AddVectoredExceptionHandler failed", 0);
c_to_factor(quot); c_to_factor(quot);
RemoveVectoredExceptionHandler((void *)exception_handler); RemoveVectoredExceptionHandler((void *)exception_handler);
} }
void open_console(void) void open_console()
{ {
} }

8
vm/os-windows-nt.hpp
View File

@ -5,8 +5,8 @@
#define UNICODE #define UNICODE
#endif #endif
#include <shellapi.h>
#include <windows.h> #include <windows.h>
#include <shellapi.h>
namespace factor namespace factor
{ {
@ -17,8 +17,10 @@ typedef char symbol_char;
#define FACTOR_DLL L"factor.dll" #define FACTOR_DLL L"factor.dll"
#define FACTOR_DLL_NAME "factor.dll" #define FACTOR_DLL_NAME "factor.dll"
#define FACTOR_STDCALL __attribute__((stdcall))
void c_to_factor_toplevel(cell quot); void c_to_factor_toplevel(cell quot);
long exception_handler(PEXCEPTION_POINTERS pe); FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe);
void open_console(void); void open_console();
} }

16
vm/os-windows.cpp
View File

@ -5,7 +5,7 @@ namespace factor
HMODULE hFactorDll; HMODULE hFactorDll;
void init_ffi(void) void init_ffi()
{ {
hFactorDll = GetModuleHandle(FACTOR_DLL); hFactorDll = GetModuleHandle(FACTOR_DLL);
if(!hFactorDll) if(!hFactorDll)
@ -14,12 +14,12 @@ void init_ffi(void)
void ffi_dlopen(dll *dll) void ffi_dlopen(dll *dll)
{ {
dll->dll = LoadLibraryEx(alien_offset(dll->path), NULL, 0); dll->dll = LoadLibraryEx((WCHAR *)alien_offset(dll->path), NULL, 0);
} }
void *ffi_dlsym(dll *dll, symbol_char *symbol) void *ffi_dlsym(dll *dll, symbol_char *symbol)
{ {
return GetProcAddress(dll ? (HMODULE)dll->dll : hFactorDll, symbol); return (void *)GetProcAddress(dll ? (HMODULE)dll->dll : hFactorDll, symbol);
} }
void ffi_dlclose(dll *dll) void ffi_dlclose(dll *dll)
@ -63,7 +63,7 @@ void windows_image_path(vm_char *full_path, vm_char *temp_path, unsigned int len
} }
/* You must free() this yourself. */ /* You must free() this yourself. */
const vm_char *default_image_path(void) const vm_char *default_image_path()
{ {
vm_char full_path[MAX_UNICODE_PATH]; vm_char full_path[MAX_UNICODE_PATH];
vm_char *ptr; vm_char *ptr;
@ -82,7 +82,7 @@ const vm_char *default_image_path(void)
} }
/* You must free() this yourself. */ /* You must free() this yourself. */
const vm_char *vm_executable_path(void) const vm_char *vm_executable_path()
{ {
vm_char full_path[MAX_UNICODE_PATH]; vm_char full_path[MAX_UNICODE_PATH];
if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH)) if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH))
@ -93,7 +93,7 @@ const vm_char *vm_executable_path(void)
PRIMITIVE(existsp) PRIMITIVE(existsp)
{ {
vm_char *path = (vm_char *)(untag_check<byte_array>(dpop()) + 1); vm_char *path = untag_check<byte_array>(dpop())->data<vm_char>();
box_boolean(windows_stat(path)); box_boolean(windows_stat(path));
} }
@ -113,7 +113,7 @@ segment *alloc_segment(cell size)
getpagesize(), PAGE_NOACCESS, &ignore)) getpagesize(), PAGE_NOACCESS, &ignore))
fatal_error("Cannot allocate high guard page", (cell)mem); fatal_error("Cannot allocate high guard page", (cell)mem);
segment *block = safe_malloc(sizeof(segment)); segment *block = (segment *)safe_malloc(sizeof(segment));
block->start = (cell)mem + getpagesize(); block->start = (cell)mem + getpagesize();
block->size = size; block->size = size;
@ -131,7 +131,7 @@ void dealloc_segment(segment *block)
free(block); free(block);
} }
long getpagesize(void) long getpagesize()
{ {
static long g_pagesize = 0; static long g_pagesize = 0;
if (! g_pagesize) if (! g_pagesize)

14
vm/os-windows.hpp
View File

@ -41,19 +41,19 @@ typedef wchar_t vm_char;
/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */ /* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
#define EPOCH_OFFSET 0x019db1ded53e8000LL #define EPOCH_OFFSET 0x019db1ded53e8000LL
void init_ffi(void); void init_ffi();
void ffi_dlopen(dll *dll); void ffi_dlopen(dll *dll);
void *ffi_dlsym(dll *dll, symbol_char *symbol); void *ffi_dlsym(dll *dll, symbol_char *symbol);
void ffi_dlclose(dll *dll); void ffi_dlclose(dll *dll);
void sleep_micros(u64 msec); void sleep_micros(u64 msec);
inline static void init_signals(void) {} inline static void init_signals() {}
inline static void early_init(void) {} inline static void early_init() {}
const vm_char *vm_executable_path(void); const vm_char *vm_executable_path();
const vm_char *default_image_path(void); const vm_char *default_image_path();
long getpagesize (void); long getpagesize ();
s64 current_micros(void); s64 current_micros();
} }

2
vm/primitives.cpp
View File

@ -135,7 +135,7 @@ const primitive_type primitives[] = {
primitive_sleep, primitive_sleep,
primitive_tuple_boa, primitive_tuple_boa,
primitive_callstack_to_array, primitive_callstack_to_array,
primitive_innermost_stack_frame_quot, primitive_innermost_stack_frame_executing,
primitive_innermost_stack_frame_scan, primitive_innermost_stack_frame_scan,
primitive_set_innermost_stack_frame_quot, primitive_set_innermost_stack_frame_quot,
primitive_call_clear, primitive_call_clear,

2
vm/profiler.cpp
View File

@ -5,7 +5,7 @@ namespace factor
bool profiling_p; bool profiling_p;
void init_profiler(void) void init_profiler()
{ {
profiling_p = false; profiling_p = false;
} }

2
vm/profiler.hpp
View File

@ -2,7 +2,7 @@ namespace factor
{ {
extern bool profiling_p; extern bool profiling_p;
void init_profiler(void); void init_profiler();
code_block *compile_profiling_stub(cell word); code_block *compile_profiling_stub(cell word);
PRIMITIVE(profiling); PRIMITIVE(profiling);

4
vm/quotations.cpp
View File

@ -251,7 +251,7 @@ void quotation_jit::iterate_quotation()
void set_quot_xt(quotation *quot, code_block *code) void set_quot_xt(quotation *quot, code_block *code)
{ {
if(code->block.type != QUOTATION_TYPE) if(code->type != QUOTATION_TYPE)
critical_error("Bad param to set_quot_xt",(cell)code); critical_error("Bad param to set_quot_xt",(cell)code);
quot->code = code; quot->code = code;
@ -297,7 +297,7 @@ PRIMITIVE(quotation_xt)
drepl(allot_cell((cell)quot->xt)); drepl(allot_cell((cell)quot->xt));
} }
void compile_all_words(void) void compile_all_words()
{ {
gc_root<array> words(find_all_words()); gc_root<array> words(find_all_words());

2
vm/quotations.hpp
View File

@ -28,7 +28,7 @@ fixnum quot_code_offset_to_scan(cell quot, cell offset);
PRIMITIVE(jit_compile); PRIMITIVE(jit_compile);
void compile_all_words(void); void compile_all_words();
PRIMITIVE(array_to_quotation); PRIMITIVE(array_to_quotation);
PRIMITIVE(quotation_xt); PRIMITIVE(quotation_xt);

7
vm/run.hpp
View File

@ -14,7 +14,7 @@ enum special_object {
BREAK_ENV = 5, /* quotation called by throw primitive */ BREAK_ENV = 5, /* quotation called by throw primitive */
ERROR_ENV, /* a marker consed onto kernel errors */ ERROR_ENV, /* a marker consed onto kernel errors */
cell_SIZE_ENV = 7, /* sizeof(cell) */ CELL_SIZE_ENV = 7, /* sizeof(cell) */
CPU_ENV, /* CPU architecture */ CPU_ENV, /* CPU architecture */
OS_ENV, /* operating system name */ OS_ENV, /* operating system name */
@ -93,6 +93,11 @@ enum special_object {
#define FIRST_SAVE_ENV BOOT_ENV #define FIRST_SAVE_ENV BOOT_ENV
#define LAST_SAVE_ENV STAGE2_ENV #define LAST_SAVE_ENV STAGE2_ENV
inline static bool save_env_p(cell i)
{
return (i >= FIRST_SAVE_ENV && i <= LAST_SAVE_ENV) || i == STACK_TRACES_ENV;
}
/* Canonical T object. It's just a word */ /* Canonical T object. It's just a word */
extern cell T; extern cell T;

2
vm/stacks.hpp
View File

@ -4,7 +4,7 @@ namespace factor
#define DEFPUSHPOP(prefix,ptr) \ #define DEFPUSHPOP(prefix,ptr) \
inline static cell prefix##peek() { return *(cell *)ptr; } \ inline static cell prefix##peek() { return *(cell *)ptr; } \
inline static void prefix##repl(cell tagged) { *(cell *)ptr = tagged; } \ inline static void prefix##repl(cell tagged) { *(cell *)ptr = tagged; } \
inline static cell prefix##pop(void) \ inline static cell prefix##pop() \
{ \ { \
cell value = prefix##peek(); \ cell value = prefix##peek(); \
ptr -= sizeof(cell); \ ptr -= sizeof(cell); \

4
vm/utilities.cpp
View File

@ -20,7 +20,7 @@ vm_char *safe_strdup(const vm_char *str)
/* We don't use printf directly, because format directives are not portable. /* We don't use printf directly, because format directives are not portable.
Instead we define the common cases here. */ Instead we define the common cases here. */
void nl(void) void nl()
{ {
fputs("\n",stdout); fputs("\n",stdout);
} }
@ -50,7 +50,7 @@ void print_fixnum(fixnum x)
printf(FIXNUM_FORMAT,x); printf(FIXNUM_FORMAT,x);
} }
cell read_cell_hex(void) cell read_cell_hex()
{ {
cell cell; cell cell;
if(scanf(cell_HEX_FORMAT,&cell) < 0) exit(1); if(scanf(cell_HEX_FORMAT,&cell) < 0) exit(1);

4
vm/utilities.hpp
View File

@ -4,12 +4,12 @@ namespace factor
void *safe_malloc(size_t size); void *safe_malloc(size_t size);
vm_char *safe_strdup(const vm_char *str); vm_char *safe_strdup(const vm_char *str);
void nl(void); void nl();
void print_string(const char *str); void print_string(const char *str);
void print_cell(cell x); void print_cell(cell x);
void print_cell_hex(cell x); void print_cell_hex(cell x);
void print_cell_hex_pad(cell x); void print_cell_hex_pad(cell x);
void print_fixnum(fixnum x); void print_fixnum(fixnum x);
cell read_cell_hex(void); cell read_cell_hex();
} }

2
vm/words.cpp
View File

@ -44,7 +44,7 @@ PRIMITIVE(word_xt)
word *w = untag_check<word>(dpop()); word *w = untag_check<word>(dpop());
code_block *code = (profiling_p ? w->profiling : w->code); code_block *code = (profiling_p ? w->profiling : w->code);
dpush(allot_cell((cell)code->xt())); dpush(allot_cell((cell)code->xt()));
dpush(allot_cell((cell)code + code->block.size)); dpush(allot_cell((cell)code + code->size));
} }
/* Allocates memory */ /* Allocates memory */

2
vm/words.hpp
View File

@ -9,7 +9,7 @@ void update_word_xt(cell word);
inline bool word_optimized_p(word *word) inline bool word_optimized_p(word *word)
{ {
return word->code->block.type == WORD_TYPE; return word->code->type == WORD_TYPE;
} }
PRIMITIVE(optimized_p); PRIMITIVE(optimized_p);

4
vm/write_barrier.cpp Normal file → Executable file
View File

@ -4,4 +4,8 @@ using namespace factor;
cell cards_offset; cell cards_offset;
cell decks_offset; cell decks_offset;
namespace factor
{
cell allot_markers_offset; cell allot_markers_offset;
}

9
vm/write_barrier.hpp Normal file → Executable file
View File

@ -6,6 +6,9 @@ card has a slot written to.
the offset of the first object is set by the allocator. */ the offset of the first object is set by the allocator. */
VM_C_API factor::cell cards_offset;
VM_C_API factor::cell decks_offset;
namespace factor namespace factor
{ {
@ -19,8 +22,6 @@ typedef u8 card;
#define CARD_SIZE (1<<CARD_BITS) #define CARD_SIZE (1<<CARD_BITS)
#define ADDR_CARD_MASK (CARD_SIZE-1) #define ADDR_CARD_MASK (CARD_SIZE-1)
VM_C_API cell cards_offset;
inline static card *addr_to_card(cell a) inline static card *addr_to_card(cell a)
{ {
return (card*)(((cell)(a) >> CARD_BITS) + cards_offset); return (card*)(((cell)(a) >> CARD_BITS) + cards_offset);
@ -42,8 +43,6 @@ typedef u8 card_deck;
#define DECK_SIZE (1<<DECK_BITS) #define DECK_SIZE (1<<DECK_BITS)
#define ADDR_DECK_MASK (DECK_SIZE-1) #define ADDR_DECK_MASK (DECK_SIZE-1)
VM_C_API cell decks_offset;
inline static card_deck *addr_to_deck(cell a) inline static card_deck *addr_to_deck(cell a)
{ {
return (card_deck *)(((cell)a >> DECK_BITS) + decks_offset); return (card_deck *)(((cell)a >> DECK_BITS) + decks_offset);
@ -61,7 +60,7 @@ inline static card *deck_to_card(card_deck *d)
#define INVALID_ALLOT_MARKER 0xff #define INVALID_ALLOT_MARKER 0xff
VM_C_API cell allot_markers_offset; extern cell allot_markers_offset;
inline static card *addr_to_allot_marker(object *a) inline static card *addr_to_allot_marker(object *a)
{ {