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

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

db4
Doug Coleman 2009-09-25 22:24:54 -05:00
parent 6fb6cbf0fc 8610fa5e48
commit caf8e5d159
67 changed files with 609 additions and 935 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -38,7 +38,6 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/byte_arrays.o \ vm/byte_arrays.o \
vm/callstack.o \ vm/callstack.o \
vm/code_block.o \ vm/code_block.o \
vm/code_gc.o \
vm/code_heap.o \ vm/code_heap.o \
vm/contexts.o \ vm/contexts.o \
vm/data_gc.o \ vm/data_gc.o \
@ -47,6 +46,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/dispatch.o \ vm/dispatch.o \
vm/errors.o \ vm/errors.o \
vm/factor.o \ vm/factor.o \
vm/heap.o \
vm/image.o \ vm/image.o \
vm/inline_cache.o \ vm/inline_cache.o \
vm/io.o \ vm/io.o \

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

@ -163,6 +163,7 @@ USERENV: jit-3dip 40
USERENV: jit-execute-word 41 USERENV: jit-execute-word 41
USERENV: jit-execute-jump 42 USERENV: jit-execute-jump 42
USERENV: jit-execute-call 43 USERENV: jit-execute-call 43
USERENV: jit-declare-word 44
! PIC stubs ! PIC stubs
USERENV: pic-load 47 USERENV: pic-load 47
@ -493,6 +494,7 @@ M: quotation '
\ inline-cache-miss-tail \ pic-miss-tail-word set \ inline-cache-miss-tail \ pic-miss-tail-word set
\ mega-cache-lookup \ mega-lookup-word set \ mega-cache-lookup \ mega-lookup-word set
\ mega-cache-miss \ mega-miss-word set \ mega-cache-miss \ mega-miss-word set
\ declare jit-declare-word set
[ undefined ] undefined-quot set ; [ undefined ] undefined-quot set ;
: emit-userenvs ( -- ) : emit-userenvs ( -- )

6
basis/compiler/cfg/builder/builder-tests.factor
View File

@ -4,6 +4,7 @@ compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
compiler.cfg arrays locals byte-arrays kernel.private math compiler.cfg arrays locals byte-arrays kernel.private math
slots.private vectors sbufs strings math.partial-dispatch slots.private vectors sbufs strings math.partial-dispatch
hashtables assocs combinators.short-circuit
strings.private accessors compiler.cfg.instructions ; strings.private accessors compiler.cfg.instructions ;
IN: compiler.cfg.builder.tests IN: compiler.cfg.builder.tests
@ -204,4 +205,7 @@ IN: compiler.cfg.builder.tests
[ [ ##box-alien? ] contains-insn? ] [ [ ##box-alien? ] contains-insn? ]
[ [ ##box-float? ] contains-insn? ] bi [ [ ##box-float? ] contains-insn? ] bi
] unit-test ] unit-test
] when ] when
! Regression. Make sure everything is inlined correctly
[ f ] [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test

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

@ -271,7 +271,7 @@ M: _gc generate-insn
[ data-values>> save-data-regs ] [ data-values>> save-data-regs ]
[ [ tagged-values>> ] [ temp1>> ] bi save-gc-roots ] [ [ tagged-values>> ] [ temp1>> ] bi save-gc-roots ]
[ [ temp1>> ] [ temp2>> ] bi t %save-context ] [ [ temp1>> ] [ temp2>> ] bi t %save-context ]
[ tagged-values>> length %call-gc ] [ [ tagged-values>> length ] [ temp1>> ] bi %call-gc ]
[ [ tagged-values>> ] [ temp1>> ] bi load-gc-roots ] [ [ tagged-values>> ] [ temp1>> ] bi load-gc-roots ]
[ data-values>> load-data-regs ] [ data-values>> load-data-regs ]
} cleave } cleave
@ -447,7 +447,7 @@ M: ##alien-indirect generate-insn
! Generate code for boxing input parameters in a callback. ! Generate code for boxing input parameters in a callback.
[ [
dup \ %save-param-reg move-parameters dup \ %save-param-reg move-parameters
"nest_stacks" %vm-invoke-1st-arg %nest-stacks
box-parameters box-parameters
] with-param-regs ; ] with-param-regs ;
@ -485,8 +485,6 @@ TUPLE: callback-context ;
[ callback-context new do-callback ] % [ callback-context new do-callback ] %
] [ ] make ; ] [ ] make ;
: %unnest-stacks ( -- ) "unnest_stacks" %vm-invoke-1st-arg ;
M: ##callback-return generate-insn M: ##callback-return generate-insn
#! All the extra book-keeping for %unwind is only for x86. #! All the extra book-keeping for %unwind is only for x86.
#! On other platforms its an alias for %return. #! On other platforms its an alias for %return.

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

@ -588,3 +588,8 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
123 >>parents 123 >>parents
ffi_test_48 ffi_test_48
] unit-test ] unit-test
! Regression: calling an undefined function would raise a protection fault
FUNCTION: void this_does_not_exist ( ) ;
[ this_does_not_exist ] [ { "kernel-error" 10 f f } = ] must-fail-with

9
basis/cpu/architecture/architecture.factor
View File

@ -296,7 +296,7 @@ HOOK: %write-barrier cpu ( src card# table -- )
HOOK: %check-nursery cpu ( label temp1 temp2 -- ) HOOK: %check-nursery cpu ( label temp1 temp2 -- )
HOOK: %save-gc-root cpu ( gc-root register -- ) HOOK: %save-gc-root cpu ( gc-root register -- )
HOOK: %load-gc-root cpu ( gc-root register -- ) HOOK: %load-gc-root cpu ( gc-root register -- )
HOOK: %call-gc cpu ( gc-root-count -- ) HOOK: %call-gc cpu ( gc-root-count temp1 -- )
HOOK: %prologue cpu ( n -- ) HOOK: %prologue cpu ( n -- )
HOOK: %epilogue cpu ( n -- ) HOOK: %epilogue cpu ( n -- )
@ -383,9 +383,6 @@ M: object %prepare-var-args ;
HOOK: %alien-invoke cpu ( function library -- ) HOOK: %alien-invoke cpu ( function library -- )
HOOK: %vm-invoke-1st-arg cpu ( function -- )
HOOK: %vm-invoke-3rd-arg cpu ( function -- )
HOOK: %cleanup cpu ( params -- ) HOOK: %cleanup cpu ( params -- )
M: object %cleanup ( params -- ) drop ; M: object %cleanup ( params -- ) drop ;
@ -398,6 +395,10 @@ HOOK: %alien-callback cpu ( quot -- )
HOOK: %callback-value cpu ( ctype -- ) HOOK: %callback-value cpu ( ctype -- )
HOOK: %nest-stacks cpu ( -- )
HOOK: %unnest-stacks cpu ( -- )
! Return to caller with stdcall unwinding (only for x86) ! Return to caller with stdcall unwinding (only for x86)
HOOK: %callback-return cpu ( params -- ) HOOK: %callback-return cpu ( params -- )

11
basis/cpu/ppc/ppc.factor
View File

@ -40,9 +40,6 @@ enable-float-intrinsics
M: ppc %vm-field-ptr ( dst field -- ) %load-vm-field-addr ; M: ppc %vm-field-ptr ( dst field -- ) %load-vm-field-addr ;
M: ppc %vm-invoke-1st-arg ( function -- ) f %alien-invoke ;
M: ppc %vm-invoke-3rd-arg ( function -- ) f %alien-invoke ;
M: ppc machine-registers M: ppc machine-registers
{ {
{ int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] } { int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] }
@ -513,7 +510,7 @@ M:: ppc %save-gc-root ( gc-root register -- )
M:: ppc %load-gc-root ( gc-root register -- ) M:: ppc %load-gc-root ( gc-root register -- )
register 1 gc-root gc-root@ LWZ ; register 1 gc-root gc-root@ LWZ ;
M:: ppc %call-gc ( gc-root-count -- ) M:: ppc %call-gc ( gc-root-count temp -- )
3 1 gc-root-base local@ ADDI 3 1 gc-root-base local@ ADDI
gc-root-count 4 LI gc-root-count 4 LI
"inline_gc" f %alien-invoke ; "inline_gc" f %alien-invoke ;
@ -781,6 +778,12 @@ M: ppc %box-small-struct ( c-type -- )
4 3 4 LWZ 4 3 4 LWZ
3 3 0 LWZ ; 3 3 0 LWZ ;
M: ppc %nest-stacks ( -- )
"nest_stacks" f %alien-invoke ;
M: ppc %unnest-stacks ( -- )
"unnest_stacks" f %alien-invoke ;
M: ppc %unbox-small-struct ( size -- ) M: ppc %unbox-small-struct ( size -- )
#! Alien must be in EAX. #! Alien must be in EAX.
heap-size cell align cell /i { heap-size cell align cell /i {

42
basis/cpu/x86/32/32.factor
View File

@ -38,9 +38,8 @@ M:: x86.32 %dispatch ( src temp -- )
bi ; bi ;
! Registers for fastcall ! Registers for fastcall
M: x86.32 param-reg-1 EAX ; : param-reg-1 ( -- reg ) EAX ;
M: x86.32 param-reg-2 EDX ; : param-reg-2 ( -- reg ) EDX ;
M: x86.32 param-reg-3 ECX ;
M: x86.32 pic-tail-reg EBX ; M: x86.32 pic-tail-reg EBX ;
@ -49,16 +48,7 @@ M: x86.32 reserved-area-size 0 ;
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ; M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
: push-vm-ptr ( -- ) : push-vm-ptr ( -- )
temp-reg 0 MOV rc-absolute-cell rt-vm rel-fixup ! push the vm ptr as an argument 0 PUSH rc-absolute-cell rt-vm rel-fixup ; ! push the vm ptr as an argument
temp-reg PUSH ;
M: x86.32 %vm-invoke-1st-arg ( function -- )
push-vm-ptr
f %alien-invoke
temp-reg POP ;
M: x86.32 %vm-invoke-3rd-arg ( function -- )
%vm-invoke-1st-arg ; ! first 2 args are regs, 3rd is stack so vm-invoke-1st-arg works here
M: x86.32 return-struct-in-registers? ( c-type -- ? ) M: x86.32 return-struct-in-registers? ( c-type -- ? )
c-type c-type
@ -247,6 +237,18 @@ M:: x86.32 %unbox-large-struct ( n c-type -- )
"to_value_struct" f %alien-invoke "to_value_struct" f %alien-invoke
] with-aligned-stack ; ] with-aligned-stack ;
M: x86.32 %nest-stacks ( -- )
4 [
push-vm-ptr
"nest_stacks" f %alien-invoke
] with-aligned-stack ;
M: x86.32 %unnest-stacks ( -- )
4 [
push-vm-ptr
"unnest_stacks" f %alien-invoke
] with-aligned-stack ;
M: x86.32 %prepare-alien-indirect ( -- ) M: x86.32 %prepare-alien-indirect ( -- )
push-vm-ptr "unbox_alien" f %alien-invoke push-vm-ptr "unbox_alien" f %alien-invoke
temp-reg POP temp-reg POP
@ -280,6 +282,7 @@ M: x86.32 %callback-value ( ctype -- )
! Unbox EAX ! Unbox EAX
unbox-return ; unbox-return ;
M: x86.32 %cleanup ( params -- ) M: x86.32 %cleanup ( params -- )
#! a) If we just called an stdcall function in Windows, it #! a) If we just called an stdcall function in Windows, it
#! cleaned up the stack frame for us. But we don't want that #! cleaned up the stack frame for us. But we don't want that
@ -311,6 +314,19 @@ M: x86.32 %callback-return ( n -- )
[ drop 0 ] [ drop 0 ]
} cond RET ; } cond RET ;
M:: x86.32 %call-gc ( gc-root-count temp -- )
temp gc-root-base param@ LEA
12 [
! Pass the VM ptr as the third parameter
0 PUSH rc-absolute-cell rt-vm rel-fixup
! Pass number of roots as second parameter
gc-root-count PUSH
! Pass pointer to start of GC roots as first parameter
temp PUSH
! Call GC
"inline_gc" f %alien-invoke
] with-aligned-stack ;
M: x86.32 dummy-stack-params? f ; M: x86.32 dummy-stack-params? f ;
M: x86.32 dummy-int-params? f ; M: x86.32 dummy-int-params? f ;

70
basis/cpu/x86/64/64.factor
View File

@ -36,9 +36,10 @@ M:: x86.64 %dispatch ( src temp -- )
[ align-code ] [ align-code ]
bi ; bi ;
M: x86.64 param-reg-1 int-regs param-regs first ; : param-reg-1 ( -- reg ) int-regs param-regs first ; inline
M: x86.64 param-reg-2 int-regs param-regs second ; : param-reg-2 ( -- reg ) int-regs param-regs second ; inline
M: x86.64 param-reg-3 int-regs param-regs third ; : param-reg-3 ( -- reg ) int-regs param-regs third ; inline
: param-reg-4 ( -- reg ) int-regs param-regs fourth ; inline
M: x86.64 pic-tail-reg RBX ; M: x86.64 pic-tail-reg RBX ;
@ -74,26 +75,13 @@ M: x86.64 %prepare-unbox ( -- )
param-reg-1 R14 [] MOV param-reg-1 R14 [] MOV
R14 cell SUB ; R14 cell SUB ;
M: x86.64 %vm-invoke-1st-arg ( function -- ) : %mov-vm-ptr ( reg -- )
param-reg-1 0 MOV rc-absolute-cell rt-vm rel-fixup 0 MOV rc-absolute-cell rt-vm rel-fixup ;
f %alien-invoke ;
: %vm-invoke-2nd-arg ( function -- )
param-reg-2 0 MOV rc-absolute-cell rt-vm rel-fixup
f %alien-invoke ;
M: x86.64 %vm-invoke-3rd-arg ( function -- )
param-reg-3 0 MOV rc-absolute-cell rt-vm rel-fixup
f %alien-invoke ;
: %vm-invoke-4th-arg ( function -- )
int-regs param-regs fourth 0 MOV rc-absolute-cell rt-vm rel-fixup
f %alien-invoke ;
M:: x86.64 %unbox ( n rep func -- ) M:: x86.64 %unbox ( n rep func -- )
param-reg-2 %mov-vm-ptr
! Call the unboxer ! Call the unboxer
func %vm-invoke-2nd-arg func f %alien-invoke
! Store the return value on the C stack if this is an ! Store the return value on the C stack if this is an
! alien-invoke, otherwise leave it the return register if ! alien-invoke, otherwise leave it the return register if
! this is the end of alien-callback ! this is the end of alien-callback
@ -109,10 +97,10 @@ M: x86.64 %unbox-long-long ( n func -- )
{ float-regs [ float-regs get pop swap MOVSD ] } { float-regs [ float-regs get pop swap MOVSD ] }
} case ; } case ;
M: x86.64 %unbox-small-struct ( c-type -- ) M: x86.64 %unbox-small-struct ( c-type -- )
! Alien must be in param-reg-1. ! Alien must be in param-reg-1.
"alien_offset" %vm-invoke-2nd-arg param-reg-2 %mov-vm-ptr
"alien_offset" f %alien-invoke
! Move alien_offset() return value to R11 so that we don't ! Move alien_offset() return value to R11 so that we don't
! clobber it. ! clobber it.
R11 RAX MOV R11 RAX MOV
@ -126,8 +114,9 @@ M:: x86.64 %unbox-large-struct ( n c-type -- )
param-reg-2 n param@ LEA param-reg-2 n param@ LEA
! Load structure size into param-reg-3 ! Load structure size into param-reg-3
param-reg-3 c-type heap-size MOV param-reg-3 c-type heap-size MOV
param-reg-4 %mov-vm-ptr
! Copy the struct to the C stack ! Copy the struct to the C stack
"to_value_struct" %vm-invoke-4th-arg ; "to_value_struct" f %alien-invoke ;
: load-return-value ( rep -- ) : load-return-value ( rep -- )
[ [ 0 ] dip reg-class-of param-reg ] [ [ 0 ] dip reg-class-of param-reg ]
@ -143,7 +132,8 @@ M:: x86.64 %box ( n rep func -- )
] [ ] [
rep load-return-value rep load-return-value
] if ] if
rep int-rep? [ func %vm-invoke-2nd-arg ] [ func %vm-invoke-1st-arg ] if ; rep int-rep? [ param-reg-2 ] [ param-reg-1 ] if %mov-vm-ptr
func f %alien-invoke ;
M: x86.64 %box-long-long ( n func -- ) M: x86.64 %box-long-long ( n func -- )
[ int-rep ] dip %box ; [ int-rep ] dip %box ;
@ -163,7 +153,8 @@ M: x86.64 %box-small-struct ( c-type -- )
[ param-reg-3 swap heap-size MOV ] bi [ param-reg-3 swap heap-size MOV ] bi
param-reg-1 0 box-struct-field@ MOV param-reg-1 0 box-struct-field@ MOV
param-reg-2 1 box-struct-field@ MOV param-reg-2 1 box-struct-field@ MOV
"box_small_struct" %vm-invoke-4th-arg param-reg-4 %mov-vm-ptr
"box_small_struct" f %alien-invoke
] with-return-regs ; ] with-return-regs ;
: struct-return@ ( n -- operand ) : struct-return@ ( n -- operand )
@ -174,8 +165,9 @@ M: x86.64 %box-large-struct ( n c-type -- )
param-reg-2 swap heap-size MOV param-reg-2 swap heap-size MOV
! Compute destination address ! Compute destination address
param-reg-1 swap struct-return@ LEA param-reg-1 swap struct-return@ LEA
param-reg-3 %mov-vm-ptr
! Copy the struct from the C stack ! Copy the struct from the C stack
"box_value_struct" %vm-invoke-3rd-arg ; "box_value_struct" f %alien-invoke ;
M: x86.64 %prepare-box-struct ( -- ) M: x86.64 %prepare-box-struct ( -- )
! Compute target address for value struct return ! Compute target address for value struct return
@ -190,9 +182,17 @@ M: x86.64 %alien-invoke
rc-absolute-cell rel-dlsym rc-absolute-cell rel-dlsym
R11 CALL ; R11 CALL ;
M: x86.64 %nest-stacks ( -- )
param-reg-1 0 MOV rc-absolute-cell rt-vm rel-fixup
"nest_stacks" f %alien-invoke ;
M: x86.64 %unnest-stacks ( -- )
param-reg-1 0 MOV rc-absolute-cell rt-vm rel-fixup
"unnest_stacks" f %alien-invoke ;
M: x86.64 %prepare-alien-indirect ( -- ) M: x86.64 %prepare-alien-indirect ( -- )
"unbox_alien" %vm-invoke-1st-arg param-reg-1 %mov-vm-ptr
"unbox_alien" f %alien-invoke
RBP RAX MOV ; RBP RAX MOV ;
M: x86.64 %alien-indirect ( -- ) M: x86.64 %alien-indirect ( -- )
@ -200,7 +200,8 @@ M: x86.64 %alien-indirect ( -- )
M: x86.64 %alien-callback ( quot -- ) M: x86.64 %alien-callback ( quot -- )
param-reg-1 swap %load-reference param-reg-1 swap %load-reference
"c_to_factor" %vm-invoke-2nd-arg ; param-reg-2 %mov-vm-ptr
"c_to_factor" f %alien-invoke ;
M: x86.64 %callback-value ( ctype -- ) M: x86.64 %callback-value ( ctype -- )
! Save top of data stack ! Save top of data stack
@ -208,8 +209,9 @@ M: x86.64 %callback-value ( ctype -- )
! Save top of data stack ! Save top of data stack
RSP 8 SUB RSP 8 SUB
param-reg-1 PUSH param-reg-1 PUSH
param-reg-1 %mov-vm-ptr
! Restore data/call/retain stacks ! Restore data/call/retain stacks
"unnest_stacks" %vm-invoke-1st-arg "unnest_stacks" f %alien-invoke
! Put former top of data stack in param-reg-1 ! Put former top of data stack in param-reg-1
param-reg-1 POP param-reg-1 POP
RSP 8 ADD RSP 8 ADD
@ -233,6 +235,16 @@ M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
func f %alien-invoke func f %alien-invoke
dst float-function-return ; dst float-function-return ;
M:: x86.64 %call-gc ( gc-root-count temp -- )
! Pass pointer to start of GC roots as first parameter
param-reg-1 gc-root-base param@ LEA
! Pass number of roots as second parameter
param-reg-2 gc-root-count MOV
! Pass VM ptr as third parameter
param-reg-3 %mov-vm-ptr
! Call GC
"inline_gc" f %alien-invoke ;
! The result of reading 4 bytes from memory is a fixnum on ! The result of reading 4 bytes from memory is a fixnum on
! x86-64. ! x86-64.
enable-alien-4-intrinsics enable-alien-4-intrinsics

15
basis/cpu/x86/x86.factor
View File

@ -52,11 +52,6 @@ M: x86 stack-frame-size ( stack-frame -- i )
! use in calls in and out of C ! use in calls in and out of C
HOOK: temp-reg cpu ( -- reg ) HOOK: temp-reg cpu ( -- reg )
! Fastcall calling convention
HOOK: param-reg-1 cpu ( -- reg )
HOOK: param-reg-2 cpu ( -- reg )
HOOK: param-reg-3 cpu ( -- reg )
HOOK: pic-tail-reg cpu ( -- reg ) HOOK: pic-tail-reg cpu ( -- reg )
M: x86 %load-immediate dup 0 = [ drop dup XOR ] [ MOV ] if ; M: x86 %load-immediate dup 0 = [ drop dup XOR ] [ MOV ] if ;
@ -828,16 +823,6 @@ M: x86 %save-gc-root ( gc-root register -- ) [ gc-root@ ] dip MOV ;
M: x86 %load-gc-root ( gc-root register -- ) swap gc-root@ MOV ; M: x86 %load-gc-root ( gc-root register -- ) swap gc-root@ MOV ;
M:: x86 %call-gc ( gc-root-count -- )
! Pass pointer to start of GC roots as first parameter
param-reg-1 gc-root-base param@ LEA
! Pass number of roots as second parameter
param-reg-2 gc-root-count MOV
! Pass vm as third argument
param-reg-3 0 MOV rc-absolute-cell rt-vm rel-fixup
! Call GC
"inline_gc" f %alien-invoke ;
M: x86 %alien-global ( dst symbol library -- ) M: x86 %alien-global ( dst symbol library -- )
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ; [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;

12
basis/hints/hints-tests.factor Normal file
View File

@ -0,0 +1,12 @@
USING: math hashtables accessors kernel words hints
compiler.tree.debugger tools.test ;
IN: hints.tests
! Regression
GENERIC: blahblah ( a b c -- )
M: hashtable blahblah 2nip [ 1 + ] change-count drop ;
HINTS: M\ hashtable blahblah { object fixnum object } { object word object } ;
[ t ] [ M\ hashtable blahblah { count>> (>>count) } inlined? ] unit-test

10
basis/hints/hints.factor
View File

@ -37,8 +37,8 @@ M: object specializer-declaration class ;
[ [ specializer-declaration ] map swap '[ _ declare @ ] ] 2bi [ [ specializer-declaration ] map swap '[ _ declare @ ] ] 2bi
] with { } map>assoc ; ] with { } map>assoc ;
: specialize-quot ( quot word specializer -- quot' ) : specialize-quot ( quot specializer -- quot' )
[ drop nip def>> ] [ nip specializer-cases ] 3bi alist>quot ; [ drop ] [ specializer-cases ] 2bi alist>quot ;
! compiler.tree.propagation.inlining sets this to f ! compiler.tree.propagation.inlining sets this to f
SYMBOL: specialize-method? SYMBOL: specialize-method?
@ -52,8 +52,8 @@ t specialize-method? set-global
: specialize-method ( quot method -- quot' ) : specialize-method ( quot method -- quot' )
[ specialize-method? get [ method-declaration prepend ] [ drop ] if ] [ specialize-method? get [ method-declaration prepend ] [ drop ] if ]
[ dup "method-generic" word-prop specializer ] bi [ "method-generic" word-prop ] bi
[ specialize-quot ] [ drop ] if* ; specializer [ specialize-quot ] when* ;
: standard-method? ( method -- ? ) : standard-method? ( method -- ? )
dup method-body? [ dup method-body? [
@ -64,7 +64,7 @@ t specialize-method? set-global
[ def>> ] keep [ def>> ] keep
dup generic? [ drop ] [ dup generic? [ drop ] [
[ dup standard-method? [ specialize-method ] [ drop ] if ] [ dup standard-method? [ specialize-method ] [ drop ] if ]
[ dup specializer [ specialize-quot ] [ drop ] if* ] [ specializer [ specialize-quot ] when* ]
bi bi
] if ; ] if ;

10
basis/math/vectors/simd/simd-tests.factor
View File

@ -81,9 +81,13 @@ CONSTANT: simd-classes
: check-optimizer ( seq inputs quot eq-quot -- ) : check-optimizer ( seq inputs quot eq-quot -- )
'[ '[
@ @
[ "print-mr" get [ nip test-mr mr. ] [ 2drop ] if ] {
[ [ call ] dip call ] [ "print-mr" get [ nip test-mr mr. ] [ 2drop ] if ]
[ [ call ] dip compile-call ] 2tri @ not [ "print-checks" get [ [ . ] bi@ ] [ 2drop ] if ]
[ [ call ] dip call ]
[ [ call ] dip compile-call ]
} 2cleave
@ not
] filter ; inline ] filter ; inline
"== Checking -new constructors" print "== Checking -new constructors" print

14
basis/math/vectors/vectors-tests.factor
View File

@ -1,5 +1,7 @@
IN: math.vectors.tests IN: math.vectors.tests
USING: math.vectors tools.test kernel ; USING: math.vectors tools.test kernel specialized-arrays compiler
kernel.private ;
SPECIALIZED-ARRAY: int
[ { 1 2 3 } ] [ 1/2 { 2 4 6 } n*v ] unit-test [ { 1 2 3 } ] [ 1/2 { 2 4 6 } n*v ] unit-test
[ { 1 2 3 } ] [ { 2 4 6 } 1/2 v*n ] unit-test [ { 1 2 3 } ] [ { 2 4 6 } 1/2 v*n ] unit-test
@ -21,4 +23,12 @@ USING: math.vectors tools.test kernel ;
[ { 0 3 2 5 4 } ] [ { 1 2 3 4 5 } { 1 1 1 1 1 } v+- ] unit-test [ { 0 3 2 5 4 } ] [ { 1 2 3 4 5 } { 1 1 1 1 1 } v+- ] unit-test
[ 1 ] [ { C{ 0 1 } } dup v. ] unit-test [ 1 ] [ { C{ 0 1 } } dup v. ] unit-test
! Make sure vector shifts behave the same as hardware SIMD vector shifts
[ int-array{ 0 0 0 0 } ] [ int-array{ 10 20 30 40 } -1 vlshift ] unit-test
[ int-array{ 0 0 0 0 } ] [
int-array{ 10 20 30 40 }
[ { int-array } declare -1 vlshift ] compile-call
] unit-test

4
basis/math/vectors/vectors.factor
View File

@ -61,8 +61,8 @@ PRIVATE>
: vbitor ( u v -- w ) over '[ _ [ bitor ] fp-bitwise-op ] 2map ; : vbitor ( u v -- w ) over '[ _ [ bitor ] fp-bitwise-op ] 2map ;
: vbitxor ( u v -- w ) over '[ _ [ bitxor ] fp-bitwise-op ] 2map ; : vbitxor ( u v -- w ) over '[ _ [ bitxor ] fp-bitwise-op ] 2map ;
: vlshift ( u n -- w ) '[ _ shift ] map ; : vlshift ( u n -- w ) HEX: ffffffff bitand '[ _ shift ] map ;
: vrshift ( u n -- w ) neg '[ _ shift ] map ; : vrshift ( u n -- w ) HEX: ffffffff bitand neg '[ _ shift ] map ;
: vfloor ( u -- v ) [ floor ] map ; : vfloor ( u -- v ) [ floor ] map ;
: vceiling ( u -- v ) [ ceiling ] map ; : vceiling ( u -- v ) [ ceiling ] map ;

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

@ -125,3 +125,5 @@ DEFER: x
keys [ "forgotten" word-prop ] filter keys [ "forgotten" word-prop ] filter
] map harvest ] map harvest
] unit-test ] unit-test
[ "hi" word-xt ] must-fail

6
extra/webapps/mason/mason.factor
View File

@ -135,10 +135,10 @@ CONSTANT: cpus
: requirements ( builder -- xml ) : requirements ( builder -- xml )
[ [
os>> { os>> {
{ "winnt" "Windows XP (also tested on Vista)" } { "winnt" "Windows XP, Windows Vista or Windows 7" }
{ "macosx" "Mac OS X 10.5 Leopard" } { "macosx" "Mac OS X 10.5 Leopard" }
{ "linux" "Ubuntu Linux 9.04 (other distributions may also work)" } { "linux" "Ubuntu Linux 9.04 (other distributions may also work)" }
{ "freebsd" "FreeBSD 7.0" } { "freebsd" "FreeBSD 7.1" }
{ "netbsd" "NetBSD 5.0" } { "netbsd" "NetBSD 5.0" }
{ "openbsd" "OpenBSD 4.4" } { "openbsd" "OpenBSD 4.4" }
} at } at
@ -146,7 +146,7 @@ CONSTANT: cpus
dup cpu>> "x86.32" = [ dup cpu>> "x86.32" = [
os>> { os>> {
{ [ dup { "winnt" "linux" "freebsd" "netbsd" } member? ] [ drop "Intel Pentium 4, Core Duo, or other x86 chip with SSE2 support. Note that 32-bit Athlon XP processors do not support SSE2." ] } { [ dup { "winnt" "linux" "freebsd" "netbsd" } member? ] [ drop "Intel Pentium 4, Core Duo, or other x86 chip with SSE2 support. Note that 32-bit Athlon XP processors do not support SSE2." ] }
{ [ dup {"openbsd" } member? ] [ drop "Intel Pentium Pro or better" ] } { [ dup { "openbsd" } member? ] [ drop "Intel Pentium Pro or better" ] }
{ [ t ] [ drop f ] } { [ t ] [ drop f ] }
} cond } cond
] [ drop f ] if ] [ drop f ] if

35
vm/alien.cpp
View File

@ -69,10 +69,7 @@ inline void factor_vm::primitive_displaced_alien()
} }
} }
PRIMITIVE(displaced_alien) PRIMITIVE_FORWARD(displaced_alien)
{
PRIMITIVE_GETVM()->primitive_displaced_alien();
}
/* address of an object representing a C pointer. Explicitly throw an error /* address of an object representing a C pointer. Explicitly throw an error
if the object is a byte array, as a sanity check. */ if the object is a byte array, as a sanity check. */
@ -81,10 +78,7 @@ inline void factor_vm::primitive_alien_address()
box_unsigned_cell((cell)pinned_alien_offset(dpop())); box_unsigned_cell((cell)pinned_alien_offset(dpop()));
} }
PRIMITIVE(alien_address) PRIMITIVE_FORWARD(alien_address)
{
PRIMITIVE_GETVM()->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 */
void *factor_vm::alien_pointer() void *factor_vm::alien_pointer()
@ -131,10 +125,7 @@ inline void factor_vm::primitive_dlopen()
dpush(library.value()); dpush(library.value());
} }
PRIMITIVE(dlopen) PRIMITIVE_FORWARD(dlopen)
{
PRIMITIVE_GETVM()->primitive_dlopen();
}
/* look up a symbol in a native library */ /* look up a symbol in a native library */
inline void factor_vm::primitive_dlsym() inline void factor_vm::primitive_dlsym()
@ -158,10 +149,7 @@ inline void factor_vm::primitive_dlsym()
} }
} }
PRIMITIVE(dlsym) PRIMITIVE_FORWARD(dlsym)
{
PRIMITIVE_GETVM()->primitive_dlsym();
}
/* close a native library handle */ /* close a native library handle */
inline void factor_vm::primitive_dlclose() inline void factor_vm::primitive_dlclose()
@ -171,10 +159,7 @@ inline void factor_vm::primitive_dlclose()
ffi_dlclose(d); ffi_dlclose(d);
} }
PRIMITIVE(dlclose) PRIMITIVE_FORWARD(dlclose)
{
PRIMITIVE_GETVM()->primitive_dlclose();
}
inline void factor_vm::primitive_dll_validp() inline void factor_vm::primitive_dll_validp()
{ {
@ -185,10 +170,7 @@ inline void factor_vm::primitive_dll_validp()
dpush(untag_check<dll>(library)->dll == NULL ? F : T); dpush(untag_check<dll>(library)->dll == NULL ? F : T);
} }
PRIMITIVE(dll_validp) PRIMITIVE_FORWARD(dll_validp)
{
PRIMITIVE_GETVM()->primitive_dll_validp();
}
/* gets the address of an object representing a C pointer */ /* gets the address of an object representing a C pointer */
char *factor_vm::alien_offset(cell obj) char *factor_vm::alien_offset(cell obj)
@ -308,9 +290,6 @@ inline void factor_vm::primitive_vm_ptr()
box_alien(this); box_alien(this);
} }
PRIMITIVE(vm_ptr) PRIMITIVE_FORWARD(vm_ptr)
{
PRIMITIVE_GETVM()->primitive_vm_ptr();
}
} }

10
vm/arrays.cpp
View File

@ -31,10 +31,7 @@ inline void factor_vm::primitive_array()
dpush(tag<array>(allot_array(size,initial))); dpush(tag<array>(allot_array(size,initial)));
} }
PRIMITIVE(array) PRIMITIVE_FORWARD(array)
{
PRIMITIVE_GETVM()->primitive_array();
}
cell factor_vm::allot_array_1(cell obj_) cell factor_vm::allot_array_1(cell obj_)
{ {
@ -75,10 +72,7 @@ inline void factor_vm::primitive_resize_array()
dpush(tag<array>(reallot_array(a,capacity))); dpush(tag<array>(reallot_array(a,capacity)));
} }
PRIMITIVE(resize_array) PRIMITIVE_FORWARD(resize_array)
{
PRIMITIVE_GETVM()->primitive_resize_array();
}
void growable_array::add(cell elt_) void growable_array::add(cell elt_)
{ {

15
vm/byte_arrays.cpp
View File

@ -16,10 +16,7 @@ inline void factor_vm::primitive_byte_array()
dpush(tag<byte_array>(allot_byte_array(size))); dpush(tag<byte_array>(allot_byte_array(size)));
} }
PRIMITIVE(byte_array) PRIMITIVE_FORWARD(byte_array)
{
PRIMITIVE_GETVM()->primitive_byte_array();
}
inline void factor_vm::primitive_uninitialized_byte_array() inline void factor_vm::primitive_uninitialized_byte_array()
{ {
@ -27,10 +24,7 @@ inline void factor_vm::primitive_uninitialized_byte_array()
dpush(tag<byte_array>(allot_array_internal<byte_array>(size))); dpush(tag<byte_array>(allot_array_internal<byte_array>(size)));
} }
PRIMITIVE(uninitialized_byte_array) PRIMITIVE_FORWARD(uninitialized_byte_array)
{
PRIMITIVE_GETVM()->primitive_uninitialized_byte_array();
}
inline void factor_vm::primitive_resize_byte_array() inline void factor_vm::primitive_resize_byte_array()
{ {
@ -39,10 +33,7 @@ inline void factor_vm::primitive_resize_byte_array()
dpush(tag<byte_array>(reallot_array(array,capacity))); dpush(tag<byte_array>(reallot_array(array,capacity)));
} }
PRIMITIVE(resize_byte_array) PRIMITIVE_FORWARD(resize_byte_array)
{
PRIMITIVE_GETVM()->primitive_resize_byte_array();
}
void growable_byte_array::append_bytes(void *elts, cell len) void growable_byte_array::append_bytes(void *elts, cell len)
{ {

30
vm/callstack.cpp
View File

@ -60,10 +60,7 @@ inline void factor_vm::primitive_callstack()
dpush(tag<callstack>(stack)); dpush(tag<callstack>(stack));
} }
PRIMITIVE(callstack) PRIMITIVE_FORWARD(callstack)
{
PRIMITIVE_GETVM()->primitive_callstack();
}
inline void factor_vm::primitive_set_callstack() inline void factor_vm::primitive_set_callstack()
{ {
@ -78,10 +75,7 @@ inline void factor_vm::primitive_set_callstack()
critical_error("Bug in set_callstack()",0); critical_error("Bug in set_callstack()",0);
} }
PRIMITIVE(set_callstack) PRIMITIVE_FORWARD(set_callstack)
{
PRIMITIVE_GETVM()->primitive_set_callstack();
}
code_block *factor_vm::frame_code(stack_frame *frame) code_block *factor_vm::frame_code(stack_frame *frame)
{ {
@ -172,10 +166,7 @@ inline void factor_vm::primitive_callstack_to_array()
dpush(accum.frames.elements.value()); dpush(accum.frames.elements.value());
} }
PRIMITIVE(callstack_to_array) PRIMITIVE_FORWARD(callstack_to_array)
{
PRIMITIVE_GETVM()->primitive_callstack_to_array();
}
stack_frame *factor_vm::innermost_stack_frame(callstack *stack) stack_frame *factor_vm::innermost_stack_frame(callstack *stack)
{ {
@ -203,20 +194,14 @@ inline void factor_vm::primitive_innermost_stack_frame_executing()
dpush(frame_executing(innermost_stack_frame(untag_check<callstack>(dpop())))); dpush(frame_executing(innermost_stack_frame(untag_check<callstack>(dpop()))));
} }
PRIMITIVE(innermost_stack_frame_executing) PRIMITIVE_FORWARD(innermost_stack_frame_executing)
{
PRIMITIVE_GETVM()->primitive_innermost_stack_frame_executing();
}
inline void factor_vm::primitive_innermost_stack_frame_scan() inline void factor_vm::primitive_innermost_stack_frame_scan()
{ {
dpush(frame_scan(innermost_stack_frame_quot(untag_check<callstack>(dpop())))); dpush(frame_scan(innermost_stack_frame_quot(untag_check<callstack>(dpop()))));
} }
PRIMITIVE(innermost_stack_frame_scan) PRIMITIVE_FORWARD(innermost_stack_frame_scan)
{
PRIMITIVE_GETVM()->primitive_innermost_stack_frame_scan();
}
inline void factor_vm::primitive_set_innermost_stack_frame_quot() inline void factor_vm::primitive_set_innermost_stack_frame_quot()
{ {
@ -234,10 +219,7 @@ inline void factor_vm::primitive_set_innermost_stack_frame_quot()
FRAME_RETURN_ADDRESS(inner) = (char *)quot->xt + offset; FRAME_RETURN_ADDRESS(inner) = (char *)quot->xt + offset;
} }
PRIMITIVE(set_innermost_stack_frame_quot) PRIMITIVE_FORWARD(set_innermost_stack_frame_quot)
{
PRIMITIVE_GETVM()->primitive_set_innermost_stack_frame_quot();
}
/* called before entry into Factor code. */ /* called before entry into Factor code. */
void factor_vm::save_callstack_bottom(stack_frame *callstack_bottom) void factor_vm::save_callstack_bottom(stack_frame *callstack_bottom)

2
vm/callstack.hpp
View File

@ -13,7 +13,7 @@ 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);
VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom,factor_vm *vm); VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom, factor_vm *vm);
} }

14
vm/code_block.cpp
View File

@ -93,9 +93,9 @@ void factor_vm::undefined_symbol()
general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL); general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
} }
void undefined_symbol(factor_vm *myvm) void undefined_symbol()
{ {
return myvm->undefined_symbol(); return SIGNAL_VM_PTR()->undefined_symbol();
} }
/* Look up an external library symbol referenced by a compiled code block */ /* Look up an external library symbol referenced by a compiled code block */
@ -371,7 +371,7 @@ void factor_vm::update_word_references(code_block *compiled)
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->type == PIC_TYPE) else if(compiled->type == PIC_TYPE)
heap_free(&code,compiled); code->heap_free(compiled);
else else
{ {
iterate_relocations(compiled,factor::update_word_references_step); iterate_relocations(compiled,factor::update_word_references_step);
@ -411,7 +411,7 @@ void factor_vm::mark_code_block(code_block *compiled)
{ {
check_code_address((cell)compiled); check_code_address((cell)compiled);
mark_block(compiled); code->mark_block(compiled);
copy_handle(&compiled->literals); copy_handle(&compiled->literals);
copy_handle(&compiled->relocation); copy_handle(&compiled->relocation);
@ -503,19 +503,19 @@ void factor_vm::fixup_labels(array *labels, code_block *compiled)
/* Might GC */ /* Might GC */
code_block *factor_vm::allot_code_block(cell size) code_block *factor_vm::allot_code_block(cell size)
{ {
heap_block *block = heap_allot(&code,size + sizeof(code_block)); heap_block *block = code->heap_allot(size + sizeof(code_block));
/* If allocation failed, do a code GC */ /* If allocation failed, do a code GC */
if(block == NULL) if(block == NULL)
{ {
gc(); gc();
block = heap_allot(&code,size + sizeof(code_block)); block = code->heap_allot(size + sizeof(code_block));
/* Insufficient room even after code GC, give up */ /* Insufficient room even after code GC, give up */
if(block == NULL) if(block == NULL)
{ {
cell used, total_free, max_free; cell used, total_free, max_free;
heap_usage(&code,&used,&total_free,&max_free); code->heap_usage(&used,&total_free,&max_free);
print_string("Code heap stats:\n"); print_string("Code heap stats:\n");
print_string("Used: "); print_cell(used); nl(); print_string("Used: "); print_cell(used); nl();

38
vm/code_gc.hpp
View File

@ -1,38 +0,0 @@
namespace factor
{
static const cell free_list_count = 16;
static const cell block_size_increment = 32;
struct heap_free_list {
free_heap_block *small_blocks[free_list_count];
free_heap_block *large_blocks;
};
struct heap {
segment *seg;
heap_free_list free;
};
typedef void (*heap_iterator)(heap_block *compiled,factor_vm *vm);
inline static heap_block *next_block(heap *h, heap_block *block)
{
cell next = ((cell)block + block->size);
if(next == h->seg->end)
return NULL;
else
return (heap_block *)next;
}
inline static heap_block *first_block(heap *h)
{
return (heap_block *)h->seg->start;
}
inline static heap_block *last_block(heap *h)
{
return (heap_block *)h->seg->end;
}
}

28
vm/code_heap.cpp
View File

@ -6,12 +6,12 @@ namespace factor
/* Allocate a code heap during startup */ /* Allocate a code heap during startup */
void factor_vm::init_code_heap(cell size) void factor_vm::init_code_heap(cell size)
{ {
new_heap(&code,size); code = new heap(this,size);
} }
bool factor_vm::in_code_heap_p(cell ptr) bool factor_vm::in_code_heap_p(cell ptr)
{ {
return (ptr >= code.seg->start && ptr <= code.seg->end); return (ptr >= code->seg->start && ptr <= code->seg->end);
} }
/* Compile a word definition with the non-optimizing compiler. Allocates memory */ /* Compile a word definition with the non-optimizing compiler. Allocates memory */
@ -31,13 +31,13 @@ void factor_vm::jit_compile_word(cell word_, cell def_, bool relocate)
/* Apply a function to every code block */ /* Apply a function to every code block */
void factor_vm::iterate_code_heap(code_heap_iterator iter) void factor_vm::iterate_code_heap(code_heap_iterator iter)
{ {
heap_block *scan = first_block(&code); heap_block *scan = code->first_block();
while(scan) while(scan)
{ {
if(scan->status != B_FREE) if(scan->status != B_FREE)
iter((code_block *)scan,this); iter((code_block *)scan,this);
scan = next_block(&code,scan); scan = code->next_block(scan);
} }
} }
@ -106,26 +106,20 @@ inline void factor_vm::primitive_modify_code_heap()
update_code_heap_words(); update_code_heap_words();
} }
PRIMITIVE(modify_code_heap) PRIMITIVE_FORWARD(modify_code_heap)
{
PRIMITIVE_GETVM()->primitive_modify_code_heap();
}
/* Push the free space and total size of the code heap */ /* Push the free space and total size of the code heap */
inline void factor_vm::primitive_code_room() inline void factor_vm::primitive_code_room()
{ {
cell used, total_free, max_free; cell used, total_free, max_free;
heap_usage(&code,&used,&total_free,&max_free); code->heap_usage(&used,&total_free,&max_free);
dpush(tag_fixnum(code.seg->size / 1024)); dpush(tag_fixnum(code->seg->size / 1024));
dpush(tag_fixnum(used / 1024)); dpush(tag_fixnum(used / 1024));
dpush(tag_fixnum(total_free / 1024)); dpush(tag_fixnum(total_free / 1024));
dpush(tag_fixnum(max_free / 1024)); dpush(tag_fixnum(max_free / 1024));
} }
PRIMITIVE(code_room) PRIMITIVE_FORWARD(code_room)
{
PRIMITIVE_GETVM()->primitive_code_room();
}
code_block *factor_vm::forward_xt(code_block *compiled) code_block *factor_vm::forward_xt(code_block *compiled)
{ {
@ -226,20 +220,20 @@ void factor_vm::compact_code_heap()
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, forwarding); cell size = code->compute_heap_forwarding(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,forwarding); code->compact_heap(forwarding);
/* Update word and quotation XTs */ /* Update word and quotation XTs */
fixup_object_xts(); fixup_object_xts();
/* Now update the free list; there will be a single free block at /* Now update the free list; there will be a single free block at
the end */ the end */
build_free_list(&code,size); code->build_free_list(size);
} }
} }

3
vm/code_heap.hpp
View File

@ -1,7 +1,8 @@
namespace factor namespace factor
{ {
struct factor_vm; struct factor_vm;
typedef void (*code_heap_iterator)(code_block *compiled,factor_vm *myvm); typedef void (*code_heap_iterator)(code_block *compiled, factor_vm *myvm);
PRIMITIVE(modify_code_heap); PRIMITIVE(modify_code_heap);
PRIMITIVE(code_room); PRIMITIVE(code_room);

31
vm/contexts.cpp
View File

@ -43,9 +43,9 @@ context *factor_vm::alloc_context()
} }
else else
{ {
new_context = (context *)safe_malloc(sizeof(context)); new_context = new context;
new_context->datastack_region = alloc_segment(ds_size); new_context->datastack_region = new segment(this,ds_size);
new_context->retainstack_region = alloc_segment(rs_size); new_context->retainstack_region = new segment(this,rs_size);
} }
return new_context; return new_context;
@ -146,10 +146,7 @@ inline void factor_vm::primitive_datastack()
general_error(ERROR_DS_UNDERFLOW,F,F,NULL); general_error(ERROR_DS_UNDERFLOW,F,F,NULL);
} }
PRIMITIVE(datastack) PRIMITIVE_FORWARD(datastack)
{
PRIMITIVE_GETVM()->primitive_datastack();
}
inline void factor_vm::primitive_retainstack() inline void factor_vm::primitive_retainstack()
{ {
@ -157,10 +154,7 @@ inline void factor_vm::primitive_retainstack()
general_error(ERROR_RS_UNDERFLOW,F,F,NULL); general_error(ERROR_RS_UNDERFLOW,F,F,NULL);
} }
PRIMITIVE(retainstack) PRIMITIVE_FORWARD(retainstack)
{
PRIMITIVE_GETVM()->primitive_retainstack();
}
/* returns pointer to top of stack */ /* returns pointer to top of stack */
cell factor_vm::array_to_stack(array *array, cell bottom) cell factor_vm::array_to_stack(array *array, cell bottom)
@ -175,20 +169,14 @@ inline void factor_vm::primitive_set_datastack()
ds = array_to_stack(untag_check<array>(dpop()),ds_bot); ds = array_to_stack(untag_check<array>(dpop()),ds_bot);
} }
PRIMITIVE(set_datastack) PRIMITIVE_FORWARD(set_datastack)
{
PRIMITIVE_GETVM()->primitive_set_datastack();
}
inline void factor_vm::primitive_set_retainstack() inline void factor_vm::primitive_set_retainstack()
{ {
rs = array_to_stack(untag_check<array>(dpop()),rs_bot); rs = array_to_stack(untag_check<array>(dpop()),rs_bot);
} }
PRIMITIVE(set_retainstack) PRIMITIVE_FORWARD(set_retainstack)
{
PRIMITIVE_GETVM()->primitive_set_retainstack();
}
/* Used to implement call( */ /* Used to implement call( */
inline void factor_vm::primitive_check_datastack() inline void factor_vm::primitive_check_datastack()
@ -216,9 +204,6 @@ inline void factor_vm::primitive_check_datastack()
} }
} }
PRIMITIVE(check_datastack) PRIMITIVE_FORWARD(check_datastack)
{
PRIMITIVE_GETVM()->primitive_check_datastack();
}
} }

1
vm/cpu-ppc.hpp
View File

@ -3,7 +3,6 @@ namespace factor
#define FACTOR_CPU_STRING "ppc" #define FACTOR_CPU_STRING "ppc"
#define VM_ASM_API VM_C_API #define VM_ASM_API VM_C_API
#define VM_ASM_API_OVERFLOW VM_C_API
register cell ds asm("r13"); register cell ds asm("r13");
register cell rs asm("r14"); register cell rs asm("r14");

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

@ -82,7 +82,7 @@ DEF(void,set_x87_env,(const void*)):
ret ret
DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to, void *vm)): DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to, void *vm)):
mov CELL_SIZE(STACK_REG),NV_TEMP_REG /* get vm ptr in case quot_xt = lazy_jit_compile */ mov ARG2,NV_TEMP_REG /* remember vm ptr in case quot_xt = lazy_jit_compile */
/* clear x87 stack, but preserve rounding mode and exception flags */ /* clear x87 stack, but preserve rounding mode and exception flags */
sub $2,STACK_REG sub $2,STACK_REG
fnstcw (STACK_REG) fnstcw (STACK_REG)

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

@ -6,6 +6,5 @@ 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 VM_C_API __attribute__ ((regparm (2))) #define VM_ASM_API VM_C_API __attribute__ ((regparm (3)))
#define VM_ASM_API_OVERFLOW VM_C_API __attribute__ ((regparm (3)))
} }

1
vm/cpu-x86.64.hpp
View File

@ -7,5 +7,4 @@ register cell ds asm("r14");
register cell rs asm("r15"); register cell rs asm("r15");
#define VM_ASM_API VM_C_API #define VM_ASM_API VM_C_API
#define VM_ASM_API_OVERFLOW VM_C_API
} }

2
vm/cpu-x86.hpp
View File

@ -69,7 +69,7 @@ inline static unsigned int fpu_status(unsigned int status)
} }
/* Defined in assembly */ /* Defined in assembly */
VM_ASM_API void c_to_factor(cell quot,void *vm); VM_ASM_API void c_to_factor(cell quot, void *vm);
VM_ASM_API void throw_impl(cell quot, stack_frame *rewind_to, void *vm); VM_ASM_API void throw_impl(cell quot, stack_frame *rewind_to, void *vm);
VM_ASM_API void lazy_jit_compile(cell quot, void *vm); VM_ASM_API void lazy_jit_compile(cell quot, void *vm);

28
vm/data_gc.cpp
View File

@ -455,7 +455,7 @@ void factor_vm::end_gc(cell gc_elapsed)
if(growing_data_heap) if(growing_data_heap)
{ {
dealloc_data_heap(old_data_heap); delete old_data_heap;
old_data_heap = NULL; old_data_heap = NULL;
growing_data_heap = false; growing_data_heap = false;
} }
@ -509,7 +509,7 @@ void factor_vm::garbage_collection(cell gen,bool growing_data_heap_,cell request
growing_data_heap = true; growing_data_heap = true;
/* see the comment in unmark_marked() */ /* see the comment in unmark_marked() */
unmark_marked(&code); code->unmark_marked();
} }
/* we try collecting aging space twice before going on to /* we try collecting aging space twice before going on to
collect tenured */ collect tenured */
@ -546,7 +546,7 @@ void factor_vm::garbage_collection(cell gen,bool growing_data_heap_,cell request
code_heap_scans++; code_heap_scans++;
if(collecting_gen == data->tenured()) if(collecting_gen == data->tenured())
free_unmarked(&code,(heap_iterator)factor::update_literal_and_word_references); code->free_unmarked((heap_iterator)factor::update_literal_and_word_references);
else else
copy_code_heap_roots(); copy_code_heap_roots();
@ -573,10 +573,7 @@ inline void factor_vm::primitive_gc()
gc(); gc();
} }
PRIMITIVE(gc) PRIMITIVE_FORWARD(gc)
{
PRIMITIVE_GETVM()->primitive_gc();
}
inline void factor_vm::primitive_gc_stats() inline void factor_vm::primitive_gc_stats()
{ {
@ -608,10 +605,7 @@ inline void factor_vm::primitive_gc_stats()
dpush(result.elements.value()); dpush(result.elements.value());
} }
PRIMITIVE(gc_stats) PRIMITIVE_FORWARD(gc_stats)
{
PRIMITIVE_GETVM()->primitive_gc_stats();
}
void factor_vm::clear_gc_stats() void factor_vm::clear_gc_stats()
{ {
@ -629,10 +623,7 @@ inline void factor_vm::primitive_clear_gc_stats()
clear_gc_stats(); clear_gc_stats();
} }
PRIMITIVE(clear_gc_stats) PRIMITIVE_FORWARD(clear_gc_stats)
{
PRIMITIVE_GETVM()->primitive_clear_gc_stats();
}
/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this /* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this
to coalesce equal but distinct quotations and wrappers. */ to coalesce equal but distinct quotations and wrappers. */
@ -665,10 +656,7 @@ inline void factor_vm::primitive_become()
compile_all_words(); compile_all_words();
} }
PRIMITIVE(become) PRIMITIVE_FORWARD(become)
{
PRIMITIVE_GETVM()->primitive_become();
}
void factor_vm::inline_gc(cell *gc_roots_base, cell gc_roots_size) void factor_vm::inline_gc(cell *gc_roots_base, cell gc_roots_size)
{ {
@ -681,7 +669,7 @@ void factor_vm::inline_gc(cell *gc_roots_base, cell gc_roots_size)
gc_locals.pop_back(); gc_locals.pop_back();
} }
VM_ASM_API_OVERFLOW void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *myvm) VM_C_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *myvm)
{ {
ASSERTVM(); ASSERTVM();
VM_PTR->inline_gc(gc_roots_base,gc_roots_size); VM_PTR->inline_gc(gc_roots_base,gc_roots_size);

2
vm/data_gc.hpp
View File

@ -20,6 +20,6 @@ PRIMITIVE(gc_stats);
PRIMITIVE(clear_gc_stats); PRIMITIVE(clear_gc_stats);
PRIMITIVE(become); PRIMITIVE(become);
struct factor_vm; struct factor_vm;
VM_ASM_API_OVERFLOW void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *myvm); VM_C_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *myvm);
} }

120
vm/data_heap.cpp
View File

@ -3,14 +3,6 @@
namespace factor namespace factor
{ {
cell factor_vm::init_zone(zone *z, cell size, cell start)
{
z->size = size;
z->start = z->here = start;
z->end = start + size;
return z->end;
}
void factor_vm::init_card_decks() void factor_vm::init_card_decks()
{ {
cell start = align(data->seg->start,deck_size); cell start = align(data->seg->start,deck_size);
@ -19,89 +11,86 @@ void factor_vm::init_card_decks()
decks_offset = (cell)data->decks - (start >> deck_bits); decks_offset = (cell)data->decks - (start >> deck_bits);
} }
data_heap *factor_vm::alloc_data_heap(cell gens, cell young_size,cell aging_size,cell tenured_size) data_heap::data_heap(factor_vm *myvm, cell gen_count_, cell young_size_, cell aging_size_, cell tenured_size_)
{ {
young_size = align(young_size,deck_size); young_size_ = align(young_size_,deck_size);
aging_size = align(aging_size,deck_size); aging_size_ = align(aging_size_,deck_size);
tenured_size = align(tenured_size,deck_size); tenured_size_ = align(tenured_size_,deck_size);
data_heap *data = (data_heap *)safe_malloc(sizeof(data_heap)); young_size = young_size_;
data->young_size = young_size; aging_size = aging_size_;
data->aging_size = aging_size; tenured_size = tenured_size_;
data->tenured_size = tenured_size; gen_count = gen_count_;
data->gen_count = gens;
cell total_size; cell total_size;
if(data->gen_count == 2) if(gen_count == 2)
total_size = young_size + 2 * tenured_size; total_size = young_size + 2 * tenured_size;
else if(data->gen_count == 3) else if(gen_count == 3)
total_size = young_size + 2 * aging_size + 2 * tenured_size; total_size = young_size + 2 * aging_size + 2 * tenured_size;
else else
{ {
fatal_error("Invalid number of generations",data->gen_count); total_size = 0;
return NULL; /* can't happen */ fatal_error("Invalid number of generations",gen_count);
} }
total_size += deck_size; total_size += deck_size;
data->seg = alloc_segment(total_size); seg = new segment(myvm,total_size);
data->generations = (zone *)safe_malloc(sizeof(zone) * data->gen_count); generations = new zone[gen_count];
data->semispaces = (zone *)safe_malloc(sizeof(zone) * data->gen_count); semispaces = new zone[gen_count];
cell cards_size = total_size >> card_bits; cell cards_size = total_size >> card_bits;
data->allot_markers = (cell *)safe_malloc(cards_size); allot_markers = new char[cards_size];
data->allot_markers_end = data->allot_markers + cards_size; allot_markers_end = allot_markers + cards_size;
data->cards = (cell *)safe_malloc(cards_size); cards = new char[cards_size];
data->cards_end = data->cards + cards_size; cards_end = cards + cards_size;
cell decks_size = total_size >> deck_bits; cell decks_size = total_size >> deck_bits;
data->decks = (cell *)safe_malloc(decks_size); decks = new char[decks_size];
data->decks_end = data->decks + decks_size; decks_end = decks + decks_size;
cell alloter = align(data->seg->start,deck_size); cell alloter = align(seg->start,deck_size);
alloter = init_zone(&data->generations[data->tenured()],tenured_size,alloter); alloter = generations[tenured()].init_zone(tenured_size,alloter);
alloter = init_zone(&data->semispaces[data->tenured()],tenured_size,alloter); alloter = semispaces[tenured()].init_zone(tenured_size,alloter);
if(data->gen_count == 3) if(gen_count == 3)
{ {
alloter = init_zone(&data->generations[data->aging()],aging_size,alloter); alloter = generations[aging()].init_zone(aging_size,alloter);
alloter = init_zone(&data->semispaces[data->aging()],aging_size,alloter); alloter = semispaces[aging()].init_zone(aging_size,alloter);
} }
if(data->gen_count >= 2) if(gen_count >= 2)
{ {
alloter = init_zone(&data->generations[data->nursery()],young_size,alloter); alloter = generations[nursery()].init_zone(young_size,alloter);
alloter = init_zone(&data->semispaces[data->nursery()],0,alloter); alloter = semispaces[nursery()].init_zone(0,alloter);
} }
if(data->seg->end - alloter > deck_size) if(seg->end - alloter > deck_size)
critical_error("Bug in alloc_data_heap",alloter); myvm->critical_error("Bug in alloc_data_heap",alloter);
return data;
} }
data_heap *factor_vm::grow_data_heap(data_heap *data, cell requested_bytes) data_heap *factor_vm::grow_data_heap(data_heap *data, cell requested_bytes)
{ {
cell new_tenured_size = (data->tenured_size * 2) + requested_bytes; cell new_tenured_size = (data->tenured_size * 2) + requested_bytes;
return alloc_data_heap(data->gen_count, return new data_heap(this,
data->gen_count,
data->young_size, data->young_size,
data->aging_size, data->aging_size,
new_tenured_size); new_tenured_size);
} }
void factor_vm::dealloc_data_heap(data_heap *data) data_heap::~data_heap()
{ {
dealloc_segment(data->seg); delete seg;
free(data->generations); delete[] generations;
free(data->semispaces); delete[] semispaces;
free(data->allot_markers); delete[] allot_markers;
free(data->cards); delete[] cards;
free(data->decks); delete[] decks;
free(data);
} }
void factor_vm::clear_cards(cell from, cell to) void factor_vm::clear_cards(cell from, cell to)
@ -162,7 +151,7 @@ void factor_vm::set_data_heap(data_heap *data_)
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 gens,cell young_size,cell aging_size,cell tenured_size,bool secure_gc_)
{ {
set_data_heap(alloc_data_heap(gens,young_size,aging_size,tenured_size)); set_data_heap(new data_heap(this,gens,young_size,aging_size,tenured_size));
secure_gc = secure_gc_; secure_gc = secure_gc_;
init_data_gc(); init_data_gc();
} }
@ -222,10 +211,7 @@ inline void factor_vm::primitive_size()
box_unsigned_cell(object_size(dpop())); box_unsigned_cell(object_size(dpop()));
} }
PRIMITIVE(size) PRIMITIVE_FORWARD(size)
{
PRIMITIVE_GETVM()->primitive_size();
}
/* The number of cells from the start of the object which should be scanned by /* The number of cells from the start of the object which should be scanned by
the GC. Some types have a binary payload at the end (string, word, DLL) which the GC. Some types have a binary payload at the end (string, word, DLL) which
@ -284,10 +270,7 @@ inline void factor_vm::primitive_data_room()
dpush(a.elements.value()); dpush(a.elements.value());
} }
PRIMITIVE(data_room) PRIMITIVE_FORWARD(data_room)
{
PRIMITIVE_GETVM()->primitive_data_room();
}
/* Disables GC and activates next-object ( -- obj ) primitive */ /* Disables GC and activates next-object ( -- obj ) primitive */
void factor_vm::begin_scan() void factor_vm::begin_scan()
@ -306,10 +289,7 @@ inline void factor_vm::primitive_begin_scan()
begin_scan(); begin_scan();
} }
PRIMITIVE(begin_scan) PRIMITIVE_FORWARD(begin_scan)
{
PRIMITIVE_GETVM()->primitive_begin_scan();
}
cell factor_vm::next_object() cell factor_vm::next_object()
{ {
@ -330,10 +310,7 @@ inline void factor_vm::primitive_next_object()
dpush(next_object()); dpush(next_object());
} }
PRIMITIVE(next_object) PRIMITIVE_FORWARD(next_object)
{
PRIMITIVE_GETVM()->primitive_next_object();
}
/* Re-enables GC */ /* Re-enables GC */
inline void factor_vm::primitive_end_scan() inline void factor_vm::primitive_end_scan()
@ -341,10 +318,7 @@ inline void factor_vm::primitive_end_scan()
gc_off = false; gc_off = false;
} }
PRIMITIVE(end_scan) PRIMITIVE_FORWARD(end_scan)
{
PRIMITIVE_GETVM()->primitive_end_scan();
}
template<typename TYPE> void factor_vm::each_object(TYPE &functor) template<typename TYPE> void factor_vm::each_object(TYPE &functor)
{ {

28
vm/data_heap.hpp
View File

@ -9,6 +9,14 @@ struct zone {
cell here; cell here;
cell size; cell size;
cell end; cell end;
cell init_zone(cell size_, cell start_)
{
size = size_;
start = here = start_;
end = start_ + size_;
return end;
}
}; };
struct data_heap { struct data_heap {
@ -23,14 +31,14 @@ struct data_heap {
zone *generations; zone *generations;
zone *semispaces; zone *semispaces;
cell *allot_markers; char *allot_markers;
cell *allot_markers_end; char *allot_markers_end;
cell *cards; char *cards;
cell *cards_end; char *cards_end;
cell *decks; char *decks;
cell *decks_end; char *decks_end;
/* the 0th generation is where new objects are allocated. */ /* the 0th generation is where new objects are allocated. */
cell nursery() { return 0; } cell nursery() { return 0; }
@ -42,6 +50,9 @@ struct data_heap {
cell tenured() { return gen_count - 1; } cell tenured() { return gen_count - 1; }
bool have_aging_p() { return gen_count > 2; } bool have_aging_p() { return gen_count > 2; }
data_heap(factor_vm *myvm, cell gen_count, cell young_size, cell aging_size, cell tenured_size);
~data_heap();
}; };
static const cell max_gen_count = 3; static const cell max_gen_count = 3;
@ -51,11 +62,6 @@ inline static bool in_zone(zone *z, object *pointer)
return (cell)pointer >= z->start && (cell)pointer < z->end; return (cell)pointer >= z->start && (cell)pointer < z->end;
} }
/* set up guard pages to check for under/overflow.
size must be a multiple of the page size */
segment *alloc_segment(cell size); // defined in OS-*.cpp files PD
void dealloc_segment(segment *block);
PRIMITIVE(data_room); PRIMITIVE(data_room);
PRIMITIVE(size); PRIMITIVE(size);

9
vm/debug.cpp
View File

@ -297,7 +297,7 @@ void factor_vm::dump_code_heap()
{ {
cell reloc_size = 0, literal_size = 0; cell reloc_size = 0, literal_size = 0;
heap_block *scan = first_block(&code); heap_block *scan = code->first_block();
while(scan) while(scan)
{ {
@ -326,7 +326,7 @@ void factor_vm::dump_code_heap()
print_cell_hex(scan->size); print_string(" "); print_cell_hex(scan->size); print_string(" ");
print_string(status); print_string("\n"); print_string(status); print_string("\n");
scan = next_block(&code,scan); scan = code->next_block(scan);
} }
print_cell(reloc_size); print_string(" bytes of relocation data\n"); print_cell(reloc_size); print_string(" bytes of relocation data\n");
@ -484,9 +484,6 @@ inline void factor_vm::primitive_die()
factorbug(); factorbug();
} }
PRIMITIVE(die) PRIMITIVE_FORWARD(die)
{
PRIMITIVE_GETVM()->primitive_die();
}
} }

20
vm/dispatch.cpp
View File

@ -120,10 +120,7 @@ inline void factor_vm::primitive_lookup_method()
dpush(lookup_method(obj,methods)); dpush(lookup_method(obj,methods));
} }
PRIMITIVE(lookup_method) PRIMITIVE_FORWARD(lookup_method)
{
PRIMITIVE_GETVM()->primitive_lookup_method();
}
cell factor_vm::object_class(cell obj) cell factor_vm::object_class(cell obj)
{ {
@ -169,20 +166,14 @@ inline void factor_vm::primitive_mega_cache_miss()
dpush(method); dpush(method);
} }
PRIMITIVE(mega_cache_miss) PRIMITIVE_FORWARD(mega_cache_miss)
{
PRIMITIVE_GETVM()->primitive_mega_cache_miss();
}
inline void factor_vm::primitive_reset_dispatch_stats() inline void factor_vm::primitive_reset_dispatch_stats()
{ {
megamorphic_cache_hits = megamorphic_cache_misses = 0; megamorphic_cache_hits = megamorphic_cache_misses = 0;
} }
PRIMITIVE(reset_dispatch_stats) PRIMITIVE_FORWARD(reset_dispatch_stats)
{
PRIMITIVE_GETVM()->primitive_reset_dispatch_stats();
}
inline void factor_vm::primitive_dispatch_stats() inline void factor_vm::primitive_dispatch_stats()
{ {
@ -193,10 +184,7 @@ inline void factor_vm::primitive_dispatch_stats()
dpush(stats.elements.value()); dpush(stats.elements.value());
} }
PRIMITIVE(dispatch_stats) PRIMITIVE_FORWARD(dispatch_stats)
{
PRIMITIVE_GETVM()->primitive_dispatch_stats();
}
void quotation_jit::emit_mega_cache_lookup(cell methods_, fixnum index, cell cache_) void quotation_jit::emit_mega_cache_lookup(cell methods_, fixnum index, cell cache_)
{ {

10
vm/errors.cpp
View File

@ -133,10 +133,7 @@ inline void factor_vm::primitive_call_clear()
throw_impl(dpop(),stack_chain->callstack_bottom,this); throw_impl(dpop(),stack_chain->callstack_bottom,this);
} }
PRIMITIVE(call_clear) PRIMITIVE_FORWARD(call_clear)
{
PRIMITIVE_GETVM()->primitive_call_clear();
}
/* For testing purposes */ /* For testing purposes */
inline void factor_vm::primitive_unimplemented() inline void factor_vm::primitive_unimplemented()
@ -144,10 +141,7 @@ inline void factor_vm::primitive_unimplemented()
not_implemented_error(); not_implemented_error();
} }
PRIMITIVE(unimplemented) PRIMITIVE_FORWARD(unimplemented)
{
PRIMITIVE_GETVM()->primitive_unimplemented();
}
void factor_vm::memory_signal_handler_impl() void factor_vm::memory_signal_handler_impl()
{ {

147
vm/code_gc.cpp → vm/heap.cpp Executable file → Normal file
View File

@ -1,37 +1,36 @@
#include "master.hpp" #include "master.hpp"
/* This malloc-style heap code is reasonably generic. Maybe in the future, it
will be used for the data heap too, if we ever get mark/sweep/compact GC. */
namespace factor namespace factor
{ {
void factor_vm::clear_free_list(heap *heap) void heap::clear_free_list()
{ {
memset(&heap->free,0,sizeof(heap_free_list)); memset(&free,0,sizeof(heap_free_list));
} }
/* This malloc-style heap code is reasonably generic. Maybe in the future, it heap::heap(factor_vm *myvm_, cell size)
will be used for the data heap too, if we ever get incremental
mark/sweep/compact GC. */
void factor_vm::new_heap(heap *heap, cell size)
{ {
heap->seg = alloc_segment(align_page(size)); myvm = myvm_;
if(!heap->seg) seg = new segment(myvm,align_page(size));
fatal_error("Out of memory in new_heap",size); if(!seg) fatal_error("Out of memory in new_heap",size);
clear_free_list();
clear_free_list(heap);
} }
void factor_vm::add_to_free_list(heap *heap, free_heap_block *block) 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 = heap->free.small_blocks[index]; block->next_free = free.small_blocks[index];
heap->free.small_blocks[index] = block; free.small_blocks[index] = block;
} }
else else
{ {
block->next_free = heap->free.large_blocks; block->next_free = free.large_blocks;
heap->free.large_blocks = block; free.large_blocks = block;
} }
} }
@ -39,16 +38,16 @@ void factor_vm::add_to_free_list(heap *heap, free_heap_block *block)
In the former case, we must add a large free block from compiling.base + size to In the former case, we must add a large free block from compiling.base + size to
compiling.limit. */ compiling.limit. */
void factor_vm::build_free_list(heap *heap, cell size) void heap::build_free_list(cell size)
{ {
heap_block *prev = NULL; heap_block *prev = NULL;
clear_free_list(heap); clear_free_list();
size = (size + block_size_increment - 1) & ~(block_size_increment - 1); size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
heap_block *scan = first_block(heap); heap_block *scan = first_block();
free_heap_block *end = (free_heap_block *)(heap->seg->start + size); free_heap_block *end = (free_heap_block *)(seg->start + size);
/* Add all free blocks to the free list */ /* Add all free blocks to the free list */
while(scan && scan < (heap_block *)end) while(scan && scan < (heap_block *)end)
@ -56,28 +55,28 @@ void factor_vm::build_free_list(heap *heap, cell size)
switch(scan->status) switch(scan->status)
{ {
case B_FREE: case B_FREE:
add_to_free_list(heap,(free_heap_block *)scan); add_to_free_list((free_heap_block *)scan);
break; break;
case B_ALLOCATED: case B_ALLOCATED:
break; break;
default: default:
critical_error("Invalid scan->status",(cell)scan); myvm->critical_error("Invalid scan->status",(cell)scan);
break; break;
} }
prev = scan; prev = scan;
scan = next_block(heap,scan); scan = next_block(scan);
} }
/* If there is room at the end of the heap, add a free block. This /* If there is room at the end of the heap, add a free block. This
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) <= seg->end)
{ {
end->status = B_FREE; end->status = B_FREE;
end->size = heap->seg->end - (cell)end; end->size = seg->end - (cell)end;
/* add final free block */ /* add final free block */
add_to_free_list(heap,end); add_to_free_list(end);
} }
/* This branch is taken if the newly loaded image fits exactly, or /* This branch is taken if the newly loaded image fits exactly, or
after code GC */ after code GC */
@ -86,30 +85,30 @@ void factor_vm::build_free_list(heap *heap, cell size)
/* even if there's no room at the end of the heap for a new /* 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 free block, we might have to jigger it up by a few bytes in
case prev + prev->size */ case prev + prev->size */
if(prev) prev->size = heap->seg->end - (cell)prev; if(prev) prev->size = seg->end - (cell)prev;
} }
} }
void factor_vm::assert_free_block(free_heap_block *block) void heap::assert_free_block(free_heap_block *block)
{ {
if(block->status != B_FREE) if(block->status != B_FREE)
critical_error("Invalid block in free list",(cell)block); myvm->critical_error("Invalid block in free list",(cell)block);
} }
free_heap_block *factor_vm::find_free_block(heap *heap, cell size) free_heap_block *heap::find_free_block(cell size)
{ {
cell attempt = size; cell attempt = size;
while(attempt < free_list_count * block_size_increment) while(attempt < free_list_count * block_size_increment)
{ {
int index = attempt / block_size_increment; int index = attempt / block_size_increment;
free_heap_block *block = heap->free.small_blocks[index]; free_heap_block *block = free.small_blocks[index];
if(block) if(block)
{ {
assert_free_block(block); assert_free_block(block);
heap->free.small_blocks[index] = block->next_free; free.small_blocks[index] = block->next_free;
return block; return block;
} }
@ -117,7 +116,7 @@ free_heap_block *factor_vm::find_free_block(heap *heap, cell size)
} }
free_heap_block *prev = NULL; free_heap_block *prev = NULL;
free_heap_block *block = heap->free.large_blocks; free_heap_block *block = free.large_blocks;
while(block) while(block)
{ {
@ -127,7 +126,7 @@ free_heap_block *factor_vm::find_free_block(heap *heap, cell size)
if(prev) if(prev)
prev->next_free = block->next_free; prev->next_free = block->next_free;
else else
heap->free.large_blocks = block->next_free; free.large_blocks = block->next_free;
return block; return block;
} }
@ -138,7 +137,7 @@ free_heap_block *factor_vm::find_free_block(heap *heap, cell size)
return NULL; return NULL;
} }
free_heap_block *factor_vm::split_free_block(heap *heap, free_heap_block *block, cell size) free_heap_block *heap::split_free_block(free_heap_block *block, cell size)
{ {
if(block->size != size ) if(block->size != size )
{ {
@ -148,21 +147,21 @@ free_heap_block *factor_vm::split_free_block(heap *heap, free_heap_block *block,
split->size = block->size - size; split->size = block->size - size;
split->next_free = block->next_free; split->next_free = block->next_free;
block->size = size; block->size = size;
add_to_free_list(heap,split); add_to_free_list(split);
} }
return block; return block;
} }
/* Allocate a block of memory from the mark and sweep GC heap */ /* Allocate a block of memory from the mark and sweep GC heap */
heap_block *factor_vm::heap_allot(heap *heap, cell size) heap_block *heap::heap_allot(cell size)
{ {
size = (size + block_size_increment - 1) & ~(block_size_increment - 1); size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
free_heap_block *block = find_free_block(heap,size); free_heap_block *block = find_free_block(size);
if(block) if(block)
{ {
block = split_free_block(heap,block,size); block = split_free_block(block,size);
block->status = B_ALLOCATED; block->status = B_ALLOCATED;
return block; return block;
@ -172,13 +171,13 @@ heap_block *factor_vm::heap_allot(heap *heap, cell size)
} }
/* Deallocates a block manually */ /* Deallocates a block manually */
void factor_vm::heap_free(heap *heap, heap_block *block) void heap::heap_free(heap_block *block)
{ {
block->status = B_FREE; block->status = B_FREE;
add_to_free_list(heap,(free_heap_block *)block); add_to_free_list((free_heap_block *)block);
} }
void factor_vm::mark_block(heap_block *block) void heap::mark_block(heap_block *block)
{ {
/* If already marked, do nothing */ /* If already marked, do nothing */
switch(block->status) switch(block->status)
@ -189,41 +188,41 @@ void factor_vm::mark_block(heap_block *block)
block->status = B_MARKED; block->status = B_MARKED;
break; break;
default: default:
critical_error("Marking the wrong block",(cell)block); myvm->critical_error("Marking the wrong block",(cell)block);
break; break;
} }
} }
/* If in the middle of code GC, we have to grow the heap, data GC restarts from /* 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. */ scratch, so we have to unmark any marked blocks. */
void factor_vm::unmark_marked(heap *heap) void heap::unmark_marked()
{ {
heap_block *scan = first_block(heap); heap_block *scan = first_block();
while(scan) while(scan)
{ {
if(scan->status == B_MARKED) if(scan->status == B_MARKED)
scan->status = B_ALLOCATED; scan->status = B_ALLOCATED;
scan = next_block(heap,scan); scan = next_block(scan);
} }
} }
/* After code GC, all referenced code blocks have status set to B_MARKED, so any /* After code GC, all referenced code blocks have status set to B_MARKED, so any
which are allocated and not marked can be reclaimed. */ which are allocated and not marked can be reclaimed. */
void factor_vm::free_unmarked(heap *heap, heap_iterator iter) void heap::free_unmarked(heap_iterator iter)
{ {
clear_free_list(heap); clear_free_list();
heap_block *prev = NULL; heap_block *prev = NULL;
heap_block *scan = first_block(heap); heap_block *scan = first_block();
while(scan) while(scan)
{ {
switch(scan->status) switch(scan->status)
{ {
case B_ALLOCATED: case B_ALLOCATED:
if(secure_gc) if(myvm->secure_gc)
memset(scan + 1,0,scan->size - sizeof(heap_block)); memset(scan + 1,0,scan->size - sizeof(heap_block));
if(prev && prev->status == B_FREE) if(prev && prev->status == B_FREE)
@ -242,30 +241,30 @@ void factor_vm::free_unmarked(heap *heap, heap_iterator iter)
break; break;
case B_MARKED: case B_MARKED:
if(prev && prev->status == B_FREE) if(prev && prev->status == B_FREE)
add_to_free_list(heap,(free_heap_block *)prev); add_to_free_list((free_heap_block *)prev);
scan->status = B_ALLOCATED; scan->status = B_ALLOCATED;
prev = scan; prev = scan;
iter(scan,this); iter(scan,myvm);
break; break;
default: default:
critical_error("Invalid scan->status",(cell)scan); myvm->critical_error("Invalid scan->status",(cell)scan);
} }
scan = next_block(heap,scan); scan = next_block(scan);
} }
if(prev && prev->status == B_FREE) if(prev && prev->status == B_FREE)
add_to_free_list(heap,(free_heap_block *)prev); add_to_free_list((free_heap_block *)prev);
} }
/* Compute total sum of sizes of free blocks, and size of largest free block */ /* Compute total sum of sizes of free blocks, and size of largest free block */
void factor_vm::heap_usage(heap *heap, cell *used, cell *total_free, cell *max_free) void heap::heap_usage(cell *used, cell *total_free, cell *max_free)
{ {
*used = 0; *used = 0;
*total_free = 0; *total_free = 0;
*max_free = 0; *max_free = 0;
heap_block *scan = first_block(heap); heap_block *scan = first_block();
while(scan) while(scan)
{ {
@ -280,34 +279,34 @@ void factor_vm::heap_usage(heap *heap, cell *used, cell *total_free, cell *max_f
*max_free = scan->size; *max_free = scan->size;
break; break;
default: default:
critical_error("Invalid scan->status",(cell)scan); myvm->critical_error("Invalid scan->status",(cell)scan);
} }
scan = next_block(heap,scan); scan = next_block(scan);
} }
} }
/* The size of the heap, not including the last block if it's free */ /* The size of the heap, not including the last block if it's free */
cell factor_vm::heap_size(heap *heap) cell heap::heap_size()
{ {
heap_block *scan = first_block(heap); heap_block *scan = first_block();
while(next_block(heap,scan) != NULL) while(next_block(scan) != NULL)
scan = next_block(heap,scan); scan = next_block(scan);
/* this is the last block in the heap, and it is free */ /* this is the last block in the heap, and it is free */
if(scan->status == B_FREE) if(scan->status == B_FREE)
return (cell)scan - heap->seg->start; return (cell)scan - seg->start;
/* otherwise the last block is allocated */ /* otherwise the last block is allocated */
else else
return heap->seg->size; return seg->size;
} }
/* Compute where each block is going to go, after compaction */ /* Compute where each block is going to go, after compaction */
cell factor_vm::compute_heap_forwarding(heap *heap, unordered_map<heap_block *,char *> &forwarding) cell heap::compute_heap_forwarding(unordered_map<heap_block *,char *> &forwarding)
{ {
heap_block *scan = first_block(heap); heap_block *scan = first_block();
char *address = (char *)first_block(heap); char *address = (char *)first_block();
while(scan) while(scan)
{ {
@ -317,21 +316,21 @@ cell factor_vm::compute_heap_forwarding(heap *heap, unordered_map<heap_block *,c
address += scan->size; address += scan->size;
} }
else if(scan->status == B_MARKED) else if(scan->status == B_MARKED)
critical_error("Why is the block marked?",0); myvm->critical_error("Why is the block marked?",0);
scan = next_block(heap,scan); scan = next_block(scan);
} }
return (cell)address - heap->seg->start; return (cell)address - seg->start;
} }
void factor_vm::compact_heap(heap *heap, unordered_map<heap_block *,char *> &forwarding) void heap::compact_heap(unordered_map<heap_block *,char *> &forwarding)
{ {
heap_block *scan = first_block(heap); heap_block *scan = first_block();
while(scan) while(scan)
{ {
heap_block *next = next_block(heap,scan); heap_block *next = next_block(scan);
if(scan->status == B_ALLOCATED) if(scan->status == B_ALLOCATED)
memmove(forwarding[scan],scan,scan->size); memmove(forwarding[scan],scan,scan->size);

59
vm/heap.hpp Normal file
View File

@ -0,0 +1,59 @@
namespace factor
{
static const cell free_list_count = 16;
static const cell block_size_increment = 32;
struct heap_free_list {
free_heap_block *small_blocks[free_list_count];
free_heap_block *large_blocks;
};
typedef void (*heap_iterator)(heap_block *compiled, factor_vm *vm);
struct heap {
factor_vm *myvm;
segment *seg;
heap_free_list free;
heap(factor_vm *myvm, cell size);
inline heap_block *next_block(heap_block *block)
{
cell next = ((cell)block + block->size);
if(next == seg->end)
return NULL;
else
return (heap_block *)next;
}
inline heap_block *first_block()
{
return (heap_block *)seg->start;
}
inline heap_block *last_block()
{
return (heap_block *)seg->end;
}
void clear_free_list();
void new_heap(cell size);
void add_to_free_list(free_heap_block *block);
void build_free_list(cell size);
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);
void heap_free(heap_block *block);
void mark_block(heap_block *block);
void unmark_marked();
void free_unmarked(heap_iterator iter);
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);
};
}

22
vm/image.cpp
View File

@ -56,7 +56,7 @@ void factor_vm::load_code_heap(FILE *file, image_header *h, vm_parameters *p)
if(h->code_size != 0) if(h->code_size != 0)
{ {
size_t bytes_read = fread(first_block(&code),1,h->code_size,file); size_t bytes_read = fread(code->first_block(),1,h->code_size,file);
if(bytes_read != h->code_size) if(bytes_read != h->code_size)
{ {
print_string("truncated image: "); print_string("truncated image: ");
@ -69,7 +69,7 @@ void factor_vm::load_code_heap(FILE *file, image_header *h, vm_parameters *p)
} }
code_relocation_base = h->code_relocation_base; code_relocation_base = h->code_relocation_base;
build_free_list(&code,h->code_size); code->build_free_list(h->code_size);
} }
/* Save the current image to disk */ /* Save the current image to disk */
@ -92,8 +92,8 @@ bool factor_vm::save_image(const vm_char *filename)
h.version = image_version; h.version = image_version;
h.data_relocation_base = tenured->start; h.data_relocation_base = tenured->start;
h.data_size = tenured->here - tenured->start; h.data_size = tenured->here - tenured->start;
h.code_relocation_base = code.seg->start; h.code_relocation_base = code->seg->start;
h.code_size = heap_size(&code); h.code_size = code->heap_size();
h.t = T; h.t = T;
h.bignum_zero = bignum_zero; h.bignum_zero = bignum_zero;
@ -107,7 +107,7 @@ bool factor_vm::save_image(const vm_char *filename)
if(fwrite(&h,sizeof(image_header),1,file) != 1) ok = false; 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*)tenured->start,h.data_size,1,file) != 1) ok = false;
if(fwrite(first_block(&code),h.code_size,1,file) != 1) ok = false; if(fwrite(code->first_block(),h.code_size,1,file) != 1) ok = false;
if(fclose(file)) ok = false; if(fclose(file)) ok = false;
if(!ok) if(!ok)
@ -128,10 +128,7 @@ inline void factor_vm::primitive_save_image()
save_image((vm_char *)(path.untagged() + 1)); save_image((vm_char *)(path.untagged() + 1));
} }
PRIMITIVE(save_image) PRIMITIVE_FORWARD(save_image)
{
PRIMITIVE_GETVM()->primitive_save_image();
}
inline void factor_vm::primitive_save_image_and_exit() inline void factor_vm::primitive_save_image_and_exit()
{ {
@ -159,10 +156,7 @@ inline void factor_vm::primitive_save_image_and_exit()
exit(1); exit(1);
} }
PRIMITIVE(save_image_and_exit) PRIMITIVE_FORWARD(save_image_and_exit)
{
PRIMITIVE_GETVM()->primitive_save_image_and_exit();
}
void factor_vm::data_fixup(cell *cell) void factor_vm::data_fixup(cell *cell)
{ {
@ -181,7 +175,7 @@ void data_fixup(cell *cell, factor_vm *myvm)
template <typename TYPE> void factor_vm::code_fixup(TYPE **handle) template <typename TYPE> void factor_vm::code_fixup(TYPE **handle)
{ {
TYPE *ptr = *handle; TYPE *ptr = *handle;
TYPE *new_ptr = (TYPE *)(((cell)ptr) + (code.seg->start - code_relocation_base)); TYPE *new_ptr = (TYPE *)(((cell)ptr) + (code->seg->start - code_relocation_base));
*handle = new_ptr; *handle = new_ptr;
} }

12
vm/inline_cache.cpp
View File

@ -24,7 +24,7 @@ void factor_vm::deallocate_inline_cache(cell return_address)
#endif #endif
if(old_type == PIC_TYPE) if(old_type == PIC_TYPE)
heap_free(&code,old_block); code->heap_free(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
@ -257,10 +257,7 @@ inline void factor_vm::primitive_reset_inline_cache_stats()
for(i = 0; i < 4; i++) pic_counts[i] = 0; for(i = 0; i < 4; i++) pic_counts[i] = 0;
} }
PRIMITIVE(reset_inline_cache_stats) PRIMITIVE_FORWARD(reset_inline_cache_stats)
{
PRIMITIVE_GETVM()->primitive_reset_inline_cache_stats();
}
inline void factor_vm::primitive_inline_cache_stats() inline void factor_vm::primitive_inline_cache_stats()
{ {
@ -275,9 +272,6 @@ inline void factor_vm::primitive_inline_cache_stats()
dpush(stats.elements.value()); dpush(stats.elements.value());
} }
PRIMITIVE(inline_cache_stats) PRIMITIVE_FORWARD(inline_cache_stats)
{
PRIMITIVE_GETVM()->primitive_inline_cache_stats();
}
} }

7
vm/inlineimpls.hpp
View File

@ -4,13 +4,6 @@ namespace factor
// I've had to copy inline implementations here to make dependencies work. Am hoping to move this code back into include files // I've had to copy inline implementations here to make dependencies work. Am hoping to move this code back into include files
// once the rest of the reentrant changes are done. -PD // once the rest of the reentrant changes are done. -PD
// segments.hpp
inline cell factor_vm::align_page(cell a)
{
return align(a,getpagesize());
}
// write_barrier.hpp // write_barrier.hpp
inline card *factor_vm::addr_to_card(cell a) inline card *factor_vm::addr_to_card(cell a)

40
vm/io.cpp
View File

@ -52,10 +52,7 @@ inline void factor_vm::primitive_fopen()
} }
} }
PRIMITIVE(fopen) PRIMITIVE_FORWARD(fopen)
{
PRIMITIVE_GETVM()->primitive_fopen();
}
inline void factor_vm::primitive_fgetc() inline void factor_vm::primitive_fgetc()
{ {
@ -82,10 +79,7 @@ inline void factor_vm::primitive_fgetc()
} }
} }
PRIMITIVE(fgetc) PRIMITIVE_FORWARD(fgetc)
{
PRIMITIVE_GETVM()->primitive_fgetc();
}
inline void factor_vm::primitive_fread() inline void factor_vm::primitive_fread()
{ {
@ -127,10 +121,7 @@ inline void factor_vm::primitive_fread()
} }
} }
PRIMITIVE(fread) PRIMITIVE_FORWARD(fread)
{
PRIMITIVE_GETVM()->primitive_fread();
}
inline void factor_vm::primitive_fputc() inline void factor_vm::primitive_fputc()
{ {
@ -150,10 +141,7 @@ inline void factor_vm::primitive_fputc()
} }
} }
PRIMITIVE(fputc) PRIMITIVE_FORWARD(fputc)
{
PRIMITIVE_GETVM()->primitive_fputc();
}
inline void factor_vm::primitive_fwrite() inline void factor_vm::primitive_fwrite()
{ {
@ -184,10 +172,7 @@ inline void factor_vm::primitive_fwrite()
} }
} }
PRIMITIVE(fwrite) PRIMITIVE_FORWARD(fwrite)
{
PRIMITIVE_GETVM()->primitive_fwrite();
}
inline void factor_vm::primitive_fseek() inline void factor_vm::primitive_fseek()
{ {
@ -214,10 +199,7 @@ inline void factor_vm::primitive_fseek()
} }
} }
PRIMITIVE(fseek) PRIMITIVE_FORWARD(fseek)
{
PRIMITIVE_GETVM()->primitive_fseek();
}
inline void factor_vm::primitive_fflush() inline void factor_vm::primitive_fflush()
{ {
@ -231,10 +213,7 @@ inline void factor_vm::primitive_fflush()
} }
} }
PRIMITIVE(fflush) PRIMITIVE_FORWARD(fflush)
{
PRIMITIVE_GETVM()->primitive_fflush();
}
inline void factor_vm::primitive_fclose() inline void factor_vm::primitive_fclose()
{ {
@ -248,10 +227,7 @@ inline void factor_vm::primitive_fclose()
} }
} }
PRIMITIVE(fclose) PRIMITIVE_FORWARD(fclose)
{
PRIMITIVE_GETVM()->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

2
vm/master.hpp
View File

@ -64,7 +64,7 @@
#include "math.hpp" #include "math.hpp"
#include "float_bits.hpp" #include "float_bits.hpp"
#include "io.hpp" #include "io.hpp"
#include "code_gc.hpp" #include "heap.hpp"
#include "code_heap.hpp" #include "code_heap.hpp"
#include "image.hpp" #include "image.hpp"
#include "callstack.hpp" #include "callstack.hpp"

226
vm/math.cpp
View File

@ -8,20 +8,14 @@ inline void factor_vm::primitive_bignum_to_fixnum()
drepl(tag_fixnum(bignum_to_fixnum(untag<bignum>(dpeek())))); drepl(tag_fixnum(bignum_to_fixnum(untag<bignum>(dpeek()))));
} }
PRIMITIVE(bignum_to_fixnum) PRIMITIVE_FORWARD(bignum_to_fixnum)
{
PRIMITIVE_GETVM()->primitive_bignum_to_fixnum();
}
inline void factor_vm::primitive_float_to_fixnum() inline void factor_vm::primitive_float_to_fixnum()
{ {
drepl(tag_fixnum(float_to_fixnum(dpeek()))); drepl(tag_fixnum(float_to_fixnum(dpeek())));
} }
PRIMITIVE(float_to_fixnum) PRIMITIVE_FORWARD(float_to_fixnum)
{
PRIMITIVE_GETVM()->primitive_float_to_fixnum();
}
/* Division can only overflow when we are dividing the most negative fixnum /* Division can only overflow when we are dividing the most negative fixnum
by -1. */ by -1. */
@ -36,10 +30,7 @@ inline void factor_vm::primitive_fixnum_divint()
drepl(tag_fixnum(result)); drepl(tag_fixnum(result));
} }
PRIMITIVE(fixnum_divint) PRIMITIVE_FORWARD(fixnum_divint)
{
PRIMITIVE_GETVM()->primitive_fixnum_divint();
}
inline void factor_vm::primitive_fixnum_divmod() inline void factor_vm::primitive_fixnum_divmod()
{ {
@ -57,10 +48,7 @@ inline void factor_vm::primitive_fixnum_divmod()
} }
} }
PRIMITIVE(fixnum_divmod) PRIMITIVE_FORWARD(fixnum_divmod)
{
PRIMITIVE_GETVM()->primitive_fixnum_divmod();
}
/* /*
* If we're shifting right by n bits, we won't overflow as long as none of the * If we're shifting right by n bits, we won't overflow as long as none of the
@ -108,30 +96,21 @@ inline void factor_vm::primitive_fixnum_shift()
fixnum_to_bignum(x),y))); fixnum_to_bignum(x),y)));
} }
PRIMITIVE(fixnum_shift) PRIMITIVE_FORWARD(fixnum_shift)
{
PRIMITIVE_GETVM()->primitive_fixnum_shift();
}
inline void factor_vm::primitive_fixnum_to_bignum() inline void factor_vm::primitive_fixnum_to_bignum()
{ {
drepl(tag<bignum>(fixnum_to_bignum(untag_fixnum(dpeek())))); drepl(tag<bignum>(fixnum_to_bignum(untag_fixnum(dpeek()))));
} }
PRIMITIVE(fixnum_to_bignum) PRIMITIVE_FORWARD(fixnum_to_bignum)
{
PRIMITIVE_GETVM()->primitive_fixnum_to_bignum();
}
inline void factor_vm::primitive_float_to_bignum() inline void factor_vm::primitive_float_to_bignum()
{ {
drepl(tag<bignum>(float_to_bignum(dpeek()))); drepl(tag<bignum>(float_to_bignum(dpeek())));
} }
PRIMITIVE(float_to_bignum) PRIMITIVE_FORWARD(float_to_bignum)
{
PRIMITIVE_GETVM()->primitive_float_to_bignum();
}
#define POP_BIGNUMS(x,y) \ #define POP_BIGNUMS(x,y) \
bignum * y = untag<bignum>(dpop()); \ bignum * y = untag<bignum>(dpop()); \
@ -143,10 +122,7 @@ inline void factor_vm::primitive_bignum_eq()
box_boolean(bignum_equal_p(x,y)); box_boolean(bignum_equal_p(x,y));
} }
PRIMITIVE(bignum_eq) PRIMITIVE_FORWARD(bignum_eq)
{
PRIMITIVE_GETVM()->primitive_bignum_eq();
}
inline void factor_vm::primitive_bignum_add() inline void factor_vm::primitive_bignum_add()
{ {
@ -154,10 +130,7 @@ inline void factor_vm::primitive_bignum_add()
dpush(tag<bignum>(bignum_add(x,y))); dpush(tag<bignum>(bignum_add(x,y)));
} }
PRIMITIVE(bignum_add) PRIMITIVE_FORWARD(bignum_add)
{
PRIMITIVE_GETVM()->primitive_bignum_add();
}
inline void factor_vm::primitive_bignum_subtract() inline void factor_vm::primitive_bignum_subtract()
{ {
@ -165,10 +138,7 @@ inline void factor_vm::primitive_bignum_subtract()
dpush(tag<bignum>(bignum_subtract(x,y))); dpush(tag<bignum>(bignum_subtract(x,y)));
} }
PRIMITIVE(bignum_subtract) PRIMITIVE_FORWARD(bignum_subtract)
{
PRIMITIVE_GETVM()->primitive_bignum_subtract();
}
inline void factor_vm::primitive_bignum_multiply() inline void factor_vm::primitive_bignum_multiply()
{ {
@ -176,10 +146,7 @@ inline void factor_vm::primitive_bignum_multiply()
dpush(tag<bignum>(bignum_multiply(x,y))); dpush(tag<bignum>(bignum_multiply(x,y)));
} }
PRIMITIVE(bignum_multiply) PRIMITIVE_FORWARD(bignum_multiply)
{
PRIMITIVE_GETVM()->primitive_bignum_multiply();
}
inline void factor_vm::primitive_bignum_divint() inline void factor_vm::primitive_bignum_divint()
{ {
@ -187,10 +154,7 @@ inline void factor_vm::primitive_bignum_divint()
dpush(tag<bignum>(bignum_quotient(x,y))); dpush(tag<bignum>(bignum_quotient(x,y)));
} }
PRIMITIVE(bignum_divint) PRIMITIVE_FORWARD(bignum_divint)
{
PRIMITIVE_GETVM()->primitive_bignum_divint();
}
inline void factor_vm::primitive_bignum_divmod() inline void factor_vm::primitive_bignum_divmod()
{ {
@ -201,10 +165,7 @@ inline void factor_vm::primitive_bignum_divmod()
dpush(tag<bignum>(r)); dpush(tag<bignum>(r));
} }
PRIMITIVE(bignum_divmod) PRIMITIVE_FORWARD(bignum_divmod)
{
PRIMITIVE_GETVM()->primitive_bignum_divmod();
}
inline void factor_vm::primitive_bignum_mod() inline void factor_vm::primitive_bignum_mod()
{ {
@ -212,10 +173,7 @@ inline void factor_vm::primitive_bignum_mod()
dpush(tag<bignum>(bignum_remainder(x,y))); dpush(tag<bignum>(bignum_remainder(x,y)));
} }
PRIMITIVE(bignum_mod) PRIMITIVE_FORWARD(bignum_mod)
{
PRIMITIVE_GETVM()->primitive_bignum_mod();
}
inline void factor_vm::primitive_bignum_and() inline void factor_vm::primitive_bignum_and()
{ {
@ -223,10 +181,7 @@ inline void factor_vm::primitive_bignum_and()
dpush(tag<bignum>(bignum_bitwise_and(x,y))); dpush(tag<bignum>(bignum_bitwise_and(x,y)));
} }
PRIMITIVE(bignum_and) PRIMITIVE_FORWARD(bignum_and)
{
PRIMITIVE_GETVM()->primitive_bignum_and();
}
inline void factor_vm::primitive_bignum_or() inline void factor_vm::primitive_bignum_or()
{ {
@ -234,10 +189,7 @@ inline void factor_vm::primitive_bignum_or()
dpush(tag<bignum>(bignum_bitwise_ior(x,y))); dpush(tag<bignum>(bignum_bitwise_ior(x,y)));
} }
PRIMITIVE(bignum_or) PRIMITIVE_FORWARD(bignum_or)
{
PRIMITIVE_GETVM()->primitive_bignum_or();
}
inline void factor_vm::primitive_bignum_xor() inline void factor_vm::primitive_bignum_xor()
{ {
@ -245,10 +197,7 @@ inline void factor_vm::primitive_bignum_xor()
dpush(tag<bignum>(bignum_bitwise_xor(x,y))); dpush(tag<bignum>(bignum_bitwise_xor(x,y)));
} }
PRIMITIVE(bignum_xor) PRIMITIVE_FORWARD(bignum_xor)
{
PRIMITIVE_GETVM()->primitive_bignum_xor();
}
inline void factor_vm::primitive_bignum_shift() inline void factor_vm::primitive_bignum_shift()
{ {
@ -257,10 +206,7 @@ inline void factor_vm::primitive_bignum_shift()
dpush(tag<bignum>(bignum_arithmetic_shift(x,y))); dpush(tag<bignum>(bignum_arithmetic_shift(x,y)));
} }
PRIMITIVE(bignum_shift) PRIMITIVE_FORWARD(bignum_shift)
{
PRIMITIVE_GETVM()->primitive_bignum_shift();
}
inline void factor_vm::primitive_bignum_less() inline void factor_vm::primitive_bignum_less()
{ {
@ -268,10 +214,7 @@ inline void factor_vm::primitive_bignum_less()
box_boolean(bignum_compare(x,y) == bignum_comparison_less); box_boolean(bignum_compare(x,y) == bignum_comparison_less);
} }
PRIMITIVE(bignum_less) PRIMITIVE_FORWARD(bignum_less)
{
PRIMITIVE_GETVM()->primitive_bignum_less();
}
inline void factor_vm::primitive_bignum_lesseq() inline void factor_vm::primitive_bignum_lesseq()
{ {
@ -279,10 +222,7 @@ inline void factor_vm::primitive_bignum_lesseq()
box_boolean(bignum_compare(x,y) != bignum_comparison_greater); box_boolean(bignum_compare(x,y) != bignum_comparison_greater);
} }
PRIMITIVE(bignum_lesseq) PRIMITIVE_FORWARD(bignum_lesseq)
{
PRIMITIVE_GETVM()->primitive_bignum_lesseq();
}
inline void factor_vm::primitive_bignum_greater() inline void factor_vm::primitive_bignum_greater()
{ {
@ -290,10 +230,7 @@ inline void factor_vm::primitive_bignum_greater()
box_boolean(bignum_compare(x,y) == bignum_comparison_greater); box_boolean(bignum_compare(x,y) == bignum_comparison_greater);
} }
PRIMITIVE(bignum_greater) PRIMITIVE_FORWARD(bignum_greater)
{
PRIMITIVE_GETVM()->primitive_bignum_greater();
}
inline void factor_vm::primitive_bignum_greatereq() inline void factor_vm::primitive_bignum_greatereq()
{ {
@ -301,20 +238,14 @@ inline void factor_vm::primitive_bignum_greatereq()
box_boolean(bignum_compare(x,y) != bignum_comparison_less); box_boolean(bignum_compare(x,y) != bignum_comparison_less);
} }
PRIMITIVE(bignum_greatereq) PRIMITIVE_FORWARD(bignum_greatereq)
{
PRIMITIVE_GETVM()->primitive_bignum_greatereq();
}
inline void factor_vm::primitive_bignum_not() inline void factor_vm::primitive_bignum_not()
{ {
drepl(tag<bignum>(bignum_bitwise_not(untag<bignum>(dpeek())))); drepl(tag<bignum>(bignum_bitwise_not(untag<bignum>(dpeek()))));
} }
PRIMITIVE(bignum_not) PRIMITIVE_FORWARD(bignum_not)
{
PRIMITIVE_GETVM()->primitive_bignum_not();
}
inline void factor_vm::primitive_bignum_bitp() inline void factor_vm::primitive_bignum_bitp()
{ {
@ -323,20 +254,14 @@ inline void factor_vm::primitive_bignum_bitp()
box_boolean(bignum_logbitp(bit,x)); box_boolean(bignum_logbitp(bit,x));
} }
PRIMITIVE(bignum_bitp) PRIMITIVE_FORWARD(bignum_bitp)
{
PRIMITIVE_GETVM()->primitive_bignum_bitp();
}
inline void factor_vm::primitive_bignum_log2() inline void factor_vm::primitive_bignum_log2()
{ {
drepl(tag<bignum>(bignum_integer_length(untag<bignum>(dpeek())))); drepl(tag<bignum>(bignum_integer_length(untag<bignum>(dpeek()))));
} }
PRIMITIVE(bignum_log2) PRIMITIVE_FORWARD(bignum_log2)
{
PRIMITIVE_GETVM()->primitive_bignum_log2();
}
unsigned int factor_vm::bignum_producer(unsigned int digit) unsigned int factor_vm::bignum_producer(unsigned int digit)
{ {
@ -356,10 +281,7 @@ inline void factor_vm::primitive_byte_array_to_bignum()
drepl(tag<bignum>(result)); drepl(tag<bignum>(result));
} }
PRIMITIVE(byte_array_to_bignum) PRIMITIVE_FORWARD(byte_array_to_bignum)
{
PRIMITIVE_GETVM()->primitive_byte_array_to_bignum();
}
cell factor_vm::unbox_array_size() cell factor_vm::unbox_array_size()
{ {
@ -399,20 +321,14 @@ inline void factor_vm::primitive_fixnum_to_float()
drepl(allot_float(fixnum_to_float(dpeek()))); drepl(allot_float(fixnum_to_float(dpeek())));
} }
PRIMITIVE(fixnum_to_float) PRIMITIVE_FORWARD(fixnum_to_float)
{
PRIMITIVE_GETVM()->primitive_fixnum_to_float();
}
inline void factor_vm::primitive_bignum_to_float() inline void factor_vm::primitive_bignum_to_float()
{ {
drepl(allot_float(bignum_to_float(dpeek()))); drepl(allot_float(bignum_to_float(dpeek())));
} }
PRIMITIVE(bignum_to_float) PRIMITIVE_FORWARD(bignum_to_float)
{
PRIMITIVE_GETVM()->primitive_bignum_to_float();
}
inline void factor_vm::primitive_str_to_float() inline void factor_vm::primitive_str_to_float()
{ {
@ -428,10 +344,7 @@ inline void factor_vm::primitive_str_to_float()
drepl(F); drepl(F);
} }
PRIMITIVE(str_to_float) PRIMITIVE_FORWARD(str_to_float)
{
PRIMITIVE_GETVM()->primitive_str_to_float();
}
inline void factor_vm::primitive_float_to_str() inline void factor_vm::primitive_float_to_str()
{ {
@ -440,10 +353,7 @@ inline void factor_vm::primitive_float_to_str()
dpush(tag<byte_array>(array)); dpush(tag<byte_array>(array));
} }
PRIMITIVE(float_to_str) PRIMITIVE_FORWARD(float_to_str)
{
PRIMITIVE_GETVM()->primitive_float_to_str();
}
#define POP_FLOATS(x,y) \ #define POP_FLOATS(x,y) \
double y = untag_float(dpop()); \ double y = untag_float(dpop()); \
@ -455,10 +365,7 @@ inline void factor_vm::primitive_float_eq()
box_boolean(x == y); box_boolean(x == y);
} }
PRIMITIVE(float_eq) PRIMITIVE_FORWARD(float_eq)
{
PRIMITIVE_GETVM()->primitive_float_eq();
}
inline void factor_vm::primitive_float_add() inline void factor_vm::primitive_float_add()
{ {
@ -466,10 +373,7 @@ inline void factor_vm::primitive_float_add()
box_double(x + y); box_double(x + y);
} }
PRIMITIVE(float_add) PRIMITIVE_FORWARD(float_add)
{
PRIMITIVE_GETVM()->primitive_float_add();
}
inline void factor_vm::primitive_float_subtract() inline void factor_vm::primitive_float_subtract()
{ {
@ -477,10 +381,7 @@ inline void factor_vm::primitive_float_subtract()
box_double(x - y); box_double(x - y);
} }
PRIMITIVE(float_subtract) PRIMITIVE_FORWARD(float_subtract)
{
PRIMITIVE_GETVM()->primitive_float_subtract();
}
inline void factor_vm::primitive_float_multiply() inline void factor_vm::primitive_float_multiply()
{ {
@ -488,10 +389,7 @@ inline void factor_vm::primitive_float_multiply()
box_double(x * y); box_double(x * y);
} }
PRIMITIVE(float_multiply) PRIMITIVE_FORWARD(float_multiply)
{
PRIMITIVE_GETVM()->primitive_float_multiply();
}
inline void factor_vm::primitive_float_divfloat() inline void factor_vm::primitive_float_divfloat()
{ {
@ -499,10 +397,7 @@ inline void factor_vm::primitive_float_divfloat()
box_double(x / y); box_double(x / y);
} }
PRIMITIVE(float_divfloat) PRIMITIVE_FORWARD(float_divfloat)
{
PRIMITIVE_GETVM()->primitive_float_divfloat();
}
inline void factor_vm::primitive_float_mod() inline void factor_vm::primitive_float_mod()
{ {
@ -510,10 +405,7 @@ inline void factor_vm::primitive_float_mod()
box_double(fmod(x,y)); box_double(fmod(x,y));
} }
PRIMITIVE(float_mod) PRIMITIVE_FORWARD(float_mod)
{
PRIMITIVE_GETVM()->primitive_float_mod();
}
inline void factor_vm::primitive_float_less() inline void factor_vm::primitive_float_less()
{ {
@ -521,10 +413,7 @@ inline void factor_vm::primitive_float_less()
box_boolean(x < y); box_boolean(x < y);
} }
PRIMITIVE(float_less) PRIMITIVE_FORWARD(float_less)
{
PRIMITIVE_GETVM()->primitive_float_less();
}
inline void factor_vm::primitive_float_lesseq() inline void factor_vm::primitive_float_lesseq()
{ {
@ -532,10 +421,7 @@ inline void factor_vm::primitive_float_lesseq()
box_boolean(x <= y); box_boolean(x <= y);
} }
PRIMITIVE(float_lesseq) PRIMITIVE_FORWARD(float_lesseq)
{
PRIMITIVE_GETVM()->primitive_float_lesseq();
}
inline void factor_vm::primitive_float_greater() inline void factor_vm::primitive_float_greater()
{ {
@ -543,10 +429,7 @@ inline void factor_vm::primitive_float_greater()
box_boolean(x > y); box_boolean(x > y);
} }
PRIMITIVE(float_greater) PRIMITIVE_FORWARD(float_greater)
{
PRIMITIVE_GETVM()->primitive_float_greater();
}
inline void factor_vm::primitive_float_greatereq() inline void factor_vm::primitive_float_greatereq()
{ {
@ -554,50 +437,35 @@ inline void factor_vm::primitive_float_greatereq()
box_boolean(x >= y); box_boolean(x >= y);
} }
PRIMITIVE(float_greatereq) PRIMITIVE_FORWARD(float_greatereq)
{
PRIMITIVE_GETVM()->primitive_float_greatereq();
}
inline void factor_vm::primitive_float_bits() inline void factor_vm::primitive_float_bits()
{ {
box_unsigned_4(float_bits(untag_float_check(dpop()))); box_unsigned_4(float_bits(untag_float_check(dpop())));
} }
PRIMITIVE(float_bits) PRIMITIVE_FORWARD(float_bits)
{
PRIMITIVE_GETVM()->primitive_float_bits();
}
inline void factor_vm::primitive_bits_float() inline void factor_vm::primitive_bits_float()
{ {
box_float(bits_float(to_cell(dpop()))); box_float(bits_float(to_cell(dpop())));
} }
PRIMITIVE(bits_float) PRIMITIVE_FORWARD(bits_float)
{
PRIMITIVE_GETVM()->primitive_bits_float();
}
inline void factor_vm::primitive_double_bits() inline void factor_vm::primitive_double_bits()
{ {
box_unsigned_8(double_bits(untag_float_check(dpop()))); box_unsigned_8(double_bits(untag_float_check(dpop())));
} }
PRIMITIVE(double_bits) PRIMITIVE_FORWARD(double_bits)
{
PRIMITIVE_GETVM()->primitive_double_bits();
}
inline void factor_vm::primitive_bits_double() inline void factor_vm::primitive_bits_double()
{ {
box_double(bits_double(to_unsigned_8(dpop()))); box_double(bits_double(to_unsigned_8(dpop())));
} }
PRIMITIVE(bits_double) PRIMITIVE_FORWARD(bits_double)
{
PRIMITIVE_GETVM()->primitive_bits_double();
}
fixnum factor_vm::to_fixnum(cell tagged) fixnum factor_vm::to_fixnum(cell tagged)
{ {
@ -838,7 +706,7 @@ inline void factor_vm::overflow_fixnum_add(fixnum x, fixnum y)
untag_fixnum(x) + untag_fixnum(y)))); untag_fixnum(x) + untag_fixnum(y))));
} }
VM_ASM_API_OVERFLOW void overflow_fixnum_add(fixnum x, fixnum y, factor_vm *myvm) VM_ASM_API void overflow_fixnum_add(fixnum x, fixnum y, factor_vm *myvm)
{ {
PRIMITIVE_OVERFLOW_GETVM()->overflow_fixnum_add(x,y); PRIMITIVE_OVERFLOW_GETVM()->overflow_fixnum_add(x,y);
} }
@ -849,7 +717,7 @@ inline void factor_vm::overflow_fixnum_subtract(fixnum x, fixnum y)
untag_fixnum(x) - untag_fixnum(y)))); untag_fixnum(x) - untag_fixnum(y))));
} }
VM_ASM_API_OVERFLOW void overflow_fixnum_subtract(fixnum x, fixnum y, factor_vm *myvm) VM_ASM_API void overflow_fixnum_subtract(fixnum x, fixnum y, factor_vm *myvm)
{ {
PRIMITIVE_OVERFLOW_GETVM()->overflow_fixnum_subtract(x,y); PRIMITIVE_OVERFLOW_GETVM()->overflow_fixnum_subtract(x,y);
} }
@ -863,7 +731,7 @@ inline void factor_vm::overflow_fixnum_multiply(fixnum x, fixnum y)
drepl(tag<bignum>(bignum_multiply(bx,by))); drepl(tag<bignum>(bignum_multiply(bx,by)));
} }
VM_ASM_API_OVERFLOW void overflow_fixnum_multiply(fixnum x, fixnum y, factor_vm *myvm) VM_ASM_API void overflow_fixnum_multiply(fixnum x, fixnum y, factor_vm *myvm)
{ {
PRIMITIVE_OVERFLOW_GETVM()->overflow_fixnum_multiply(x,y); PRIMITIVE_OVERFLOW_GETVM()->overflow_fixnum_multiply(x,y);
} }

6
vm/math.hpp
View File

@ -83,8 +83,8 @@ VM_C_API u64 to_unsigned_8(cell obj, factor_vm *vm);
VM_C_API fixnum to_fixnum(cell tagged, factor_vm *vm); VM_C_API fixnum to_fixnum(cell tagged, factor_vm *vm);
VM_C_API cell to_cell(cell tagged, factor_vm *vm); VM_C_API cell to_cell(cell tagged, factor_vm *vm);
VM_ASM_API_OVERFLOW void overflow_fixnum_add(fixnum x, fixnum y, factor_vm *vm); VM_ASM_API void overflow_fixnum_add(fixnum x, fixnum y, factor_vm *vm);
VM_ASM_API_OVERFLOW void overflow_fixnum_subtract(fixnum x, fixnum y, factor_vm *vm); VM_ASM_API void overflow_fixnum_subtract(fixnum x, fixnum y, factor_vm *vm);
VM_ASM_API_OVERFLOW void overflow_fixnum_multiply(fixnum x, fixnum y, factor_vm *vm); VM_ASM_API void overflow_fixnum_multiply(fixnum x, fixnum y, factor_vm *vm);
} }

3
vm/os-genunix.cpp
View File

@ -18,6 +18,7 @@ void early_init() { }
#define SUFFIX ".image" #define SUFFIX ".image"
#define SUFFIX_LEN 6 #define SUFFIX_LEN 6
/* You must delete[] the result yourself. */
const char *default_image_path() const char *default_image_path()
{ {
const char *path = vm_executable_path(); const char *path = vm_executable_path();
@ -31,7 +32,7 @@ const char *default_image_path()
const char *iter = path; const char *iter = path;
while(*iter) { len++; iter++; } while(*iter) { len++; iter++; }
char *new_path = (char *)safe_malloc(PATH_MAX + SUFFIX_LEN + 1); char *new_path = new char[PATH_MAX + SUFFIX_LEN + 1];
memcpy(new_path,path,len + 1); memcpy(new_path,path,len + 1);
memcpy(new_path + len,SUFFIX,SUFFIX_LEN + 1); memcpy(new_path + len,SUFFIX,SUFFIX_LEN + 1);
return new_path; return new_path;

4
vm/os-linux.cpp
View File

@ -3,10 +3,10 @@
namespace factor namespace factor
{ {
/* Snarfed from SBCL linux-so.c. You must free() this yourself. */ /* Snarfed from SBCL linux-so.c. You must delete[] the result yourself. */
const char *vm_executable_path() const char *vm_executable_path()
{ {
char *path = (char *)safe_malloc(PATH_MAX + 1); char *path = new char[PATH_MAX + 1];
int size = readlink("/proc/self/exe", path, PATH_MAX); int size = readlink("/proc/self/exe", path, PATH_MAX);
if (size < 0) if (size < 0)

37
vm/os-unix.cpp
View File

@ -21,9 +21,8 @@ pthread_key_t tlsKey = 0;
void init_platform_globals() void init_platform_globals()
{ {
if (pthread_key_create(&tlsKey, NULL) != 0){ if (pthread_key_create(&tlsKey, NULL) != 0)
fatal_error("pthread_key_create() failed",0); fatal_error("pthread_key_create() failed",0);
}
} }
@ -75,8 +74,6 @@ void factor_vm::ffi_dlclose(dll *dll)
dll->dll = NULL; dll->dll = NULL;
} }
inline void factor_vm::primitive_existsp() inline void factor_vm::primitive_existsp()
{ {
struct stat sb; struct stat sb;
@ -84,13 +81,13 @@ inline void factor_vm::primitive_existsp()
box_boolean(stat(path,&sb) >= 0); box_boolean(stat(path,&sb) >= 0);
} }
PRIMITIVE(existsp) PRIMITIVE_FORWARD(existsp)
{
PRIMITIVE_GETVM()->primitive_existsp();
}
segment *factor_vm::alloc_segment(cell size) segment::segment(factor_vm *myvm_, cell size_)
{ {
myvm = myvm_;
size = size_;
int pagesize = getpagesize(); int pagesize = getpagesize();
char *array = (char *)mmap(NULL,pagesize + size + pagesize, char *array = (char *)mmap(NULL,pagesize + size + pagesize,
@ -98,7 +95,7 @@ segment *factor_vm::alloc_segment(cell size)
MAP_ANON | MAP_PRIVATE,-1,0); MAP_ANON | MAP_PRIVATE,-1,0);
if(array == (char*)-1) if(array == (char*)-1)
out_of_memory(); myvm->out_of_memory();
if(mprotect(array,pagesize,PROT_NONE) == -1) if(mprotect(array,pagesize,PROT_NONE) == -1)
fatal_error("Cannot protect low guard page",(cell)array); fatal_error("Cannot protect low guard page",(cell)array);
@ -106,26 +103,16 @@ segment *factor_vm::alloc_segment(cell size)
if(mprotect(array + pagesize + size,pagesize,PROT_NONE) == -1) if(mprotect(array + pagesize + size,pagesize,PROT_NONE) == -1)
fatal_error("Cannot protect high guard page",(cell)array); fatal_error("Cannot protect high guard page",(cell)array);
segment *retval = (segment *)safe_malloc(sizeof(segment)); start = (cell)(array + pagesize);
end = start + size;
retval->start = (cell)(array + pagesize);
retval->size = size;
retval->end = retval->start + size;
return retval;
} }
void dealloc_segment(segment *block) segment::~segment()
{ {
int pagesize = getpagesize(); int pagesize = getpagesize();
int retval = munmap((void*)(start - pagesize),pagesize + size + pagesize);
int retval = munmap((void*)(block->start - pagesize),
pagesize + block->size + pagesize);
if(retval) if(retval)
fatal_error("dealloc_segment failed",0); fatal_error("Segment deallocation failed",0);
free(block);
} }
stack_frame *factor_vm::uap_stack_pointer(void *uap) stack_frame *factor_vm::uap_stack_pointer(void *uap)

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

@ -30,10 +30,7 @@ char *getenv(char *name)
return 0; /* unreachable */ return 0; /* unreachable */
} }
PRIMITIVE(os_envs) PRIMITIVE_FORWARD(os_envs)
{
vm->not_implemented_error();
}
void c_to_factor_toplevel(cell quot) void c_to_factor_toplevel(cell quot)
{ {

28
vm/os-windows.cpp
View File

@ -96,19 +96,19 @@ inline void factor_vm::primitive_existsp()
box_boolean(windows_stat(path)); box_boolean(windows_stat(path));
} }
PRIMITIVE(existsp) PRIMITIVE_FORWARD(existsp)
{
PRIMITIVE_GETVM()->primitive_existsp();
}
segment *factor_vm::alloc_segment(cell size) segment::segment(factor_vm *myvm_, cell size_)
{ {
myvm = myvm_;
size = size_;
char *mem; char *mem;
DWORD ignore; DWORD ignore;
if((mem = (char *)VirtualAlloc(NULL, getpagesize() * 2 + size, if((mem = (char *)VirtualAlloc(NULL, getpagesize() * 2 + size,
MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == 0) MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == 0)
out_of_memory(); myvm->out_of_memory();
if (!VirtualProtect(mem, getpagesize(), PAGE_NOACCESS, &ignore)) if (!VirtualProtect(mem, getpagesize(), PAGE_NOACCESS, &ignore))
fatal_error("Cannot allocate low guard page", (cell)mem); fatal_error("Cannot allocate low guard page", (cell)mem);
@ -117,22 +117,16 @@ segment *factor_vm::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 = (segment *)safe_malloc(sizeof(segment)); start = (cell)mem + getpagesize();
end = start + size;
block->start = (cell)mem + getpagesize();
block->size = size;
block->end = block->start + size;
return block;
} }
void factor_vm::dealloc_segment(segment *block) segment::~segment()
{ {
SYSTEM_INFO si; SYSTEM_INFO si;
GetSystemInfo(&si); GetSystemInfo(&si);
if(!VirtualFree((void*)(block->start - si.dwPageSize), 0, MEM_RELEASE)) if(!VirtualFree((void*)(start - si.dwPageSize), 0, MEM_RELEASE))
fatal_error("dealloc_segment failed",0); myvm->fatal_error("Segment deallocation failed",0);
free(block);
} }
long factor_vm::getpagesize() long factor_vm::getpagesize()

9
vm/primitives.hpp
View File

@ -4,10 +4,17 @@ namespace factor
#if defined(FACTOR_X86) #if defined(FACTOR_X86)
extern "C" __attribute__ ((regparm (1))) typedef void (*primitive_type)(void *myvm); extern "C" __attribute__ ((regparm (1))) typedef void (*primitive_type)(void *myvm);
#define PRIMITIVE(name) extern "C" __attribute__ ((regparm (1))) void primitive_##name(void *myvm) #define PRIMITIVE(name) extern "C" __attribute__ ((regparm (1))) void primitive_##name(void *myvm)
#define PRIMITIVE_FORWARD(name) extern "C" __attribute__ ((regparm (1))) void primitive_##name(void *myvm) \
{ \
PRIMITIVE_GETVM()->primitive_##name(); \
}
#else #else
extern "C" typedef void (*primitive_type)(void *myvm); extern "C" typedef void (*primitive_type)(void *myvm);
#define PRIMITIVE(name) extern "C" void primitive_##name(void *myvm) #define PRIMITIVE(name) extern "C" void primitive_##name(void *myvm)
#define PRIMITIVE_FORWARD(name) extern "C" void primitive_##name(void *myvm) \
{ \
PRIMITIVE_GETVM()->primitive_##name(); \
}
#endif #endif
extern const primitive_type primitives[]; extern const primitive_type primitives[];
} }

5
vm/profiler.cpp
View File

@ -52,9 +52,6 @@ inline void factor_vm::primitive_profiling()
set_profiling(to_boolean(dpop())); set_profiling(to_boolean(dpop()));
} }
PRIMITIVE(profiling) PRIMITIVE_FORWARD(profiling)
{
PRIMITIVE_GETVM()->primitive_profiling();
}
} }

95
vm/quotations.cpp
View File

@ -36,51 +36,47 @@ includes stack shufflers, some fixnum arithmetic words, and words such as tag,
slot and eq?. A primitive call is relatively expensive (two subroutine calls) slot and eq?. A primitive call is relatively expensive (two subroutine calls)
so this results in a big speedup for relatively little effort. */ so this results in a big speedup for relatively little effort. */
bool quotation_jit::primitive_call_p(cell i) bool quotation_jit::primitive_call_p(cell i, cell length)
{ {
return (i + 2) == array_capacity(elements.untagged()) return (i + 2) == length && array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_PRIMITIVE_WORD];
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(FIXNUM_TYPE)
&& array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_PRIMITIVE_WORD];
} }
bool quotation_jit::fast_if_p(cell i) bool quotation_jit::fast_if_p(cell i, cell length)
{ {
return (i + 3) == array_capacity(elements.untagged()) return (i + 3) == length
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
&& tagged<object>(array_nth(elements.untagged(),i + 1)).type_p(QUOTATION_TYPE) && tagged<object>(array_nth(elements.untagged(),i + 1)).type_p(QUOTATION_TYPE)
&& array_nth(elements.untagged(),i + 2) == parent_vm->userenv[JIT_IF_WORD]; && array_nth(elements.untagged(),i + 2) == parent_vm->userenv[JIT_IF_WORD];
} }
bool quotation_jit::fast_dip_p(cell i) bool quotation_jit::fast_dip_p(cell i, cell length)
{ {
return (i + 2) <= array_capacity(elements.untagged()) return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_DIP_WORD];
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
&& array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_DIP_WORD];
} }
bool quotation_jit::fast_2dip_p(cell i) bool quotation_jit::fast_2dip_p(cell i, cell length)
{ {
return (i + 2) <= array_capacity(elements.untagged()) return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_2DIP_WORD];
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
&& array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_2DIP_WORD];
} }
bool quotation_jit::fast_3dip_p(cell i) bool quotation_jit::fast_3dip_p(cell i, cell length)
{ {
return (i + 2) <= array_capacity(elements.untagged()) return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_3DIP_WORD];
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
&& array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_3DIP_WORD];
} }
bool quotation_jit::mega_lookup_p(cell i) bool quotation_jit::mega_lookup_p(cell i, cell length)
{ {
return (i + 3) < array_capacity(elements.untagged()) return (i + 4) <= length
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(ARRAY_TYPE)
&& tagged<object>(array_nth(elements.untagged(),i + 1)).type_p(FIXNUM_TYPE) && tagged<object>(array_nth(elements.untagged(),i + 1)).type_p(FIXNUM_TYPE)
&& tagged<object>(array_nth(elements.untagged(),i + 2)).type_p(ARRAY_TYPE) && tagged<object>(array_nth(elements.untagged(),i + 2)).type_p(ARRAY_TYPE)
&& array_nth(elements.untagged(),i + 3) == parent_vm->userenv[MEGA_LOOKUP_WORD]; && array_nth(elements.untagged(),i + 3) == parent_vm->userenv[MEGA_LOOKUP_WORD];
} }
bool quotation_jit::declare_p(cell i, cell length)
{
return (i + 2) <= length
&& array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_DECLARE_WORD];
}
bool quotation_jit::stack_frame_p() bool quotation_jit::stack_frame_p()
{ {
fixnum length = array_capacity(elements.untagged()); fixnum length = array_capacity(elements.untagged());
@ -96,7 +92,7 @@ bool quotation_jit::stack_frame_p()
return true; return true;
break; break;
case QUOTATION_TYPE: case QUOTATION_TYPE:
if(fast_dip_p(i) || fast_2dip_p(i) || fast_3dip_p(i)) if(fast_dip_p(i,length) || fast_2dip_p(i,length) || fast_3dip_p(i,length))
return true; return true;
break; break;
default: default:
@ -179,19 +175,21 @@ void quotation_jit::iterate_quotation()
break; break;
case FIXNUM_TYPE: case FIXNUM_TYPE:
/* Primitive calls */ /* Primitive calls */
if(primitive_call_p(i)) if(primitive_call_p(i,length))
{ {
emit_with(parent_vm->userenv[JIT_PRIMITIVE],obj.value()); emit_with(parent_vm->userenv[JIT_PRIMITIVE],obj.value());
i++; i++;
tail_call = true; tail_call = true;
break;
} }
else
push(obj.value());
break;
case QUOTATION_TYPE: case QUOTATION_TYPE:
/* 'if' preceeded by two literal quotations (this is why if and ? are /* 'if' preceeded by two literal quotations (this is why if and ? are
mutually recursive in the library, but both still work) */ mutually recursive in the library, but both still work) */
if(fast_if_p(i)) if(fast_if_p(i,length))
{ {
if(stack_frame) emit(parent_vm->userenv[JIT_EPILOG]); if(stack_frame) emit(parent_vm->userenv[JIT_EPILOG]);
tail_call = true; tail_call = true;
@ -207,39 +205,37 @@ void quotation_jit::iterate_quotation()
emit(parent_vm->userenv[JIT_IF]); emit(parent_vm->userenv[JIT_IF]);
i += 2; i += 2;
break;
} }
/* dip */ /* dip */
else if(fast_dip_p(i)) else if(fast_dip_p(i,length))
{ {
if(compiling) if(compiling)
parent_vm->jit_compile(obj.value(),relocate); parent_vm->jit_compile(obj.value(),relocate);
emit_with(parent_vm->userenv[JIT_DIP],obj.value()); emit_with(parent_vm->userenv[JIT_DIP],obj.value());
i++; i++;
break;
} }
/* 2dip */ /* 2dip */
else if(fast_2dip_p(i)) else if(fast_2dip_p(i,length))
{ {
if(compiling) if(compiling)
parent_vm->jit_compile(obj.value(),relocate); parent_vm->jit_compile(obj.value(),relocate);
emit_with(parent_vm->userenv[JIT_2DIP],obj.value()); emit_with(parent_vm->userenv[JIT_2DIP],obj.value());
i++; i++;
break;
} }
/* 3dip */ /* 3dip */
else if(fast_3dip_p(i)) else if(fast_3dip_p(i,length))
{ {
if(compiling) if(compiling)
parent_vm->jit_compile(obj.value(),relocate); parent_vm->jit_compile(obj.value(),relocate);
emit_with(parent_vm->userenv[JIT_3DIP],obj.value()); emit_with(parent_vm->userenv[JIT_3DIP],obj.value());
i++; i++;
break;
} }
else
push(obj.value());
break;
case ARRAY_TYPE: case ARRAY_TYPE:
/* Method dispatch */ /* Method dispatch */
if(mega_lookup_p(i)) if(mega_lookup_p(i,length))
{ {
emit_mega_cache_lookup( emit_mega_cache_lookup(
array_nth(elements.untagged(),i), array_nth(elements.untagged(),i),
@ -247,8 +243,13 @@ void quotation_jit::iterate_quotation()
array_nth(elements.untagged(),i + 2)); array_nth(elements.untagged(),i + 2));
i += 3; i += 3;
tail_call = true; tail_call = true;
break;
} }
/* Non-optimizing compiler ignores declarations */
else if(declare_p(i,length))
i++;
else
push(obj.value());
break;
default: default:
push(obj.value()); push(obj.value());
break; break;
@ -294,10 +295,7 @@ inline void factor_vm::primitive_jit_compile()
jit_compile(dpop(),true); jit_compile(dpop(),true);
} }
PRIMITIVE(jit_compile) PRIMITIVE_FORWARD(jit_compile)
{
PRIMITIVE_GETVM()->primitive_jit_compile();
}
/* push a new quotation on the stack */ /* push a new quotation on the stack */
inline void factor_vm::primitive_array_to_quotation() inline void factor_vm::primitive_array_to_quotation()
@ -311,10 +309,7 @@ inline void factor_vm::primitive_array_to_quotation()
drepl(tag<quotation>(quot)); drepl(tag<quotation>(quot));
} }
PRIMITIVE(array_to_quotation) PRIMITIVE_FORWARD(array_to_quotation)
{
PRIMITIVE_GETVM()->primitive_array_to_quotation();
}
inline void factor_vm::primitive_quotation_xt() inline void factor_vm::primitive_quotation_xt()
{ {
@ -322,10 +317,7 @@ inline void factor_vm::primitive_quotation_xt()
drepl(allot_cell((cell)quot->xt)); drepl(allot_cell((cell)quot->xt));
} }
PRIMITIVE(quotation_xt) PRIMITIVE_FORWARD(quotation_xt)
{
PRIMITIVE_GETVM()->primitive_quotation_xt();
}
void factor_vm::compile_all_words() void factor_vm::compile_all_words()
{ {
@ -368,7 +360,7 @@ cell factor_vm::lazy_jit_compile_impl(cell quot_, stack_frame *stack)
return quot.value(); return quot.value();
} }
VM_ASM_API_OVERFLOW cell lazy_jit_compile_impl(cell quot_, stack_frame *stack, factor_vm *myvm) VM_ASM_API cell lazy_jit_compile_impl(cell quot_, stack_frame *stack, factor_vm *myvm)
{ {
ASSERTVM(); ASSERTVM();
return VM_PTR->lazy_jit_compile_impl(quot_,stack); return VM_PTR->lazy_jit_compile_impl(quot_,stack);
@ -381,9 +373,6 @@ inline void factor_vm::primitive_quot_compiled_p()
dpush(tag_boolean(quot->code != NULL)); dpush(tag_boolean(quot->code != NULL));
} }
PRIMITIVE(quot_compiled_p) PRIMITIVE_FORWARD(quot_compiled_p)
{
PRIMITIVE_GETVM()->primitive_quot_compiled_p();
}
} }

15
vm/quotations.hpp
View File

@ -12,12 +12,13 @@ struct quotation_jit : public jit {
relocate(relocate_){}; relocate(relocate_){};
void emit_mega_cache_lookup(cell methods, fixnum index, cell cache); void emit_mega_cache_lookup(cell methods, fixnum index, cell cache);
bool primitive_call_p(cell i); bool primitive_call_p(cell i, cell length);
bool fast_if_p(cell i); bool fast_if_p(cell i, cell length);
bool fast_dip_p(cell i); bool fast_dip_p(cell i, cell length);
bool fast_2dip_p(cell i); bool fast_2dip_p(cell i, cell length);
bool fast_3dip_p(cell i); bool fast_3dip_p(cell i, cell length);
bool mega_lookup_p(cell i); bool mega_lookup_p(cell i, cell length);
bool declare_p(cell i, cell length);
bool stack_frame_p(); bool stack_frame_p();
void iterate_quotation(); void iterate_quotation();
}; };
@ -27,7 +28,7 @@ PRIMITIVE(jit_compile);
PRIMITIVE(array_to_quotation); PRIMITIVE(array_to_quotation);
PRIMITIVE(quotation_xt); PRIMITIVE(quotation_xt);
VM_ASM_API_OVERFLOW cell lazy_jit_compile_impl(cell quot, stack_frame *stack, factor_vm *myvm); VM_ASM_API cell lazy_jit_compile_impl(cell quot, stack_frame *stack, factor_vm *myvm);
PRIMITIVE(quot_compiled_p); PRIMITIVE(quot_compiled_p);

40
vm/run.cpp
View File

@ -9,10 +9,7 @@ inline void factor_vm::primitive_getenv()
drepl(userenv[e]); drepl(userenv[e]);
} }
PRIMITIVE(getenv) PRIMITIVE_FORWARD(getenv)
{
PRIMITIVE_GETVM()->primitive_getenv();
}
inline void factor_vm::primitive_setenv() inline void factor_vm::primitive_setenv()
{ {
@ -21,40 +18,28 @@ inline void factor_vm::primitive_setenv()
userenv[e] = value; userenv[e] = value;
} }
PRIMITIVE(setenv) PRIMITIVE_FORWARD(setenv)
{
PRIMITIVE_GETVM()->primitive_setenv();
}
inline void factor_vm::primitive_exit() inline void factor_vm::primitive_exit()
{ {
exit(to_fixnum(dpop())); exit(to_fixnum(dpop()));
} }
PRIMITIVE(exit) PRIMITIVE_FORWARD(exit)
{
PRIMITIVE_GETVM()->primitive_exit();
}
inline void factor_vm::primitive_micros() inline void factor_vm::primitive_micros()
{ {
box_unsigned_8(current_micros()); box_unsigned_8(current_micros());
} }
PRIMITIVE(micros) PRIMITIVE_FORWARD(micros)
{
PRIMITIVE_GETVM()->primitive_micros();
}
inline void factor_vm::primitive_sleep() inline void factor_vm::primitive_sleep()
{ {
sleep_micros(to_cell(dpop())); sleep_micros(to_cell(dpop()));
} }
PRIMITIVE(sleep) PRIMITIVE_FORWARD(sleep)
{
PRIMITIVE_GETVM()->primitive_sleep();
}
inline void factor_vm::primitive_set_slot() inline void factor_vm::primitive_set_slot()
{ {
@ -66,10 +51,7 @@ inline void factor_vm::primitive_set_slot()
write_barrier(obj); write_barrier(obj);
} }
PRIMITIVE(set_slot) PRIMITIVE_FORWARD(set_slot)
{
PRIMITIVE_GETVM()->primitive_set_slot();
}
inline void factor_vm::primitive_load_locals() inline void factor_vm::primitive_load_locals()
{ {
@ -79,10 +61,7 @@ inline void factor_vm::primitive_load_locals()
rs += sizeof(cell) * count; rs += sizeof(cell) * count;
} }
PRIMITIVE(load_locals) PRIMITIVE_FORWARD(load_locals)
{
PRIMITIVE_GETVM()->primitive_load_locals();
}
cell factor_vm::clone_object(cell obj_) cell factor_vm::clone_object(cell obj_)
{ {
@ -104,9 +83,6 @@ inline void factor_vm::primitive_clone()
drepl(clone_object(dpeek())); drepl(clone_object(dpeek()));
} }
PRIMITIVE(clone) PRIMITIVE_FORWARD(clone)
{
PRIMITIVE_GETVM()->primitive_clone();
}
} }

1
vm/run.hpp
View File

@ -57,6 +57,7 @@ enum special_object {
JIT_EXECUTE_WORD, JIT_EXECUTE_WORD,
JIT_EXECUTE_JUMP, JIT_EXECUTE_JUMP,
JIT_EXECUTE_CALL, JIT_EXECUTE_CALL,
JIT_DECLARE_WORD,
/* Polymorphic inline cache generation in inline_cache.c */ /* Polymorphic inline cache generation in inline_cache.c */
PIC_LOAD = 47, PIC_LOAD = 47,

13
vm/segments.hpp
View File

@ -1,10 +1,23 @@
namespace factor namespace factor
{ {
struct factor_vm;
inline cell align_page(cell a)
{
return align(a,getpagesize());
}
/* segments set up guard pages to check for under/overflow.
size must be a multiple of the page size */
struct segment { struct segment {
factor_vm *myvm;
cell start; cell start;
cell size; cell size;
cell end; cell end;
segment(factor_vm *myvm, cell size);
~segment();
}; };
} }

25
vm/strings.cpp
View File

@ -106,10 +106,7 @@ inline void factor_vm::primitive_string()
dpush(tag<string>(allot_string(length,initial))); dpush(tag<string>(allot_string(length,initial)));
} }
PRIMITIVE(string) PRIMITIVE_FORWARD(string)
{
PRIMITIVE_GETVM()->primitive_string();
}
bool factor_vm::reallot_string_in_place_p(string *str, cell capacity) bool factor_vm::reallot_string_in_place_p(string *str, cell capacity)
{ {
@ -167,10 +164,7 @@ inline void factor_vm::primitive_resize_string()
dpush(tag<string>(reallot_string(str,capacity))); dpush(tag<string>(reallot_string(str,capacity)));
} }
PRIMITIVE(resize_string) PRIMITIVE_FORWARD(resize_string)
{
PRIMITIVE_GETVM()->primitive_resize_string();
}
inline void factor_vm::primitive_string_nth() inline void factor_vm::primitive_string_nth()
{ {
@ -179,10 +173,7 @@ inline void factor_vm::primitive_string_nth()
dpush(tag_fixnum(string_nth(str,index))); dpush(tag_fixnum(string_nth(str,index)));
} }
PRIMITIVE(string_nth) PRIMITIVE_FORWARD(string_nth)
{
PRIMITIVE_GETVM()->primitive_string_nth();
}
inline void factor_vm::primitive_set_string_nth_fast() inline void factor_vm::primitive_set_string_nth_fast()
{ {
@ -192,10 +183,7 @@ inline void factor_vm::primitive_set_string_nth_fast()
set_string_nth_fast(str,index,value); set_string_nth_fast(str,index,value);
} }
PRIMITIVE(set_string_nth_fast) PRIMITIVE_FORWARD(set_string_nth_fast)
{
PRIMITIVE_GETVM()->primitive_set_string_nth_fast();
}
inline void factor_vm::primitive_set_string_nth_slow() inline void factor_vm::primitive_set_string_nth_slow()
{ {
@ -205,9 +193,6 @@ inline void factor_vm::primitive_set_string_nth_slow()
set_string_nth_slow(str,index,value); set_string_nth_slow(str,index,value);
} }
PRIMITIVE(set_string_nth_slow) PRIMITIVE_FORWARD(set_string_nth_slow)
{
PRIMITIVE_GETVM()->primitive_set_string_nth_slow();
}
} }

10
vm/tuples.cpp
View File

@ -23,10 +23,7 @@ inline void factor_vm::primitive_tuple()
dpush(tag<tuple>(t)); dpush(tag<tuple>(t));
} }
PRIMITIVE(tuple) PRIMITIVE_FORWARD(tuple)
{
PRIMITIVE_GETVM()->primitive_tuple();
}
/* push a new tuple on the stack, filling its slots from the stack */ /* push a new tuple on the stack, filling its slots from the stack */
inline void factor_vm::primitive_tuple_boa() inline void factor_vm::primitive_tuple_boa()
@ -39,9 +36,6 @@ inline void factor_vm::primitive_tuple_boa()
dpush(t.value()); dpush(t.value());
} }
PRIMITIVE(tuple_boa) PRIMITIVE_FORWARD(tuple_boa)
{
PRIMITIVE_GETVM()->primitive_tuple_boa();
}
} }

7
vm/utilities.cpp
View File

@ -4,13 +4,6 @@ namespace factor
{ {
/* If memory allocation fails, bail out */ /* If memory allocation fails, bail out */
void *safe_malloc(size_t size)
{
void *ptr = malloc(size);
if(!ptr) fatal_error("Out of memory in safe_malloc", 0);
return ptr;
}
vm_char *safe_strdup(const vm_char *str) vm_char *safe_strdup(const vm_char *str)
{ {
vm_char *ptr = STRDUP(str); vm_char *ptr = STRDUP(str);

1
vm/utilities.hpp
View File

@ -1,6 +1,5 @@
namespace factor namespace factor
{ {
void *safe_malloc(size_t size);
vm_char *safe_strdup(const vm_char *str); vm_char *safe_strdup(const vm_char *str);
void print_string(const char *str); void print_string(const char *str);
void nl(); void nl();

4
vm/vm-data.hpp
View File

@ -83,8 +83,8 @@ struct factor_vm_data {
cell bignum_neg_one; cell bignum_neg_one;
//code_heap //code_heap
heap code; heap *code;
unordered_map<heap_block *,char *> forwarding; unordered_map<heap_block *, char *> forwarding;
//image //image
cell code_relocation_base; cell code_relocation_base;

26
vm/vm.hpp
View File

@ -5,9 +5,6 @@ namespace factor
struct factor_vm : factor_vm_data { struct factor_vm : factor_vm_data {
// segments
inline cell align_page(cell a);
// contexts // contexts
void reset_datastack(); void reset_datastack();
void reset_retainstack(); void reset_retainstack();
@ -127,11 +124,8 @@ struct factor_vm : factor_vm_data {
bignum *digit_stream_to_bignum(unsigned int n_digits, unsigned int (*producer)(unsigned int, factor_vm *), unsigned int radix, int negative_p); bignum *digit_stream_to_bignum(unsigned int n_digits, unsigned int (*producer)(unsigned int, factor_vm *), unsigned int radix, int negative_p);
//data_heap //data_heap
cell init_zone(zone *z, cell size, cell start);
void init_card_decks(); void init_card_decks();
data_heap *alloc_data_heap(cell gens, cell young_size,cell aging_size,cell tenured_size);
data_heap *grow_data_heap(data_heap *data, cell requested_bytes); data_heap *grow_data_heap(data_heap *data, cell requested_bytes);
void dealloc_data_heap(data_heap *data);
void clear_cards(cell from, cell to); void clear_cards(cell from, cell to);
void clear_decks(cell from, cell to); void clear_decks(cell from, cell to);
void clear_allot_markers(cell from, cell to); void clear_allot_markers(cell from, cell to);
@ -381,24 +375,6 @@ struct factor_vm : factor_vm_data {
inline void primitive_fflush(); inline void primitive_fflush();
inline void primitive_fclose(); inline void primitive_fclose();
//code_gc
void clear_free_list(heap *heap);
void new_heap(heap *heap, cell size);
void add_to_free_list(heap *heap, free_heap_block *block);
void build_free_list(heap *heap, cell size);
void assert_free_block(free_heap_block *block);
free_heap_block *find_free_block(heap *heap, cell size);
free_heap_block *split_free_block(heap *heap, free_heap_block *block, cell size);
heap_block *heap_allot(heap *heap, cell size);
void heap_free(heap *heap, heap_block *block);
void mark_block(heap_block *block);
void unmark_marked(heap *heap);
void free_unmarked(heap *heap, heap_iterator iter);
void heap_usage(heap *heap, cell *used, cell *total_free, cell *max_free);
cell heap_size(heap *heap);
cell compute_heap_forwarding(heap *heap, unordered_map<heap_block *,char *> &forwarding);
void compact_heap(heap *heap, unordered_map<heap_block *,char *> &forwarding);
//code_block //code_block
relocation_type relocation_type_of(relocation_entry r); relocation_type relocation_type_of(relocation_entry r);
relocation_class relocation_class_of(relocation_entry r); relocation_class relocation_class_of(relocation_entry r);
@ -578,14 +554,12 @@ struct factor_vm : factor_vm_data {
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);
segment *alloc_segment(cell size);
void c_to_factor_toplevel(cell quot); void c_to_factor_toplevel(cell quot);
// os-windows // os-windows
#if defined(WINDOWS) #if defined(WINDOWS)
void sleep_micros(u64 usec); void sleep_micros(u64 usec);
long getpagesize(); long getpagesize();
void dealloc_segment(segment *block);
const vm_char *vm_executable_path(); const vm_char *vm_executable_path();
const vm_char *default_image_path(); const vm_char *default_image_path();
void windows_image_path(vm_char *full_path, vm_char *temp_path, unsigned int length); void windows_image_path(vm_char *full_path, vm_char *temp_path, unsigned int length);

37
vm/words.cpp
View File

@ -39,24 +39,27 @@ inline void factor_vm::primitive_word()
dpush(tag<word>(allot_word(vocab,name))); dpush(tag<word>(allot_word(vocab,name)));
} }
PRIMITIVE(word) PRIMITIVE_FORWARD(word)
{
PRIMITIVE_GETVM()->primitive_word();
}
/* word-xt ( word -- start end ) */ /* word-xt ( word -- start end ) */
inline void factor_vm::primitive_word_xt() inline void factor_vm::primitive_word_xt()
{ {
word *w = untag_check<word>(dpop()); gc_root<word> w(dpop(),this);
code_block *code = (profiling_p ? w->profiling : w->code); w.untag_check(this);
dpush(allot_cell((cell)code->xt()));
dpush(allot_cell((cell)code + code->size)); if(profiling_p)
{
dpush(allot_cell((cell)w->profiling->xt()));
dpush(allot_cell((cell)w->profiling + w->profiling->size));
}
else
{
dpush(allot_cell((cell)w->code->xt()));
dpush(allot_cell((cell)w->code + w->code->size));
}
} }
PRIMITIVE(word_xt) PRIMITIVE_FORWARD(word_xt)
{
PRIMITIVE_GETVM()->primitive_word_xt();
}
/* Allocates memory */ /* Allocates memory */
void factor_vm::update_word_xt(cell w_) void factor_vm::update_word_xt(cell w_)
@ -85,10 +88,7 @@ inline void factor_vm::primitive_optimized_p()
drepl(tag_boolean(word_optimized_p(untag_check<word>(dpeek())))); drepl(tag_boolean(word_optimized_p(untag_check<word>(dpeek()))));
} }
PRIMITIVE(optimized_p) PRIMITIVE_FORWARD(optimized_p)
{
PRIMITIVE_GETVM()->primitive_optimized_p();
}
inline void factor_vm::primitive_wrapper() inline void factor_vm::primitive_wrapper()
{ {
@ -97,9 +97,6 @@ inline void factor_vm::primitive_wrapper()
drepl(tag<wrapper>(new_wrapper)); drepl(tag<wrapper>(new_wrapper));
} }
PRIMITIVE(wrapper) PRIMITIVE_FORWARD(wrapper)
{
PRIMITIVE_GETVM()->primitive_wrapper();
}
} }