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/callstack.o \
vm/code_block.o \
vm/code_gc.o \
vm/code_heap.o \
vm/contexts.o \
vm/data_gc.o \
@ -47,6 +46,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/dispatch.o \
vm/errors.o \
vm/factor.o \
vm/heap.o \
vm/image.o \
vm/inline_cache.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-jump 42
USERENV: jit-execute-call 43
USERENV: jit-declare-word 44
! PIC stubs
USERENV: pic-load 47
@ -493,6 +494,7 @@ M: quotation '
\ inline-cache-miss-tail \ pic-miss-tail-word set
\ mega-cache-lookup \ mega-lookup-word set
\ mega-cache-miss \ mega-miss-word set
\ declare jit-declare-word set
[ undefined ] undefined-quot set ;
: 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 arrays locals byte-arrays kernel.private math
slots.private vectors sbufs strings math.partial-dispatch
hashtables assocs combinators.short-circuit
strings.private accessors compiler.cfg.instructions ;
IN: compiler.cfg.builder.tests
@ -204,4 +205,7 @@ IN: compiler.cfg.builder.tests
[ [ ##box-alien? ] contains-insn? ]
[ [ ##box-float? ] contains-insn? ] bi
] 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 ]
[ [ tagged-values>> ] [ temp1>> ] bi save-gc-roots ]
[ [ 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 ]
[ data-values>> load-data-regs ]
} cleave
@ -447,7 +447,7 @@ M: ##alien-indirect generate-insn
! Generate code for boxing input parameters in a callback.
[
dup \ %save-param-reg move-parameters
"nest_stacks" %vm-invoke-1st-arg
%nest-stacks
box-parameters
] with-param-regs ;
@ -485,8 +485,6 @@ TUPLE: callback-context ;
[ callback-context new do-callback ] %
] [ ] make ;
: %unnest-stacks ( -- ) "unnest_stacks" %vm-invoke-1st-arg ;
M: ##callback-return generate-insn
#! All the extra book-keeping for %unwind is only for x86.
#! 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
ffi_test_48
] 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: %save-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: %epilogue cpu ( n -- )
@ -383,9 +383,6 @@ M: object %prepare-var-args ;
HOOK: %alien-invoke cpu ( function library -- )
HOOK: %vm-invoke-1st-arg cpu ( function -- )
HOOK: %vm-invoke-3rd-arg cpu ( function -- )
HOOK: %cleanup cpu ( params -- )
M: object %cleanup ( params -- ) drop ;
@ -398,6 +395,10 @@ HOOK: %alien-callback cpu ( quot -- )
HOOK: %callback-value cpu ( ctype -- )
HOOK: %nest-stacks cpu ( -- )
HOOK: %unnest-stacks cpu ( -- )
! Return to caller with stdcall unwinding (only for x86)
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-invoke-1st-arg ( function -- ) f %alien-invoke ;
M: ppc %vm-invoke-3rd-arg ( function -- ) f %alien-invoke ;
M: ppc machine-registers
{
{ 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 -- )
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
gc-root-count 4 LI
"inline_gc" f %alien-invoke ;
@ -781,6 +778,12 @@ M: ppc %box-small-struct ( c-type -- )
4 3 4 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 -- )
#! Alien must be in EAX.
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 ;
! Registers for fastcall
M: x86.32 param-reg-1 EAX ;
M: x86.32 param-reg-2 EDX ;
M: x86.32 param-reg-3 ECX ;
: param-reg-1 ( -- reg ) EAX ;
: param-reg-2 ( -- reg ) EDX ;
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 ;
: push-vm-ptr ( -- )
temp-reg 0 MOV 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
0 PUSH rc-absolute-cell rt-vm rel-fixup ; ! push the vm ptr as an argument
M: x86.32 return-struct-in-registers? ( c-type -- ? )
c-type
@ -247,6 +237,18 @@ M:: x86.32 %unbox-large-struct ( n c-type -- )
"to_value_struct" f %alien-invoke
] 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 ( -- )
push-vm-ptr "unbox_alien" f %alien-invoke
temp-reg POP
@ -280,6 +282,7 @@ M: x86.32 %callback-value ( ctype -- )
! Unbox EAX
unbox-return ;
M: x86.32 %cleanup ( params -- )
#! a) If we just called an stdcall function in Windows, it
#! 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 ]
} 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-int-params? f ;

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

@ -36,9 +36,10 @@ M:: x86.64 %dispatch ( src temp -- )
[ align-code ]
bi ;
M: x86.64 param-reg-1 int-regs param-regs first ;
M: x86.64 param-reg-2 int-regs param-regs second ;
M: x86.64 param-reg-3 int-regs param-regs third ;
: param-reg-1 ( -- reg ) int-regs param-regs first ; inline
: param-reg-2 ( -- reg ) int-regs param-regs second ; inline
: 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 ;
@ -74,26 +75,13 @@ M: x86.64 %prepare-unbox ( -- )
param-reg-1 R14 [] MOV
R14 cell SUB ;
M: x86.64 %vm-invoke-1st-arg ( function -- )
param-reg-1 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 ;
: %mov-vm-ptr ( reg -- )
0 MOV rc-absolute-cell rt-vm rel-fixup ;
M:: x86.64 %unbox ( n rep func -- )
param-reg-2 %mov-vm-ptr
! Call the unboxer
func %vm-invoke-2nd-arg
func f %alien-invoke
! Store the return value on the C stack if this is an
! alien-invoke, otherwise leave it the return register if
! 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 ] }
} case ;
M: x86.64 %unbox-small-struct ( c-type -- )
! 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
! clobber it.
R11 RAX MOV
@ -126,8 +114,9 @@ M:: x86.64 %unbox-large-struct ( n c-type -- )
param-reg-2 n param@ LEA
! Load structure size into param-reg-3
param-reg-3 c-type heap-size MOV
param-reg-4 %mov-vm-ptr
! Copy the struct to the C stack
"to_value_struct" %vm-invoke-4th-arg ;
"to_value_struct" f %alien-invoke ;
: load-return-value ( rep -- )
[ [ 0 ] dip reg-class-of param-reg ]
@ -143,7 +132,8 @@ M:: x86.64 %box ( n rep func -- )
] [
rep load-return-value
] 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 -- )
[ 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-1 0 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 ;
: struct-return@ ( n -- operand )
@ -174,8 +165,9 @@ M: x86.64 %box-large-struct ( n c-type -- )
param-reg-2 swap heap-size MOV
! Compute destination address
param-reg-1 swap struct-return@ LEA
param-reg-3 %mov-vm-ptr
! 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 ( -- )
! Compute target address for value struct return
@ -190,9 +182,17 @@ M: x86.64 %alien-invoke
rc-absolute-cell rel-dlsym
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 ( -- )
"unbox_alien" %vm-invoke-1st-arg
param-reg-1 %mov-vm-ptr
"unbox_alien" f %alien-invoke
RBP RAX MOV ;
M: x86.64 %alien-indirect ( -- )
@ -200,7 +200,8 @@ M: x86.64 %alien-indirect ( -- )
M: x86.64 %alien-callback ( quot -- )
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 -- )
! Save top of data stack
@ -208,8 +209,9 @@ M: x86.64 %callback-value ( ctype -- )
! Save top of data stack
RSP 8 SUB
param-reg-1 PUSH
param-reg-1 %mov-vm-ptr
! 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
param-reg-1 POP
RSP 8 ADD
@ -233,6 +235,16 @@ M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
func f %alien-invoke
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
! x86-64.
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
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 )
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 %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 -- )
[ 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
] with { } map>assoc ;
: specialize-quot ( quot word specializer -- quot' )
[ drop nip def>> ] [ nip specializer-cases ] 3bi alist>quot ;
: specialize-quot ( quot specializer -- quot' )
[ drop ] [ specializer-cases ] 2bi alist>quot ;
! compiler.tree.propagation.inlining sets this to f
SYMBOL: specialize-method?
@ -52,8 +52,8 @@ t specialize-method? set-global
: specialize-method ( quot method -- quot' )
[ specialize-method? get [ method-declaration prepend ] [ drop ] if ]
[ dup "method-generic" word-prop specializer ] bi
[ specialize-quot ] [ drop ] if* ;
[ "method-generic" word-prop ] bi
specializer [ specialize-quot ] when* ;
: standard-method? ( method -- ? )
dup method-body? [
@ -64,7 +64,7 @@ t specialize-method? set-global
[ def>> ] keep
dup generic? [ drop ] [
[ dup standard-method? [ specialize-method ] [ drop ] if ]
[ dup specializer [ specialize-quot ] [ drop ] if* ]
[ specializer [ specialize-quot ] when* ]
bi
] 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 -- )
'[
@
[ "print-mr" get [ nip test-mr mr. ] [ 2drop ] if ]
[ [ call ] dip call ]
[ [ call ] dip compile-call ] 2tri @ not
{
[ "print-mr" get [ nip test-mr mr. ] [ 2drop ] if ]
[ "print-checks" get [ [ . ] bi@ ] [ 2drop ] if ]
[ [ call ] dip call ]
[ [ call ] dip compile-call ]
} 2cleave
@ not
] filter ; inline
"== Checking -new constructors" print

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

@ -1,5 +1,7 @@
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 } ] [ { 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
[ 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 ;
: vbitxor ( u v -- w ) over '[ _ [ bitxor ] fp-bitwise-op ] 2map ;
: vlshift ( u n -- w ) '[ _ shift ] map ;
: vrshift ( u n -- w ) neg '[ _ shift ] map ;
: vlshift ( u n -- w ) HEX: ffffffff bitand '[ _ shift ] map ;
: vrshift ( u n -- w ) HEX: ffffffff bitand neg '[ _ shift ] map ;
: vfloor ( u -- v ) [ floor ] 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
] map harvest
] unit-test
[ "hi" word-xt ] must-fail

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

@ -135,10 +135,10 @@ CONSTANT: cpus
: requirements ( builder -- xml )
[
os>> {
{ "winnt" "Windows XP (also tested on Vista)" }
{ "winnt" "Windows XP, Windows Vista or Windows 7" }
{ "macosx" "Mac OS X 10.5 Leopard" }
{ "linux" "Ubuntu Linux 9.04 (other distributions may also work)" }
{ "freebsd" "FreeBSD 7.0" }
{ "freebsd" "FreeBSD 7.1" }
{ "netbsd" "NetBSD 5.0" }
{ "openbsd" "OpenBSD 4.4" }
} at
@ -146,7 +146,7 @@ CONSTANT: cpus
dup cpu>> "x86.32" = [
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 {"openbsd" } member? ] [ drop "Intel Pentium Pro or better" ] }
{ [ dup { "openbsd" } member? ] [ drop "Intel Pentium Pro or better" ] }
{ [ t ] [ drop f ] }
} cond
] [ drop f ] if

35
vm/alien.cpp
View File

@ -69,10 +69,7 @@ inline void factor_vm::primitive_displaced_alien()
}
}
PRIMITIVE(displaced_alien)
{
PRIMITIVE_GETVM()->primitive_displaced_alien();
}
PRIMITIVE_FORWARD(displaced_alien)
/* address of an object representing a C pointer. Explicitly throw an error
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()));
}
PRIMITIVE(alien_address)
{
PRIMITIVE_GETVM()->primitive_alien_address();
}
PRIMITIVE_FORWARD(alien_address)
/* pop ( alien n ) from datastack, return alien's address plus n */
void *factor_vm::alien_pointer()
@ -131,10 +125,7 @@ inline void factor_vm::primitive_dlopen()
dpush(library.value());
}
PRIMITIVE(dlopen)
{
PRIMITIVE_GETVM()->primitive_dlopen();
}
PRIMITIVE_FORWARD(dlopen)
/* look up a symbol in a native library */
inline void factor_vm::primitive_dlsym()
@ -158,10 +149,7 @@ inline void factor_vm::primitive_dlsym()
}
}
PRIMITIVE(dlsym)
{
PRIMITIVE_GETVM()->primitive_dlsym();
}
PRIMITIVE_FORWARD(dlsym)
/* close a native library handle */
inline void factor_vm::primitive_dlclose()
@ -171,10 +159,7 @@ inline void factor_vm::primitive_dlclose()
ffi_dlclose(d);
}
PRIMITIVE(dlclose)
{
PRIMITIVE_GETVM()->primitive_dlclose();
}
PRIMITIVE_FORWARD(dlclose)
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);
}
PRIMITIVE(dll_validp)
{
PRIMITIVE_GETVM()->primitive_dll_validp();
}
PRIMITIVE_FORWARD(dll_validp)
/* gets the address of an object representing a C pointer */
char *factor_vm::alien_offset(cell obj)
@ -308,9 +290,6 @@ inline void factor_vm::primitive_vm_ptr()
box_alien(this);
}
PRIMITIVE(vm_ptr)
{
PRIMITIVE_GETVM()->primitive_vm_ptr();
}
PRIMITIVE_FORWARD(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)));
}
PRIMITIVE(array)
{
PRIMITIVE_GETVM()->primitive_array();
}
PRIMITIVE_FORWARD(array)
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)));
}
PRIMITIVE(resize_array)
{
PRIMITIVE_GETVM()->primitive_resize_array();
}
PRIMITIVE_FORWARD(resize_array)
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)));
}
PRIMITIVE(byte_array)
{
PRIMITIVE_GETVM()->primitive_byte_array();
}
PRIMITIVE_FORWARD(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)));
}
PRIMITIVE(uninitialized_byte_array)
{
PRIMITIVE_GETVM()->primitive_uninitialized_byte_array();
}
PRIMITIVE_FORWARD(uninitialized_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)));
}
PRIMITIVE(resize_byte_array)
{
PRIMITIVE_GETVM()->primitive_resize_byte_array();
}
PRIMITIVE_FORWARD(resize_byte_array)
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));
}
PRIMITIVE(callstack)
{
PRIMITIVE_GETVM()->primitive_callstack();
}
PRIMITIVE_FORWARD(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);
}
PRIMITIVE(set_callstack)
{
PRIMITIVE_GETVM()->primitive_set_callstack();
}
PRIMITIVE_FORWARD(set_callstack)
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());
}
PRIMITIVE(callstack_to_array)
{
PRIMITIVE_GETVM()->primitive_callstack_to_array();
}
PRIMITIVE_FORWARD(callstack_to_array)
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()))));
}
PRIMITIVE(innermost_stack_frame_executing)
{
PRIMITIVE_GETVM()->primitive_innermost_stack_frame_executing();
}
PRIMITIVE_FORWARD(innermost_stack_frame_executing)
inline void factor_vm::primitive_innermost_stack_frame_scan()
{
dpush(frame_scan(innermost_stack_frame_quot(untag_check<callstack>(dpop()))));
}
PRIMITIVE(innermost_stack_frame_scan)
{
PRIMITIVE_GETVM()->primitive_innermost_stack_frame_scan();
}
PRIMITIVE_FORWARD(innermost_stack_frame_scan)
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;
}
PRIMITIVE(set_innermost_stack_frame_quot)
{
PRIMITIVE_GETVM()->primitive_set_innermost_stack_frame_quot();
}
PRIMITIVE_FORWARD(set_innermost_stack_frame_quot)
/* called before entry into Factor code. */
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(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);
}
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 */
@ -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
GC, we add them to the free list immediately. */
else if(compiled->type == PIC_TYPE)
heap_free(&code,compiled);
code->heap_free(compiled);
else
{
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);
mark_block(compiled);
code->mark_block(compiled);
copy_handle(&compiled->literals);
copy_handle(&compiled->relocation);
@ -503,19 +503,19 @@ void factor_vm::fixup_labels(array *labels, code_block *compiled)
/* Might GC */
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(block == NULL)
{
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 */
if(block == NULL)
{
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("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 */
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)
{
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 */
@ -31,13 +31,13 @@ void factor_vm::jit_compile_word(cell word_, cell def_, bool relocate)
/* Apply a function to every code block */
void factor_vm::iterate_code_heap(code_heap_iterator iter)
{
heap_block *scan = first_block(&code);
heap_block *scan = code->first_block();
while(scan)
{
if(scan->status != B_FREE)
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();
}
PRIMITIVE(modify_code_heap)
{
PRIMITIVE_GETVM()->primitive_modify_code_heap();
}
PRIMITIVE_FORWARD(modify_code_heap)
/* Push the free space and total size of the code heap */
inline void factor_vm::primitive_code_room()
{
cell used, total_free, max_free;
heap_usage(&code,&used,&total_free,&max_free);
dpush(tag_fixnum(code.seg->size / 1024));
code->heap_usage(&used,&total_free,&max_free);
dpush(tag_fixnum(code->seg->size / 1024));
dpush(tag_fixnum(used / 1024));
dpush(tag_fixnum(total_free / 1024));
dpush(tag_fixnum(max_free / 1024));
}
PRIMITIVE(code_room)
{
PRIMITIVE_GETVM()->primitive_code_room();
}
PRIMITIVE_FORWARD(code_room)
code_block *factor_vm::forward_xt(code_block *compiled)
{
@ -226,20 +220,20 @@ void factor_vm::compact_code_heap()
gc();
/* 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 */
forward_object_xts();
/* Actually perform the compaction */
compact_heap(&code,forwarding);
code->compact_heap(forwarding);
/* Update word and quotation XTs */
fixup_object_xts();
/* Now update the free list; there will be a single free block at
the end */
build_free_list(&code,size);
code->build_free_list(size);
}
}

3
vm/code_heap.hpp
View File

@ -1,7 +1,8 @@
namespace factor
{
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(code_room);

31
vm/contexts.cpp
View File

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

1
vm/cpu-ppc.hpp
View File

@ -3,7 +3,6 @@ namespace factor
#define FACTOR_CPU_STRING "ppc"
#define VM_ASM_API VM_C_API
#define VM_ASM_API_OVERFLOW VM_C_API
register cell ds asm("r13");
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
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 */
sub $2,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 rs asm("edi");
#define VM_ASM_API VM_C_API __attribute__ ((regparm (2)))
#define VM_ASM_API_OVERFLOW VM_C_API __attribute__ ((regparm (3)))
#define VM_ASM_API 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");
#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 */
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 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)
{
dealloc_data_heap(old_data_heap);
delete old_data_heap;
old_data_heap = NULL;
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;
/* see the comment in unmark_marked() */
unmark_marked(&code);
code->unmark_marked();
}
/* we try collecting aging space twice before going on to
collect tenured */
@ -546,7 +546,7 @@ void factor_vm::garbage_collection(cell gen,bool growing_data_heap_,cell request
code_heap_scans++;
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
copy_code_heap_roots();
@ -573,10 +573,7 @@ inline void factor_vm::primitive_gc()
gc();
}
PRIMITIVE(gc)
{
PRIMITIVE_GETVM()->primitive_gc();
}
PRIMITIVE_FORWARD(gc)
inline void factor_vm::primitive_gc_stats()
{
@ -608,10 +605,7 @@ inline void factor_vm::primitive_gc_stats()
dpush(result.elements.value());
}
PRIMITIVE(gc_stats)
{
PRIMITIVE_GETVM()->primitive_gc_stats();
}
PRIMITIVE_FORWARD(gc_stats)
void factor_vm::clear_gc_stats()
{
@ -629,10 +623,7 @@ inline void factor_vm::primitive_clear_gc_stats()
clear_gc_stats();
}
PRIMITIVE(clear_gc_stats)
{
PRIMITIVE_GETVM()->primitive_clear_gc_stats();
}
PRIMITIVE_FORWARD(clear_gc_stats)
/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this
to coalesce equal but distinct quotations and wrappers. */
@ -665,10 +656,7 @@ inline void factor_vm::primitive_become()
compile_all_words();
}
PRIMITIVE(become)
{
PRIMITIVE_GETVM()->primitive_become();
}
PRIMITIVE_FORWARD(become)
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();
}
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();
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(become);
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
{
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()
{
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);
}
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);
aging_size = align(aging_size,deck_size);
tenured_size = align(tenured_size,deck_size);
young_size_ = align(young_size_,deck_size);
aging_size_ = align(aging_size_,deck_size);
tenured_size_ = align(tenured_size_,deck_size);
data_heap *data = (data_heap *)safe_malloc(sizeof(data_heap));
data->young_size = young_size;
data->aging_size = aging_size;
data->tenured_size = tenured_size;
data->gen_count = gens;
young_size = young_size_;
aging_size = aging_size_;
tenured_size = tenured_size_;
gen_count = gen_count_;
cell total_size;
if(data->gen_count == 2)
if(gen_count == 2)
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;
else
{
fatal_error("Invalid number of generations",data->gen_count);
return NULL; /* can't happen */
total_size = 0;
fatal_error("Invalid number of generations",gen_count);
}
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);
data->semispaces = (zone *)safe_malloc(sizeof(zone) * data->gen_count);
generations = new zone[gen_count];
semispaces = new zone[gen_count];
cell cards_size = total_size >> card_bits;
data->allot_markers = (cell *)safe_malloc(cards_size);
data->allot_markers_end = data->allot_markers + cards_size;
allot_markers = new char[cards_size];
allot_markers_end = allot_markers + cards_size;
data->cards = (cell *)safe_malloc(cards_size);
data->cards_end = data->cards + cards_size;
cards = new char[cards_size];
cards_end = cards + cards_size;
cell decks_size = total_size >> deck_bits;
data->decks = (cell *)safe_malloc(decks_size);
data->decks_end = data->decks + decks_size;
decks = new char[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 = init_zone(&data->semispaces[data->tenured()],tenured_size,alloter);
alloter = generations[tenured()].init_zone(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 = init_zone(&data->semispaces[data->aging()],aging_size,alloter);
alloter = generations[aging()].init_zone(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 = init_zone(&data->semispaces[data->nursery()],0,alloter);
alloter = generations[nursery()].init_zone(young_size,alloter);
alloter = semispaces[nursery()].init_zone(0,alloter);
}
if(data->seg->end - alloter > deck_size)
critical_error("Bug in alloc_data_heap",alloter);
return data;
if(seg->end - alloter > deck_size)
myvm->critical_error("Bug in alloc_data_heap",alloter);
}
data_heap *factor_vm::grow_data_heap(data_heap *data, cell 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->aging_size,
new_tenured_size);
}
void factor_vm::dealloc_data_heap(data_heap *data)
data_heap::~data_heap()
{
dealloc_segment(data->seg);
free(data->generations);
free(data->semispaces);
free(data->allot_markers);
free(data->cards);
free(data->decks);
free(data);
delete seg;
delete[] generations;
delete[] semispaces;
delete[] allot_markers;
delete[] cards;
delete[] decks;
}
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_)
{
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_;
init_data_gc();
}
@ -222,10 +211,7 @@ inline void factor_vm::primitive_size()
box_unsigned_cell(object_size(dpop()));
}
PRIMITIVE(size)
{
PRIMITIVE_GETVM()->primitive_size();
}
PRIMITIVE_FORWARD(size)
/* 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
@ -284,10 +270,7 @@ inline void factor_vm::primitive_data_room()
dpush(a.elements.value());
}
PRIMITIVE(data_room)
{
PRIMITIVE_GETVM()->primitive_data_room();
}
PRIMITIVE_FORWARD(data_room)
/* Disables GC and activates next-object ( -- obj ) primitive */
void factor_vm::begin_scan()
@ -306,10 +289,7 @@ inline void factor_vm::primitive_begin_scan()
begin_scan();
}
PRIMITIVE(begin_scan)
{
PRIMITIVE_GETVM()->primitive_begin_scan();
}
PRIMITIVE_FORWARD(begin_scan)
cell factor_vm::next_object()
{
@ -330,10 +310,7 @@ inline void factor_vm::primitive_next_object()
dpush(next_object());
}
PRIMITIVE(next_object)
{
PRIMITIVE_GETVM()->primitive_next_object();
}
PRIMITIVE_FORWARD(next_object)
/* Re-enables GC */
inline void factor_vm::primitive_end_scan()
@ -341,10 +318,7 @@ inline void factor_vm::primitive_end_scan()
gc_off = false;
}
PRIMITIVE(end_scan)
{
PRIMITIVE_GETVM()->primitive_end_scan();
}
PRIMITIVE_FORWARD(end_scan)
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 size;
cell end;
cell init_zone(cell size_, cell start_)
{
size = size_;
start = here = start_;
end = start_ + size_;
return end;
}
};
struct data_heap {
@ -23,14 +31,14 @@ struct data_heap {
zone *generations;
zone *semispaces;
cell *allot_markers;
cell *allot_markers_end;
char *allot_markers;
char *allot_markers_end;
cell *cards;
cell *cards_end;
char *cards;
char *cards_end;
cell *decks;
cell *decks_end;
char *decks;
char *decks_end;
/* the 0th generation is where new objects are allocated. */
cell nursery() { return 0; }
@ -42,6 +50,9 @@ struct data_heap {
cell tenured() { return gen_count - 1; }
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;
@ -51,11 +62,6 @@ inline static bool in_zone(zone *z, object *pointer)
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(size);

9
vm/debug.cpp
View File

@ -297,7 +297,7 @@ void factor_vm::dump_code_heap()
{
cell reloc_size = 0, literal_size = 0;
heap_block *scan = first_block(&code);
heap_block *scan = code->first_block();
while(scan)
{
@ -326,7 +326,7 @@ void factor_vm::dump_code_heap()
print_cell_hex(scan->size); print_string(" ");
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");
@ -484,9 +484,6 @@ inline void factor_vm::primitive_die()
factorbug();
}
PRIMITIVE(die)
{
PRIMITIVE_GETVM()->primitive_die();
}
PRIMITIVE_FORWARD(die)
}

20
vm/dispatch.cpp
View File

@ -120,10 +120,7 @@ inline void factor_vm::primitive_lookup_method()
dpush(lookup_method(obj,methods));
}
PRIMITIVE(lookup_method)
{
PRIMITIVE_GETVM()->primitive_lookup_method();
}
PRIMITIVE_FORWARD(lookup_method)
cell factor_vm::object_class(cell obj)
{
@ -169,20 +166,14 @@ inline void factor_vm::primitive_mega_cache_miss()
dpush(method);
}
PRIMITIVE(mega_cache_miss)
{
PRIMITIVE_GETVM()->primitive_mega_cache_miss();
}
PRIMITIVE_FORWARD(mega_cache_miss)
inline void factor_vm::primitive_reset_dispatch_stats()
{
megamorphic_cache_hits = megamorphic_cache_misses = 0;
}
PRIMITIVE(reset_dispatch_stats)
{
PRIMITIVE_GETVM()->primitive_reset_dispatch_stats();
}
PRIMITIVE_FORWARD(reset_dispatch_stats)
inline void factor_vm::primitive_dispatch_stats()
{
@ -193,10 +184,7 @@ inline void factor_vm::primitive_dispatch_stats()
dpush(stats.elements.value());
}
PRIMITIVE(dispatch_stats)
{
PRIMITIVE_GETVM()->primitive_dispatch_stats();
}
PRIMITIVE_FORWARD(dispatch_stats)
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);
}
PRIMITIVE(call_clear)
{
PRIMITIVE_GETVM()->primitive_call_clear();
}
PRIMITIVE_FORWARD(call_clear)
/* For testing purposes */
inline void factor_vm::primitive_unimplemented()
@ -144,10 +141,7 @@ inline void factor_vm::primitive_unimplemented()
not_implemented_error();
}
PRIMITIVE(unimplemented)
{
PRIMITIVE_GETVM()->primitive_unimplemented();
}
PRIMITIVE_FORWARD(unimplemented)
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"
/* 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
{
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
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::heap(factor_vm *myvm_, cell size)
{
heap->seg = alloc_segment(align_page(size));
if(!heap->seg)
fatal_error("Out of memory in new_heap",size);
clear_free_list(heap);
myvm = myvm_;
seg = new segment(myvm,align_page(size));
if(!seg) fatal_error("Out of memory in new_heap",size);
clear_free_list();
}
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)
{
int index = block->size / block_size_increment;
block->next_free = heap->free.small_blocks[index];
heap->free.small_blocks[index] = block;
block->next_free = free.small_blocks[index];
free.small_blocks[index] = block;
}
else
{
block->next_free = heap->free.large_blocks;
heap->free.large_blocks = block;
block->next_free = free.large_blocks;
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
compiling.limit. */
void factor_vm::build_free_list(heap *heap, cell size)
void heap::build_free_list(cell size)
{
heap_block *prev = NULL;
clear_free_list(heap);
clear_free_list();
size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
heap_block *scan = first_block(heap);
free_heap_block *end = (free_heap_block *)(heap->seg->start + size);
heap_block *scan = first_block();
free_heap_block *end = (free_heap_block *)(seg->start + size);
/* Add all free blocks to the free list */
while(scan && scan < (heap_block *)end)
@ -56,28 +55,28 @@ void factor_vm::build_free_list(heap *heap, cell size)
switch(scan->status)
{
case B_FREE:
add_to_free_list(heap,(free_heap_block *)scan);
add_to_free_list((free_heap_block *)scan);
break;
case B_ALLOCATED:
break;
default:
critical_error("Invalid scan->status",(cell)scan);
myvm->critical_error("Invalid scan->status",(cell)scan);
break;
}
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
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->size = heap->seg->end - (cell)end;
end->size = seg->end - (cell)end;
/* 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
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
free block, we might have to jigger it up by a few bytes in
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)
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;
while(attempt < free_list_count * 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)
{
assert_free_block(block);
heap->free.small_blocks[index] = block->next_free;
free.small_blocks[index] = block->next_free;
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 *block = heap->free.large_blocks;
free_heap_block *block = free.large_blocks;
while(block)
{
@ -127,7 +126,7 @@ free_heap_block *factor_vm::find_free_block(heap *heap, cell size)
if(prev)
prev->next_free = block->next_free;
else
heap->free.large_blocks = block->next_free;
free.large_blocks = block->next_free;
return block;
}
@ -138,7 +137,7 @@ free_heap_block *factor_vm::find_free_block(heap *heap, cell size)
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 )
{
@ -148,21 +147,21 @@ free_heap_block *factor_vm::split_free_block(heap *heap, free_heap_block *block,
split->size = block->size - size;
split->next_free = block->next_free;
block->size = size;
add_to_free_list(heap,split);
add_to_free_list(split);
}
return block;
}
/* 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);
free_heap_block *block = find_free_block(heap,size);
free_heap_block *block = find_free_block(size);
if(block)
{
block = split_free_block(heap,block,size);
block = split_free_block(block,size);
block->status = B_ALLOCATED;
return block;
@ -172,13 +171,13 @@ heap_block *factor_vm::heap_allot(heap *heap, cell size)
}
/* 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;
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 */
switch(block->status)
@ -189,41 +188,41 @@ void factor_vm::mark_block(heap_block *block)
block->status = B_MARKED;
break;
default:
critical_error("Marking the wrong block",(cell)block);
myvm->critical_error("Marking the wrong block",(cell)block);
break;
}
}
/* If in the middle of code GC, we have to grow the heap, data GC restarts from
scratch, so we have to unmark any marked blocks. */
void factor_vm::unmark_marked(heap *heap)
void heap::unmark_marked()
{
heap_block *scan = first_block(heap);
heap_block *scan = first_block();
while(scan)
{
if(scan->status == B_MARKED)
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
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 *scan = first_block(heap);
heap_block *scan = first_block();
while(scan)
{
switch(scan->status)
{
case B_ALLOCATED:
if(secure_gc)
if(myvm->secure_gc)
memset(scan + 1,0,scan->size - sizeof(heap_block));
if(prev && prev->status == B_FREE)
@ -242,30 +241,30 @@ void factor_vm::free_unmarked(heap *heap, heap_iterator iter)
break;
case B_MARKED:
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;
prev = scan;
iter(scan,this);
iter(scan,myvm);
break;
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)
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 */
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;
*total_free = 0;
*max_free = 0;
heap_block *scan = first_block(heap);
heap_block *scan = first_block();
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;
break;
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 */
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)
scan = next_block(heap,scan);
while(next_block(scan) != NULL)
scan = next_block(scan);
/* this is the last block in the heap, and it is free */
if(scan->status == B_FREE)
return (cell)scan - heap->seg->start;
return (cell)scan - seg->start;
/* otherwise the last block is allocated */
else
return heap->seg->size;
return seg->size;
}
/* 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);
char *address = (char *)first_block(heap);
heap_block *scan = first_block();
char *address = (char *)first_block();
while(scan)
{
@ -317,21 +316,21 @@ cell factor_vm::compute_heap_forwarding(heap *heap, unordered_map<heap_block *,c
address += scan->size;
}
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)
{
heap_block *next = next_block(heap,scan);
heap_block *next = next_block(scan);
if(scan->status == B_ALLOCATED)
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)
{
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)
{
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;
build_free_list(&code,h->code_size);
code->build_free_list(h->code_size);
}
/* Save the current image to disk */
@ -92,8 +92,8 @@ bool factor_vm::save_image(const vm_char *filename)
h.version = image_version;
h.data_relocation_base = tenured->start;
h.data_size = tenured->here - tenured->start;
h.code_relocation_base = code.seg->start;
h.code_size = heap_size(&code);
h.code_relocation_base = code->seg->start;
h.code_size = code->heap_size();
h.t = T;
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((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(!ok)
@ -128,10 +128,7 @@ inline void factor_vm::primitive_save_image()
save_image((vm_char *)(path.untagged() + 1));
}
PRIMITIVE(save_image)
{
PRIMITIVE_GETVM()->primitive_save_image();
}
PRIMITIVE_FORWARD(save_image)
inline void factor_vm::primitive_save_image_and_exit()
{
@ -159,10 +156,7 @@ inline void factor_vm::primitive_save_image_and_exit()
exit(1);
}
PRIMITIVE(save_image_and_exit)
{
PRIMITIVE_GETVM()->primitive_save_image_and_exit();
}
PRIMITIVE_FORWARD(save_image_and_exit)
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)
{
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;
}

12
vm/inline_cache.cpp
View File

@ -24,7 +24,7 @@ void factor_vm::deallocate_inline_cache(cell return_address)
#endif
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
@ -257,10 +257,7 @@ inline void factor_vm::primitive_reset_inline_cache_stats()
for(i = 0; i < 4; i++) pic_counts[i] = 0;
}
PRIMITIVE(reset_inline_cache_stats)
{
PRIMITIVE_GETVM()->primitive_reset_inline_cache_stats();
}
PRIMITIVE_FORWARD(reset_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());
}
PRIMITIVE(inline_cache_stats)
{
PRIMITIVE_GETVM()->primitive_inline_cache_stats();
}
PRIMITIVE_FORWARD(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
// 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
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_GETVM()->primitive_fopen();
}
PRIMITIVE_FORWARD(fopen)
inline void factor_vm::primitive_fgetc()
{
@ -82,10 +79,7 @@ inline void factor_vm::primitive_fgetc()
}
}
PRIMITIVE(fgetc)
{
PRIMITIVE_GETVM()->primitive_fgetc();
}
PRIMITIVE_FORWARD(fgetc)
inline void factor_vm::primitive_fread()
{
@ -127,10 +121,7 @@ inline void factor_vm::primitive_fread()
}
}
PRIMITIVE(fread)
{
PRIMITIVE_GETVM()->primitive_fread();
}
PRIMITIVE_FORWARD(fread)
inline void factor_vm::primitive_fputc()
{
@ -150,10 +141,7 @@ inline void factor_vm::primitive_fputc()
}
}
PRIMITIVE(fputc)
{
PRIMITIVE_GETVM()->primitive_fputc();
}
PRIMITIVE_FORWARD(fputc)
inline void factor_vm::primitive_fwrite()
{
@ -184,10 +172,7 @@ inline void factor_vm::primitive_fwrite()
}
}
PRIMITIVE(fwrite)
{
PRIMITIVE_GETVM()->primitive_fwrite();
}
PRIMITIVE_FORWARD(fwrite)
inline void factor_vm::primitive_fseek()
{
@ -214,10 +199,7 @@ inline void factor_vm::primitive_fseek()
}
}
PRIMITIVE(fseek)
{
PRIMITIVE_GETVM()->primitive_fseek();
}
PRIMITIVE_FORWARD(fseek)
inline void factor_vm::primitive_fflush()
{
@ -231,10 +213,7 @@ inline void factor_vm::primitive_fflush()
}
}
PRIMITIVE(fflush)
{
PRIMITIVE_GETVM()->primitive_fflush();
}
PRIMITIVE_FORWARD(fflush)
inline void factor_vm::primitive_fclose()
{
@ -248,10 +227,7 @@ inline void factor_vm::primitive_fclose()
}
}
PRIMITIVE(fclose)
{
PRIMITIVE_GETVM()->primitive_fclose();
}
PRIMITIVE_FORWARD(fclose)
/* 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

2
vm/master.hpp
View File

@ -64,7 +64,7 @@
#include "math.hpp"
#include "float_bits.hpp"
#include "io.hpp"
#include "code_gc.hpp"
#include "heap.hpp"
#include "code_heap.hpp"
#include "image.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()))));
}
PRIMITIVE(bignum_to_fixnum)
{
PRIMITIVE_GETVM()->primitive_bignum_to_fixnum();
}
PRIMITIVE_FORWARD(bignum_to_fixnum)
inline void factor_vm::primitive_float_to_fixnum()
{
drepl(tag_fixnum(float_to_fixnum(dpeek())));
}
PRIMITIVE(float_to_fixnum)
{
PRIMITIVE_GETVM()->primitive_float_to_fixnum();
}
PRIMITIVE_FORWARD(float_to_fixnum)
/* Division can only overflow when we are dividing the most negative fixnum
by -1. */
@ -36,10 +30,7 @@ inline void factor_vm::primitive_fixnum_divint()
drepl(tag_fixnum(result));
}
PRIMITIVE(fixnum_divint)
{
PRIMITIVE_GETVM()->primitive_fixnum_divint();
}
PRIMITIVE_FORWARD(fixnum_divint)
inline void factor_vm::primitive_fixnum_divmod()
{
@ -57,10 +48,7 @@ inline void factor_vm::primitive_fixnum_divmod()
}
}
PRIMITIVE(fixnum_divmod)
{
PRIMITIVE_GETVM()->primitive_fixnum_divmod();
}
PRIMITIVE_FORWARD(fixnum_divmod)
/*
* 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)));
}
PRIMITIVE(fixnum_shift)
{
PRIMITIVE_GETVM()->primitive_fixnum_shift();
}
PRIMITIVE_FORWARD(fixnum_shift)
inline void factor_vm::primitive_fixnum_to_bignum()
{
drepl(tag<bignum>(fixnum_to_bignum(untag_fixnum(dpeek()))));
}
PRIMITIVE(fixnum_to_bignum)
{
PRIMITIVE_GETVM()->primitive_fixnum_to_bignum();
}
PRIMITIVE_FORWARD(fixnum_to_bignum)
inline void factor_vm::primitive_float_to_bignum()
{
drepl(tag<bignum>(float_to_bignum(dpeek())));
}
PRIMITIVE(float_to_bignum)
{
PRIMITIVE_GETVM()->primitive_float_to_bignum();
}
PRIMITIVE_FORWARD(float_to_bignum)
#define POP_BIGNUMS(x,y) \
bignum * y = untag<bignum>(dpop()); \
@ -143,10 +122,7 @@ inline void factor_vm::primitive_bignum_eq()
box_boolean(bignum_equal_p(x,y));
}
PRIMITIVE(bignum_eq)
{
PRIMITIVE_GETVM()->primitive_bignum_eq();
}
PRIMITIVE_FORWARD(bignum_eq)
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)));
}
PRIMITIVE(bignum_add)
{
PRIMITIVE_GETVM()->primitive_bignum_add();
}
PRIMITIVE_FORWARD(bignum_add)
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)));
}
PRIMITIVE(bignum_subtract)
{
PRIMITIVE_GETVM()->primitive_bignum_subtract();
}
PRIMITIVE_FORWARD(bignum_subtract)
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)));
}
PRIMITIVE(bignum_multiply)
{
PRIMITIVE_GETVM()->primitive_bignum_multiply();
}
PRIMITIVE_FORWARD(bignum_multiply)
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)));
}
PRIMITIVE(bignum_divint)
{
PRIMITIVE_GETVM()->primitive_bignum_divint();
}
PRIMITIVE_FORWARD(bignum_divint)
inline void factor_vm::primitive_bignum_divmod()
{
@ -201,10 +165,7 @@ inline void factor_vm::primitive_bignum_divmod()
dpush(tag<bignum>(r));
}
PRIMITIVE(bignum_divmod)
{
PRIMITIVE_GETVM()->primitive_bignum_divmod();
}
PRIMITIVE_FORWARD(bignum_divmod)
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)));
}
PRIMITIVE(bignum_mod)
{
PRIMITIVE_GETVM()->primitive_bignum_mod();
}
PRIMITIVE_FORWARD(bignum_mod)
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)));
}
PRIMITIVE(bignum_and)
{
PRIMITIVE_GETVM()->primitive_bignum_and();
}
PRIMITIVE_FORWARD(bignum_and)
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)));
}
PRIMITIVE(bignum_or)
{
PRIMITIVE_GETVM()->primitive_bignum_or();
}
PRIMITIVE_FORWARD(bignum_or)
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)));
}
PRIMITIVE(bignum_xor)
{
PRIMITIVE_GETVM()->primitive_bignum_xor();
}
PRIMITIVE_FORWARD(bignum_xor)
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)));
}
PRIMITIVE(bignum_shift)
{
PRIMITIVE_GETVM()->primitive_bignum_shift();
}
PRIMITIVE_FORWARD(bignum_shift)
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);
}
PRIMITIVE(bignum_less)
{
PRIMITIVE_GETVM()->primitive_bignum_less();
}
PRIMITIVE_FORWARD(bignum_less)
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);
}
PRIMITIVE(bignum_lesseq)
{
PRIMITIVE_GETVM()->primitive_bignum_lesseq();
}
PRIMITIVE_FORWARD(bignum_lesseq)
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);
}
PRIMITIVE(bignum_greater)
{
PRIMITIVE_GETVM()->primitive_bignum_greater();
}
PRIMITIVE_FORWARD(bignum_greater)
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);
}
PRIMITIVE(bignum_greatereq)
{
PRIMITIVE_GETVM()->primitive_bignum_greatereq();
}
PRIMITIVE_FORWARD(bignum_greatereq)
inline void factor_vm::primitive_bignum_not()
{
drepl(tag<bignum>(bignum_bitwise_not(untag<bignum>(dpeek()))));
}
PRIMITIVE(bignum_not)
{
PRIMITIVE_GETVM()->primitive_bignum_not();
}
PRIMITIVE_FORWARD(bignum_not)
inline void factor_vm::primitive_bignum_bitp()
{
@ -323,20 +254,14 @@ inline void factor_vm::primitive_bignum_bitp()
box_boolean(bignum_logbitp(bit,x));
}
PRIMITIVE(bignum_bitp)
{
PRIMITIVE_GETVM()->primitive_bignum_bitp();
}
PRIMITIVE_FORWARD(bignum_bitp)
inline void factor_vm::primitive_bignum_log2()
{
drepl(tag<bignum>(bignum_integer_length(untag<bignum>(dpeek()))));
}
PRIMITIVE(bignum_log2)
{
PRIMITIVE_GETVM()->primitive_bignum_log2();
}
PRIMITIVE_FORWARD(bignum_log2)
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));
}
PRIMITIVE(byte_array_to_bignum)
{
PRIMITIVE_GETVM()->primitive_byte_array_to_bignum();
}
PRIMITIVE_FORWARD(byte_array_to_bignum)
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())));
}
PRIMITIVE(fixnum_to_float)
{
PRIMITIVE_GETVM()->primitive_fixnum_to_float();
}
PRIMITIVE_FORWARD(fixnum_to_float)
inline void factor_vm::primitive_bignum_to_float()
{
drepl(allot_float(bignum_to_float(dpeek())));
}
PRIMITIVE(bignum_to_float)
{
PRIMITIVE_GETVM()->primitive_bignum_to_float();
}
PRIMITIVE_FORWARD(bignum_to_float)
inline void factor_vm::primitive_str_to_float()
{
@ -428,10 +344,7 @@ inline void factor_vm::primitive_str_to_float()
drepl(F);
}
PRIMITIVE(str_to_float)
{
PRIMITIVE_GETVM()->primitive_str_to_float();
}
PRIMITIVE_FORWARD(str_to_float)
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));
}
PRIMITIVE(float_to_str)
{
PRIMITIVE_GETVM()->primitive_float_to_str();
}
PRIMITIVE_FORWARD(float_to_str)
#define POP_FLOATS(x,y) \
double y = untag_float(dpop()); \
@ -455,10 +365,7 @@ inline void factor_vm::primitive_float_eq()
box_boolean(x == y);
}
PRIMITIVE(float_eq)
{
PRIMITIVE_GETVM()->primitive_float_eq();
}
PRIMITIVE_FORWARD(float_eq)
inline void factor_vm::primitive_float_add()
{
@ -466,10 +373,7 @@ inline void factor_vm::primitive_float_add()
box_double(x + y);
}
PRIMITIVE(float_add)
{
PRIMITIVE_GETVM()->primitive_float_add();
}
PRIMITIVE_FORWARD(float_add)
inline void factor_vm::primitive_float_subtract()
{
@ -477,10 +381,7 @@ inline void factor_vm::primitive_float_subtract()
box_double(x - y);
}
PRIMITIVE(float_subtract)
{
PRIMITIVE_GETVM()->primitive_float_subtract();
}
PRIMITIVE_FORWARD(float_subtract)
inline void factor_vm::primitive_float_multiply()
{
@ -488,10 +389,7 @@ inline void factor_vm::primitive_float_multiply()
box_double(x * y);
}
PRIMITIVE(float_multiply)
{
PRIMITIVE_GETVM()->primitive_float_multiply();
}
PRIMITIVE_FORWARD(float_multiply)
inline void factor_vm::primitive_float_divfloat()
{
@ -499,10 +397,7 @@ inline void factor_vm::primitive_float_divfloat()
box_double(x / y);
}
PRIMITIVE(float_divfloat)
{
PRIMITIVE_GETVM()->primitive_float_divfloat();
}
PRIMITIVE_FORWARD(float_divfloat)
inline void factor_vm::primitive_float_mod()
{
@ -510,10 +405,7 @@ inline void factor_vm::primitive_float_mod()
box_double(fmod(x,y));
}
PRIMITIVE(float_mod)
{
PRIMITIVE_GETVM()->primitive_float_mod();
}
PRIMITIVE_FORWARD(float_mod)
inline void factor_vm::primitive_float_less()
{
@ -521,10 +413,7 @@ inline void factor_vm::primitive_float_less()
box_boolean(x < y);
}
PRIMITIVE(float_less)
{
PRIMITIVE_GETVM()->primitive_float_less();
}
PRIMITIVE_FORWARD(float_less)
inline void factor_vm::primitive_float_lesseq()
{
@ -532,10 +421,7 @@ inline void factor_vm::primitive_float_lesseq()
box_boolean(x <= y);
}
PRIMITIVE(float_lesseq)
{
PRIMITIVE_GETVM()->primitive_float_lesseq();
}
PRIMITIVE_FORWARD(float_lesseq)
inline void factor_vm::primitive_float_greater()
{
@ -543,10 +429,7 @@ inline void factor_vm::primitive_float_greater()
box_boolean(x > y);
}
PRIMITIVE(float_greater)
{
PRIMITIVE_GETVM()->primitive_float_greater();
}
PRIMITIVE_FORWARD(float_greater)
inline void factor_vm::primitive_float_greatereq()
{
@ -554,50 +437,35 @@ inline void factor_vm::primitive_float_greatereq()
box_boolean(x >= y);
}
PRIMITIVE(float_greatereq)
{
PRIMITIVE_GETVM()->primitive_float_greatereq();
}
PRIMITIVE_FORWARD(float_greatereq)
inline void factor_vm::primitive_float_bits()
{
box_unsigned_4(float_bits(untag_float_check(dpop())));
}
PRIMITIVE(float_bits)
{
PRIMITIVE_GETVM()->primitive_float_bits();
}
PRIMITIVE_FORWARD(float_bits)
inline void factor_vm::primitive_bits_float()
{
box_float(bits_float(to_cell(dpop())));
}
PRIMITIVE(bits_float)
{
PRIMITIVE_GETVM()->primitive_bits_float();
}
PRIMITIVE_FORWARD(bits_float)
inline void factor_vm::primitive_double_bits()
{
box_unsigned_8(double_bits(untag_float_check(dpop())));
}
PRIMITIVE(double_bits)
{
PRIMITIVE_GETVM()->primitive_double_bits();
}
PRIMITIVE_FORWARD(double_bits)
inline void factor_vm::primitive_bits_double()
{
box_double(bits_double(to_unsigned_8(dpop())));
}
PRIMITIVE(bits_double)
{
PRIMITIVE_GETVM()->primitive_bits_double();
}
PRIMITIVE_FORWARD(bits_double)
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))));
}
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);
}
@ -849,7 +717,7 @@ inline void factor_vm::overflow_fixnum_subtract(fixnum x, 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);
}
@ -863,7 +731,7 @@ inline void factor_vm::overflow_fixnum_multiply(fixnum x, fixnum y)
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);
}

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 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_OVERFLOW 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_add(fixnum x, fixnum y, factor_vm *vm);
VM_ASM_API void overflow_fixnum_subtract(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_LEN 6
/* You must delete[] the result yourself. */
const char *default_image_path()
{
const char *path = vm_executable_path();
@ -31,7 +32,7 @@ const char *default_image_path()
const char *iter = path;
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 + len,SUFFIX,SUFFIX_LEN + 1);
return new_path;

4
vm/os-linux.cpp
View File

@ -3,10 +3,10 @@
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()
{
char *path = (char *)safe_malloc(PATH_MAX + 1);
char *path = new char[PATH_MAX + 1];
int size = readlink("/proc/self/exe", path, PATH_MAX);
if (size < 0)

37
vm/os-unix.cpp
View File

@ -21,9 +21,8 @@ pthread_key_t tlsKey = 0;
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);
}
}
@ -75,8 +74,6 @@ void factor_vm::ffi_dlclose(dll *dll)
dll->dll = NULL;
}
inline void factor_vm::primitive_existsp()
{
struct stat sb;
@ -84,13 +81,13 @@ inline void factor_vm::primitive_existsp()
box_boolean(stat(path,&sb) >= 0);
}
PRIMITIVE(existsp)
{
PRIMITIVE_GETVM()->primitive_existsp();
}
PRIMITIVE_FORWARD(existsp)
segment *factor_vm::alloc_segment(cell size)
segment::segment(factor_vm *myvm_, cell size_)
{
myvm = myvm_;
size = size_;
int pagesize = getpagesize();
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);
if(array == (char*)-1)
out_of_memory();
myvm->out_of_memory();
if(mprotect(array,pagesize,PROT_NONE) == -1)
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)
fatal_error("Cannot protect high guard page",(cell)array);
segment *retval = (segment *)safe_malloc(sizeof(segment));
retval->start = (cell)(array + pagesize);
retval->size = size;
retval->end = retval->start + size;
return retval;
start = (cell)(array + pagesize);
end = start + size;
}
void dealloc_segment(segment *block)
segment::~segment()
{
int pagesize = getpagesize();
int retval = munmap((void*)(block->start - pagesize),
pagesize + block->size + pagesize);
int retval = munmap((void*)(start - pagesize),pagesize + size + pagesize);
if(retval)
fatal_error("dealloc_segment failed",0);
free(block);
fatal_error("Segment deallocation failed",0);
}
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 */
}
PRIMITIVE(os_envs)
{
vm->not_implemented_error();
}
PRIMITIVE_FORWARD(os_envs)
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));
}
PRIMITIVE(existsp)
{
PRIMITIVE_GETVM()->primitive_existsp();
}
PRIMITIVE_FORWARD(existsp)
segment *factor_vm::alloc_segment(cell size)
segment::segment(factor_vm *myvm_, cell size_)
{
myvm = myvm_;
size = size_;
char *mem;
DWORD ignore;
if((mem = (char *)VirtualAlloc(NULL, getpagesize() * 2 + size,
MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == 0)
out_of_memory();
myvm->out_of_memory();
if (!VirtualProtect(mem, getpagesize(), PAGE_NOACCESS, &ignore))
fatal_error("Cannot allocate low guard page", (cell)mem);
@ -117,22 +117,16 @@ segment *factor_vm::alloc_segment(cell size)
getpagesize(), PAGE_NOACCESS, &ignore))
fatal_error("Cannot allocate high guard page", (cell)mem);
segment *block = (segment *)safe_malloc(sizeof(segment));
block->start = (cell)mem + getpagesize();
block->size = size;
block->end = block->start + size;
return block;
start = (cell)mem + getpagesize();
end = start + size;
}
void factor_vm::dealloc_segment(segment *block)
segment::~segment()
{
SYSTEM_INFO si;
GetSystemInfo(&si);
if(!VirtualFree((void*)(block->start - si.dwPageSize), 0, MEM_RELEASE))
fatal_error("dealloc_segment failed",0);
free(block);
if(!VirtualFree((void*)(start - si.dwPageSize), 0, MEM_RELEASE))
myvm->fatal_error("Segment deallocation failed",0);
}
long factor_vm::getpagesize()

9
vm/primitives.hpp
View File

@ -4,10 +4,17 @@ namespace factor
#if defined(FACTOR_X86)
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_FORWARD(name) extern "C" __attribute__ ((regparm (1))) void primitive_##name(void *myvm) \
{ \
PRIMITIVE_GETVM()->primitive_##name(); \
}
#else
extern "C" typedef void (*primitive_type)(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
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()));
}
PRIMITIVE(profiling)
{
PRIMITIVE_GETVM()->primitive_profiling();
}
PRIMITIVE_FORWARD(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)
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())
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(FIXNUM_TYPE)
&& array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_PRIMITIVE_WORD];
return (i + 2) == length && 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())
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
return (i + 3) == length
&& tagged<object>(array_nth(elements.untagged(),i + 1)).type_p(QUOTATION_TYPE)
&& 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())
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
&& array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_DIP_WORD];
return (i + 2) <= length && 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())
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
&& array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_2DIP_WORD];
return (i + 2) <= length && 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())
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
&& array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_3DIP_WORD];
return (i + 2) <= length && 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())
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(ARRAY_TYPE)
return (i + 4) <= length
&& tagged<object>(array_nth(elements.untagged(),i + 1)).type_p(FIXNUM_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];
}
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()
{
fixnum length = array_capacity(elements.untagged());
@ -96,7 +92,7 @@ bool quotation_jit::stack_frame_p()
return true;
break;
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;
break;
default:
@ -179,19 +175,21 @@ void quotation_jit::iterate_quotation()
break;
case FIXNUM_TYPE:
/* Primitive calls */
if(primitive_call_p(i))
if(primitive_call_p(i,length))
{
emit_with(parent_vm->userenv[JIT_PRIMITIVE],obj.value());
i++;
tail_call = true;
break;
}
else
push(obj.value());
break;
case QUOTATION_TYPE:
/* 'if' preceeded by two literal quotations (this is why if and ? are
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]);
tail_call = true;
@ -207,39 +205,37 @@ void quotation_jit::iterate_quotation()
emit(parent_vm->userenv[JIT_IF]);
i += 2;
break;
}
/* dip */
else if(fast_dip_p(i))
else if(fast_dip_p(i,length))
{
if(compiling)
parent_vm->jit_compile(obj.value(),relocate);
emit_with(parent_vm->userenv[JIT_DIP],obj.value());
i++;
break;
}
/* 2dip */
else if(fast_2dip_p(i))
else if(fast_2dip_p(i,length))
{
if(compiling)
parent_vm->jit_compile(obj.value(),relocate);
emit_with(parent_vm->userenv[JIT_2DIP],obj.value());
i++;
break;
}
/* 3dip */
else if(fast_3dip_p(i))
else if(fast_3dip_p(i,length))
{
if(compiling)
parent_vm->jit_compile(obj.value(),relocate);
emit_with(parent_vm->userenv[JIT_3DIP],obj.value());
i++;
break;
}
else
push(obj.value());
break;
case ARRAY_TYPE:
/* Method dispatch */
if(mega_lookup_p(i))
if(mega_lookup_p(i,length))
{
emit_mega_cache_lookup(
array_nth(elements.untagged(),i),
@ -247,8 +243,13 @@ void quotation_jit::iterate_quotation()
array_nth(elements.untagged(),i + 2));
i += 3;
tail_call = true;
break;
}
/* Non-optimizing compiler ignores declarations */
else if(declare_p(i,length))
i++;
else
push(obj.value());
break;
default:
push(obj.value());
break;
@ -294,10 +295,7 @@ inline void factor_vm::primitive_jit_compile()
jit_compile(dpop(),true);
}
PRIMITIVE(jit_compile)
{
PRIMITIVE_GETVM()->primitive_jit_compile();
}
PRIMITIVE_FORWARD(jit_compile)
/* push a new quotation on the stack */
inline void factor_vm::primitive_array_to_quotation()
@ -311,10 +309,7 @@ inline void factor_vm::primitive_array_to_quotation()
drepl(tag<quotation>(quot));
}
PRIMITIVE(array_to_quotation)
{
PRIMITIVE_GETVM()->primitive_array_to_quotation();
}
PRIMITIVE_FORWARD(array_to_quotation)
inline void factor_vm::primitive_quotation_xt()
{
@ -322,10 +317,7 @@ inline void factor_vm::primitive_quotation_xt()
drepl(allot_cell((cell)quot->xt));
}
PRIMITIVE(quotation_xt)
{
PRIMITIVE_GETVM()->primitive_quotation_xt();
}
PRIMITIVE_FORWARD(quotation_xt)
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();
}
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();
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));
}
PRIMITIVE(quot_compiled_p)
{
PRIMITIVE_GETVM()->primitive_quot_compiled_p();
}
PRIMITIVE_FORWARD(quot_compiled_p)
}

15
vm/quotations.hpp
View File

@ -12,12 +12,13 @@ struct quotation_jit : public jit {
relocate(relocate_){};
void emit_mega_cache_lookup(cell methods, fixnum index, cell cache);
bool primitive_call_p(cell i);
bool fast_if_p(cell i);
bool fast_dip_p(cell i);
bool fast_2dip_p(cell i);
bool fast_3dip_p(cell i);
bool mega_lookup_p(cell i);
bool primitive_call_p(cell i, cell length);
bool fast_if_p(cell i, cell length);
bool fast_dip_p(cell i, cell length);
bool fast_2dip_p(cell i, cell length);
bool fast_3dip_p(cell i, cell length);
bool mega_lookup_p(cell i, cell length);
bool declare_p(cell i, cell length);
bool stack_frame_p();
void iterate_quotation();
};
@ -27,7 +28,7 @@ PRIMITIVE(jit_compile);
PRIMITIVE(array_to_quotation);
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);

40
vm/run.cpp
View File

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

1
vm/run.hpp
View File

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

13
vm/segments.hpp
View File

@ -1,10 +1,23 @@
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 {
factor_vm *myvm;
cell start;
cell size;
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)));
}
PRIMITIVE(string)
{
PRIMITIVE_GETVM()->primitive_string();
}
PRIMITIVE_FORWARD(string)
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)));
}
PRIMITIVE(resize_string)
{
PRIMITIVE_GETVM()->primitive_resize_string();
}
PRIMITIVE_FORWARD(resize_string)
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)));
}
PRIMITIVE(string_nth)
{
PRIMITIVE_GETVM()->primitive_string_nth();
}
PRIMITIVE_FORWARD(string_nth)
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);
}
PRIMITIVE(set_string_nth_fast)
{
PRIMITIVE_GETVM()->primitive_set_string_nth_fast();
}
PRIMITIVE_FORWARD(set_string_nth_fast)
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);
}
PRIMITIVE(set_string_nth_slow)
{
PRIMITIVE_GETVM()->primitive_set_string_nth_slow();
}
PRIMITIVE_FORWARD(set_string_nth_slow)
}

10
vm/tuples.cpp
View File

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

7
vm/utilities.cpp
View File

@ -4,13 +4,6 @@ namespace factor
{
/* 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 *ptr = STRDUP(str);

1
vm/utilities.hpp
View File

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

4
vm/vm-data.hpp
View File

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

26
vm/vm.hpp
View File

@ -5,9 +5,6 @@ namespace factor
struct factor_vm : factor_vm_data {
// segments
inline cell align_page(cell a);
// contexts
void reset_datastack();
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);
//data_heap
cell init_zone(zone *z, cell size, cell start);
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);
void dealloc_data_heap(data_heap *data);
void clear_cards(cell from, cell to);
void clear_decks(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_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
relocation_type relocation_type_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_dlsym(dll *dll, symbol_char *symbol);
void ffi_dlclose(dll *dll);
segment *alloc_segment(cell size);
void c_to_factor_toplevel(cell quot);
// os-windows
#if defined(WINDOWS)
void sleep_micros(u64 usec);
long getpagesize();
void dealloc_segment(segment *block);
const vm_char *vm_executable_path();
const vm_char *default_image_path();
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)));
}
PRIMITIVE(word)
{
PRIMITIVE_GETVM()->primitive_word();
}
PRIMITIVE_FORWARD(word)
/* word-xt ( word -- start end ) */
inline void factor_vm::primitive_word_xt()
{
word *w = untag_check<word>(dpop());
code_block *code = (profiling_p ? w->profiling : w->code);
dpush(allot_cell((cell)code->xt()));
dpush(allot_cell((cell)code + code->size));
gc_root<word> w(dpop(),this);
w.untag_check(this);
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_GETVM()->primitive_word_xt();
}
PRIMITIVE_FORWARD(word_xt)
/* Allocates memory */
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()))));
}
PRIMITIVE(optimized_p)
{
PRIMITIVE_GETVM()->primitive_optimized_p();
}
PRIMITIVE_FORWARD(optimized_p)
inline void factor_vm::primitive_wrapper()
{
@ -97,9 +97,6 @@ inline void factor_vm::primitive_wrapper()
drepl(tag<wrapper>(new_wrapper));
}
PRIMITIVE(wrapper)
{
PRIMITIVE_GETVM()->primitive_wrapper();
}
PRIMITIVE_FORWARD(wrapper)
}