CFLAGS += -O3
endif
+ifdef REENTRANT
+ CFLAGS += -DFACTOR_REENTRANT
+endif
+
CFLAGS += $(SITE_CFLAGS)
ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
Factor.app/Contents/MacOS/factor
$(EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
- $(LINKER) $(ENGINE) $(DLL_OBJS)
- $(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+ $(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
+ $(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
$(CONSOLE_EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
- $(LINKER) $(ENGINE) $(DLL_OBJS)
- $(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+ $(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
+ $(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
$(TEST_LIBRARY): vm/ffi_test.o
- $(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS)
+ $(TOOLCHAIN_PREFIX)$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS)
clean:
rm -f vm/*.o
etags vm/*.{cpp,hpp,mm,S,c}
vm/resources.o:
- $(WINDRES) vm/factor.rs vm/resources.o
+ $(TOOLCHAIN_PREFIX)$(WINDRES) vm/factor.rs vm/resources.o
vm/ffi_test.o: vm/ffi_test.c
- $(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -o $@ $<
+ $(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -o $@ $<
.c.o:
- $(CC) -c $(CFLAGS) -o $@ $<
+ $(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) -o $@ $<
.cpp.o:
- $(CPP) -c $(CFLAGS) -o $@ $<
+ $(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $<
.S.o:
- $(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
+ $(TOOLCHAIN_PREFIX)$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
.mm.o:
- $(CPP) -c $(CFLAGS) -o $@ $<
+ $(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $<
.PHONY: factor tags clean
M: ##set-slot insn-slot# slot>> constant ;
M: ##set-slot-imm insn-slot# slot>> ;
M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
+M: ##vm-field-ptr insn-slot# fieldname>> 1array ; ! is this right?
M: ##slot insn-object obj>> resolve ;
M: ##slot-imm insn-object obj>> resolve ;
M: ##set-slot insn-object obj>> resolve ;
M: ##set-slot-imm insn-object obj>> resolve ;
M: ##alien-global insn-object drop \ ##alien-global ;
+M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ;
: init-alias-analysis ( insns -- insns' )
H{ } clone histories set
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ; inline
: ^^tag-fixnum ( src -- dst ) tag-bits get ^^shl-imm ; inline
-: ^^untag-fixnum ( src -- dst ) tag-bits get ^^sar-imm ; inline
\ No newline at end of file
+: ^^untag-fixnum ( src -- dst ) tag-bits get ^^sar-imm ; inline
def: dst/int-rep
literal: symbol library ;
+INSN: ##vm-field-ptr
+def: dst/int-rep
+literal: fieldname ;
+
! FFI
INSN: ##alien-invoke
literal: params stack-frame ;
ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
: emit-getenv ( node -- )
- "userenv" f ^^alien-global
+ "userenv" ^^vm-field-ptr
swap node-input-infos first literal>>
[ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot 0 ^^slot ] if*
ds-push ;
[ dst>> ] [ symbol>> ] [ library>> ] tri
%alien-global ;
+M: ##vm-field-ptr generate-insn
+ [ dst>> ] [ fieldname>> ] bi %vm-field-ptr ;
+
! ##alien-invoke
GENERIC: next-fastcall-param ( rep -- )
! Generate code for boxing input parameters in a callback.
[
dup \ %save-param-reg move-parameters
- "nest_stacks" f %alien-invoke
+ "nest_stacks" %vm-invoke-1st-arg
box-parameters
] with-param-regs ;
[ callback-context new do-callback ] %
] [ ] make ;
-: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
+: %unnest-stacks ( -- ) "unnest_stacks" %vm-invoke-1st-arg ;
M: ##callback-return generate-insn
#! All the extra book-keeping for %unwind is only for x86.
CONSTANT: rt-stack-chain 9
CONSTANT: rt-untagged 10
CONSTANT: rt-megamorphic-cache-hits 11
+CONSTANT: rt-vm 12
: rc-absolute? ( n -- ? )
${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ;
HOOK: %set-alien-vector cpu ( ptr value rep -- )
HOOK: %alien-global cpu ( dst symbol library -- )
+HOOK: %vm-field-ptr cpu ( dst fieldname -- )
HOOK: %allot cpu ( dst size class temp -- )
HOOK: %write-barrier cpu ( src card# table -- )
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 ;
compiler.cfg.instructions compiler.cfg.comparisons
compiler.codegen.fixup compiler.cfg.intrinsics
compiler.cfg.stack-frame compiler.cfg.build-stack-frame
-compiler.units compiler.constants compiler.codegen ;
+compiler.units compiler.constants compiler.codegen vm ;
FROM: cpu.ppc.assembler => B ;
FROM: math => float ;
IN: cpu.ppc
\ ##float>integer t frame-required? set-word-prop
>>
+: %load-vm-addr ( reg -- )
+ 0 swap LOAD32 rc-absolute-ppc-2/2 rt-vm rel-fixup ;
+
+: %load-vm-field-addr ( reg symbol -- )
+ [ drop %load-vm-addr ]
+ [ [ dup ] dip vm-field-offset ADDI ] 2bi ;
+
+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 ] }
M: ppc %set-alien-double swap 0 STFD ;
: load-zone-ptr ( reg -- )
- "nursery" f %alien-global ;
+ "nursery" %load-vm-field-addr ;
: load-allot-ptr ( nursery-ptr allot-ptr -- )
[ drop load-zone-ptr ] [ swap 4 LWZ ] 2bi ;
dst class store-tagged ;
: load-cards-offset ( dst -- )
- [ "cards_offset" f %alien-global ] [ dup 0 LWZ ] bi ;
+ [ "cards_offset" %load-vm-field-addr ] [ dup 0 LWZ ] bi ;
: load-decks-offset ( dst -- )
- [ "decks_offset" f %alien-global ] [ dup 0 LWZ ] bi ;
+ [ "decks_offset" %load-vm-field-addr ] [ dup 0 LWZ ] bi ;
M:: ppc %write-barrier ( src card# table -- )
card-mark scratch-reg LI
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
- temp1 "stack_chain" f %alien-global
+ temp1 "stack_chain" %load-vm-field-addr
temp1 temp1 0 LWZ
1 temp1 0 STW
callback-allowed? [
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
+
M: x86.32 return-struct-in-registers? ( c-type -- ? )
c-type
[ return-in-registers?>> ]
#! parameter being passed to a callback from C.
over [ load-return-reg ] [ 2drop ] if ;
+CONSTANT: vm-ptr-size 4
+
M:: x86.32 %box ( n rep func -- )
n rep (%box)
- rep rep-size [
+ rep rep-size vm-ptr-size + [
+ push-vm-ptr
rep push-return-reg
func f %alien-invoke
] with-aligned-stack ;
M: x86.32 %box-long-long ( n func -- )
[ (%box-long-long) ] dip
- 8 [
+ 8 vm-ptr-size + [
+ push-vm-ptr
EDX PUSH
EAX PUSH
f %alien-invoke
M:: x86.32 %box-large-struct ( n c-type -- )
! Compute destination address
- ECX n struct-return@ LEA
- 8 [
+ EDX n struct-return@ LEA
+ 8 vm-ptr-size + [
+ push-vm-ptr
! Push struct size
c-type heap-size PUSH
! Push destination address
- ECX PUSH
+ EDX PUSH
! Copy the struct from the C stack
"box_value_struct" f %alien-invoke
] with-aligned-stack ;
M: x86.32 %box-small-struct ( c-type -- )
#! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
- 12 [
+ 12 vm-ptr-size + [
+ push-vm-ptr
heap-size PUSH
EDX PUSH
EAX PUSH
ESI 4 SUB ;
: call-unbox-func ( func -- )
- 4 [
+ 8 [
+ ! push the vm ptr as an argument
+ push-vm-ptr
! Push parameter
EAX PUSH
! Call the unboxer
: %unbox-struct-1 ( -- )
#! Alien must be in EAX.
- 4 [
+ 4 vm-ptr-size + [
+ push-vm-ptr
EAX PUSH
"alien_offset" f %alien-invoke
! Load first cell
: %unbox-struct-2 ( -- )
#! Alien must be in EAX.
- 4 [
+ 4 vm-ptr-size + [
+ push-vm-ptr
EAX PUSH
"alien_offset" f %alien-invoke
! Load second cell
M:: x86.32 %unbox-large-struct ( n c-type -- )
! Alien must be in EAX.
! Compute destination address
- ECX n stack@ LEA
- 12 [
+ EDX n stack@ LEA
+ 12 vm-ptr-size + [
+ push-vm-ptr
! Push struct size
c-type heap-size PUSH
! Push destination address
- ECX PUSH
+ EDX PUSH
! Push source address
EAX PUSH
! Copy the struct to the stack
] with-aligned-stack ;
M: x86.32 %prepare-alien-indirect ( -- )
- "unbox_alien" f %alien-invoke
+ push-vm-ptr "unbox_alien" f %alien-invoke
+ temp-reg POP
EBP EAX MOV ;
M: x86.32 %alien-indirect ( -- )
4 [
EAX swap %load-reference
EAX PUSH
+ param-reg-2 0 MOV rc-absolute-cell rt-vm rel-fixup
"c_to_factor" f %alien-invoke
] with-aligned-stack ;
! Save top of data stack in non-volatile register
%prepare-unbox
EAX PUSH
+ push-vm-ptr
! Restore data/call/retain stacks
"unnest_stacks" f %alien-invoke
! Place top of data stack in EAX
+ temp-reg POP
EAX POP
! Restore C stack
ESP 12 ADD
: div-arg ( -- reg ) EAX ;
: mod-arg ( -- reg ) EDX ;
: arg ( -- reg ) EAX ;
+: arg2 ( -- reg ) EDX ;
: temp0 ( -- reg ) EAX ;
: temp1 ( -- reg ) EDX ;
: temp2 ( -- reg ) ECX ;
temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel
! save stack pointer
temp0 [] stack-reg MOV
+ ! pass vm ptr to primitive
+ arg 0 MOV rc-absolute-cell rt-vm jit-rel
! call the primitive
0 JMP rc-relative rt-primitive jit-rel
] jit-primitive jit-define
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 ;
+
+
M:: x86.64 %unbox ( n rep func -- )
! Call the unboxer
- func f %alien-invoke
+ func %vm-invoke-2nd-arg
! 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
{ 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" f %alien-invoke
+ "alien_offset" %vm-invoke-2nd-arg
! Move alien_offset() return value to R11 so that we don't
! clobber it.
R11 RAX MOV
! Load structure size into param-reg-3
param-reg-3 c-type heap-size MOV
! Copy the struct to the C stack
- "to_value_struct" f %alien-invoke ;
+ "to_value_struct" %vm-invoke-4th-arg ;
: load-return-value ( rep -- )
[ [ 0 ] dip reg-class-of param-reg ]
[ ]
tri copy-register ;
+
+
M:: x86.64 %box ( n rep func -- )
n [
n
] [
rep load-return-value
] if
- func f %alien-invoke ;
+ rep int-rep? [ func %vm-invoke-2nd-arg ] [ func %vm-invoke-1st-arg ] if ;
M: x86.64 %box-long-long ( n func -- )
[ int-rep ] dip %box ;
[ 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" f %alien-invoke
+ "box_small_struct" %vm-invoke-4th-arg
] with-return-regs ;
: struct-return@ ( n -- operand )
! Compute destination address
param-reg-1 swap struct-return@ LEA
! Copy the struct from the C stack
- "box_value_struct" f %alien-invoke ;
+ "box_value_struct" %vm-invoke-3rd-arg ;
M: x86.64 %prepare-box-struct ( -- )
! Compute target address for value struct return
rc-absolute-cell rel-dlsym
R11 CALL ;
+
M: x86.64 %prepare-alien-indirect ( -- )
- "unbox_alien" f %alien-invoke
+ "unbox_alien" %vm-invoke-1st-arg
RBP RAX MOV ;
M: x86.64 %alien-indirect ( -- )
M: x86.64 %alien-callback ( quot -- )
param-reg-1 swap %load-reference
- "c_to_factor" f %alien-invoke ;
+ "c_to_factor" %vm-invoke-2nd-arg ;
M: x86.64 %callback-value ( ctype -- )
! Save top of data stack
RSP 8 SUB
param-reg-1 PUSH
! Restore data/call/retain stacks
- "unnest_stacks" f %alien-invoke
+ "unnest_stacks" %vm-invoke-1st-arg
! Put former top of data stack in param-reg-1
param-reg-1 POP
RSP 8 ADD
: rex-length ( -- n ) 1 ;
[
+
! load stack_chain
temp0 0 MOV rc-absolute-cell rt-stack-chain jit-rel
temp0 temp0 [] MOV
temp0 [] stack-reg MOV
! load XT
temp1 0 MOV rc-absolute-cell rt-primitive jit-rel
+ ! load vm ptr
+ arg 0 MOV rc-absolute-cell rt-vm jit-rel
! go
temp1 JMP
] jit-primitive jit-define
: stack-frame-size ( -- n ) 4 bootstrap-cells ;
: arg ( -- reg ) RDI ;
+: arg2 ( -- reg ) RSI ;
<< "vocab:cpu/x86/64/bootstrap.factor" parse-file parsed >>
call
: stack-frame-size ( -- n ) 8 bootstrap-cells ;
: arg ( -- reg ) RCX ;
+: arg2 ( -- reg ) RDX ;
<< "vocab:cpu/x86/64/bootstrap.factor" parse-file parsed >>
call
arg ds-reg [] MOV
! pop stack
ds-reg bootstrap-cell SUB
+ ! pass vm pointer
+ arg2 0 MOV rc-absolute-cell rt-vm jit-rel
! call quotation
arg quot-xt-offset [+] JMP
] \ (call) define-sub-primitive
cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
cpu.architecture kernel kernel.private math memory namespaces make
sequences words system layouts combinators math.order fry locals
-compiler.constants byte-arrays
+compiler.constants vm byte-arrays
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.intrinsics
compiler.cfg.comparisons
compiler.cfg.stack-frame
-compiler.codegen
compiler.codegen.fixup ;
FROM: math => float ;
IN: cpu.x86
M: x86 %shr [ SHR ] emit-shift ;
M: x86 %sar [ SAR ] emit-shift ;
+M: x86 %vm-field-ptr ( dst field -- )
+ [ drop 0 MOV rc-absolute-cell rt-vm rel-fixup ]
+ [ vm-field-offset ADD ] 2bi ;
+
: load-zone-ptr ( reg -- )
#! Load pointer to start of zone array
- 0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
+ "nursery" %vm-field-ptr ;
: load-allot-ptr ( nursery-ptr allot-ptr -- )
[ drop load-zone-ptr ] [ swap cell [+] MOV ] 2bi ;
dst class store-tagged
nursery-ptr size inc-allot-ptr ;
+
M:: x86 %write-barrier ( src card# table -- )
#! Mark the card pointed to by vreg.
! Mark the card
card# src MOV
card# card-bits SHR
- table "cards_offset" f %alien-global
+ table "cards_offset" %vm-field-ptr
table table [] MOV
table card# [+] card-mark <byte> MOV
! Mark the card deck
card# deck-bits card-bits - SHR
- table "decks_offset" f %alien-global
+ table "decks_offset" %vm-field-ptr
table table [] MOV
table card# [+] card-mark <byte> MOV ;
! Pass number of roots as second parameter
param-reg-2 gc-root-count MOV
! Call GC
- "inline_gc" f %alien-invoke ;
+ "inline_gc" %vm-invoke-3rd-arg ;
-M: x86 %alien-global
- [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
+M: x86 %alien-global ( dst symbol library -- )
+ [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
- temp1 "stack_chain" f %alien-global
- temp1 temp1 [] MOV
+ temp1 0 MOV rc-absolute-cell rt-vm rel-fixup
+ temp1 temp1 "stack_chain" vm-field-offset [+] MOV
temp2 stack-reg cell neg [+] LEA
temp1 [] temp2 MOV
callback-allowed? [
--- /dev/null
+Phil Dawes
\ No newline at end of file
--- /dev/null
+Layout of the C vm structure
--- /dev/null
+! Copyright (C) 2009 Phil Dawes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.structs alien.syntax ;
+IN: vm
+
+TYPEDEF: void* cell
+
+C-STRUCT: zone
+ { "cell" "start" }
+ { "cell" "here" }
+ { "cell" "size" }
+ { "cell" "end" }
+ ;
+
+C-STRUCT: vm
+ { "context*" "stack_chain" }
+ { "zone" "nursery" }
+ { "cell" "cards_offset" }
+ { "cell" "decks_offset" }
+ { "cell[70]" "userenv" }
+ ;
+
+: vm-field-offset ( field -- offset ) "vm" offset-of ;
\ No newline at end of file
"words"
"vectors"
"vectors.private"
+ "vm"
} [ create-vocab drop ] each
! Builtin classes
{ "inline-cache-stats" "generic.single" (( -- stats )) }
{ "optimized?" "words" (( word -- ? )) }
{ "quot-compiled?" "quotations" (( quot -- ? )) }
+ { "vm-ptr" "vm" (( -- ptr )) }
} [ [ first3 ] dip swap make-primitive ] each-index
! Bump build number
--- /dev/null
+USING: alien.syntax io io.encodings.utf16n io.encodings.utf8 io.files
+kernel namespaces sequences system threads unix.utilities ;
+IN: mttest
+
+FUNCTION: void* start_standalone_factor_in_new_thread ( int argc, char** argv ) ;
+
+HOOK: native-string-encoding os ( -- encoding )
+M: windows native-string-encoding utf16n ;
+M: unix native-string-encoding utf8 ;
+
+: start-vm-in-os-thread ( args -- threadhandle )
+ \ vm get-global prefix
+ [ length ] [ native-string-encoding strings>alien ] bi
+ start_standalone_factor_in_new_thread ;
+
+: start-tetris-in-os-thread ( -- )
+ { "-run=tetris" } start-vm-in-os-thread drop ;
+
+: start-testthread-in-os-thread ( -- )
+ { "-run=mttest" } start-vm-in-os-thread drop ;
+
+: testthread ( -- )
+ "/tmp/hello" utf8 [ "hello!\n" write ] with-file-appender 5000000 sleep ;
+
+MAIN: testthread
\ No newline at end of file
/* gets the address of an object representing a C pointer, with the
intention of storing the pointer across code which may potentially GC. */
-char *pinned_alien_offset(cell obj)
+char *factorvm::pinned_alien_offset(cell obj)
{
switch(tagged<object>(obj).type())
{
}
/* make an alien */
-cell allot_alien(cell delegate_, cell displacement)
+cell factorvm::allot_alien(cell delegate_, cell displacement)
{
- gc_root<object> delegate(delegate_);
- gc_root<alien> new_alien(allot<alien>(sizeof(alien)));
+ gc_root<object> delegate(delegate_,this);
+ gc_root<alien> new_alien(allot<alien>(sizeof(alien)),this);
if(delegate.type_p(ALIEN_TYPE))
{
}
/* make an alien pointing at an offset of another alien */
-PRIMITIVE(displaced_alien)
+inline void factorvm::vmprim_displaced_alien()
{
cell alien = dpop();
cell displacement = to_cell(dpop());
}
}
+PRIMITIVE(displaced_alien)
+{
+ PRIMITIVE_GETVM()->vmprim_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. */
-PRIMITIVE(alien_address)
+inline void factorvm::vmprim_alien_address()
{
box_unsigned_cell((cell)pinned_alien_offset(dpop()));
}
+PRIMITIVE(alien_address)
+{
+ PRIMITIVE_GETVM()->vmprim_alien_address();
+}
+
/* pop ( alien n ) from datastack, return alien's address plus n */
-static void *alien_pointer()
+void *factorvm::alien_pointer()
{
fixnum offset = to_fixnum(dpop());
return unbox_alien() + offset;
#define DEFINE_ALIEN_ACCESSOR(name,type,boxer,to) \
PRIMITIVE(alien_##name) \
{ \
- boxer(*(type*)alien_pointer()); \
+ PRIMITIVE_GETVM()->boxer(*(type*)PRIMITIVE_GETVM()->alien_pointer()); \
} \
PRIMITIVE(set_alien_##name) \
{ \
- type *ptr = (type *)alien_pointer(); \
- type value = to(dpop()); \
+ type *ptr = (type *)PRIMITIVE_GETVM()->alien_pointer(); \
+ type value = PRIMITIVE_GETVM()->to(dpop()); \
*ptr = value; \
}
DEFINE_ALIEN_ACCESSOR(cell,void *,box_alien,pinned_alien_offset)
/* open a native library and push a handle */
-PRIMITIVE(dlopen)
+inline void factorvm::vmprim_dlopen()
{
- gc_root<byte_array> path(dpop());
- path.untag_check();
- gc_root<dll> library(allot<dll>(sizeof(dll)));
+ gc_root<byte_array> path(dpop(),this);
+ path.untag_check(this);
+ gc_root<dll> library(allot<dll>(sizeof(dll)),this);
library->path = path.value();
ffi_dlopen(library.untagged());
dpush(library.value());
}
+PRIMITIVE(dlopen)
+{
+ PRIMITIVE_GETVM()->vmprim_dlopen();
+}
+
/* look up a symbol in a native library */
-PRIMITIVE(dlsym)
+inline void factorvm::vmprim_dlsym()
{
- gc_root<object> library(dpop());
- gc_root<byte_array> name(dpop());
- name.untag_check();
+ gc_root<object> library(dpop(),this);
+ gc_root<byte_array> name(dpop(),this);
+ name.untag_check(this);
symbol_char *sym = name->data<symbol_char>();
}
}
+PRIMITIVE(dlsym)
+{
+ PRIMITIVE_GETVM()->vmprim_dlsym();
+}
+
/* close a native library handle */
-PRIMITIVE(dlclose)
+inline void factorvm::vmprim_dlclose()
{
dll *d = untag_check<dll>(dpop());
if(d->dll != NULL)
ffi_dlclose(d);
}
-PRIMITIVE(dll_validp)
+PRIMITIVE(dlclose)
+{
+ PRIMITIVE_GETVM()->vmprim_dlclose();
+}
+
+inline void factorvm::vmprim_dll_validp()
{
cell library = dpop();
if(library == F)
dpush(untag_check<dll>(library)->dll == NULL ? F : T);
}
+PRIMITIVE(dll_validp)
+{
+ PRIMITIVE_GETVM()->vmprim_dll_validp();
+}
+
/* gets the address of an object representing a C pointer */
-VM_C_API char *alien_offset(cell obj)
+char *factorvm::alien_offset(cell obj)
{
switch(tagged<object>(obj).type())
{
}
}
+VM_C_API char *alien_offset(cell obj, factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->alien_offset(obj);
+}
+
/* pop an object representing a C pointer */
-VM_C_API char *unbox_alien()
+char *factorvm::unbox_alien()
{
return alien_offset(dpop());
}
+VM_C_API char *unbox_alien(factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->unbox_alien();
+}
+
/* make an alien and push */
-VM_C_API void box_alien(void *ptr)
+void factorvm::box_alien(void *ptr)
{
if(ptr == NULL)
dpush(F);
dpush(allot_alien(F,(cell)ptr));
}
+VM_C_API void box_alien(void *ptr, factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_alien(ptr);
+}
+
/* for FFI calls passing structs by value */
-VM_C_API void to_value_struct(cell src, void *dest, cell size)
+void factorvm::to_value_struct(cell src, void *dest, cell size)
{
memcpy(dest,alien_offset(src),size);
}
+VM_C_API void to_value_struct(cell src, void *dest, cell size, factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->to_value_struct(src,dest,size);
+}
+
/* for FFI callbacks receiving structs by value */
-VM_C_API void box_value_struct(void *src, cell size)
+void factorvm::box_value_struct(void *src, cell size)
{
byte_array *bytes = allot_byte_array(size);
memcpy(bytes->data<void>(),src,size);
dpush(tag<byte_array>(bytes));
}
+VM_C_API void box_value_struct(void *src, cell size,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_value_struct(src,size);
+}
+
/* On some x86 OSes, structs <= 8 bytes are returned in registers. */
-VM_C_API void box_small_struct(cell x, cell y, cell size)
+void factorvm::box_small_struct(cell x, cell y, cell size)
{
cell data[2];
data[0] = x;
box_value_struct(data,size);
}
+VM_C_API void box_small_struct(cell x, cell y, cell size, factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_small_struct(x,y,size);
+}
+
/* On OS X/PPC, complex numbers are returned in registers. */
-VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size)
+void factorvm::box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size)
{
cell data[4];
data[0] = x1;
box_value_struct(data,size);
}
+VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size, factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_medium_struct(x1, x2, x3, x4, size);
+}
+
+inline void factorvm::vmprim_vm_ptr()
+{
+ box_alien(this);
+}
+
+PRIMITIVE(vm_ptr)
+{
+ PRIMITIVE_GETVM()->vmprim_vm_ptr();
+}
+
}
namespace factor
{
-cell allot_alien(cell delegate, cell displacement);
-
PRIMITIVE(displaced_alien);
PRIMITIVE(alien_address);
PRIMITIVE(dlclose);
PRIMITIVE(dll_validp);
-VM_C_API char *alien_offset(cell object);
-VM_C_API char *unbox_alien();
-VM_C_API void box_alien(void *ptr);
-VM_C_API void to_value_struct(cell src, void *dest, cell size);
-VM_C_API void box_value_struct(void *src, cell size);
-VM_C_API void box_small_struct(cell x, cell y, cell size);
-VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size);
+PRIMITIVE(vm_ptr);
+
+VM_C_API char *alien_offset(cell object, factorvm *vm);
+VM_C_API char *unbox_alien(factorvm *vm);
+VM_C_API void box_alien(void *ptr, factorvm *vm);
+VM_C_API void to_value_struct(cell src, void *dest, cell size, factorvm *vm);
+VM_C_API void box_value_struct(void *src, cell size,factorvm *vm);
+VM_C_API void box_small_struct(cell x, cell y, cell size,factorvm *vm);
+VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size,factorvm *vm);
}
{
/* make a new array with an initial element */
-array *allot_array(cell capacity, cell fill_)
+array *factorvm::allot_array(cell capacity, cell fill_)
{
- gc_root<object> fill(fill_);
- gc_root<array> new_array(allot_array_internal<array>(capacity));
+ gc_root<object> fill(fill_,this);
+ gc_root<array> new_array(allot_array_internal<array>(capacity),this);
if(fill.value() == tag_fixnum(0))
memset(new_array->data(),'\0',capacity * sizeof(cell));
return new_array.untagged();
}
+
/* push a new array on the stack */
-PRIMITIVE(array)
+inline void factorvm::vmprim_array()
{
cell initial = dpop();
cell size = unbox_array_size();
dpush(tag<array>(allot_array(size,initial)));
}
-cell allot_array_1(cell obj_)
+PRIMITIVE(array)
{
- gc_root<object> obj(obj_);
- gc_root<array> a(allot_array_internal<array>(1));
+ PRIMITIVE_GETVM()->vmprim_array();
+}
+
+cell factorvm::allot_array_1(cell obj_)
+{
+ gc_root<object> obj(obj_,this);
+ gc_root<array> a(allot_array_internal<array>(1),this);
set_array_nth(a.untagged(),0,obj.value());
return a.value();
}
-cell allot_array_2(cell v1_, cell v2_)
+
+cell factorvm::allot_array_2(cell v1_, cell v2_)
{
- gc_root<object> v1(v1_);
- gc_root<object> v2(v2_);
- gc_root<array> a(allot_array_internal<array>(2));
+ gc_root<object> v1(v1_,this);
+ gc_root<object> v2(v2_,this);
+ gc_root<array> a(allot_array_internal<array>(2),this);
set_array_nth(a.untagged(),0,v1.value());
set_array_nth(a.untagged(),1,v2.value());
return a.value();
}
-cell allot_array_4(cell v1_, cell v2_, cell v3_, cell v4_)
+
+cell factorvm::allot_array_4(cell v1_, cell v2_, cell v3_, cell v4_)
{
- gc_root<object> v1(v1_);
- gc_root<object> v2(v2_);
- gc_root<object> v3(v3_);
- gc_root<object> v4(v4_);
- gc_root<array> a(allot_array_internal<array>(4));
+ gc_root<object> v1(v1_,this);
+ gc_root<object> v2(v2_,this);
+ gc_root<object> v3(v3_,this);
+ gc_root<object> v4(v4_,this);
+ gc_root<array> a(allot_array_internal<array>(4),this);
set_array_nth(a.untagged(),0,v1.value());
set_array_nth(a.untagged(),1,v2.value());
set_array_nth(a.untagged(),2,v3.value());
return a.value();
}
-PRIMITIVE(resize_array)
+
+inline void factorvm::vmprim_resize_array()
{
array* a = untag_check<array>(dpop());
cell capacity = unbox_array_size();
dpush(tag<array>(reallot_array(a,capacity)));
}
+PRIMITIVE(resize_array)
+{
+ PRIMITIVE_GETVM()->vmprim_resize_array();
+}
+
void growable_array::add(cell elt_)
{
- gc_root<object> elt(elt_);
+ factorvm* myvm = elements.myvm;
+ gc_root<object> elt(elt_,myvm);
if(count == array_capacity(elements.untagged()))
- elements = reallot_array(elements.untagged(),count * 2);
+ elements = myvm->reallot_array(elements.untagged(),count * 2);
- set_array_nth(elements.untagged(),count++,elt.value());
+ myvm->set_array_nth(elements.untagged(),count++,elt.value());
}
void growable_array::trim()
{
- elements = reallot_array(elements.untagged(),count);
+ factorvm *myvm = elements.myvm;
+ elements = myvm->reallot_array(elements.untagged(),count);
}
}
namespace factor
{
-inline static cell array_nth(array *array, cell slot)
+inline cell array_nth(array *array, cell slot)
{
#ifdef FACTOR_DEBUG
assert(slot < array_capacity(array));
return array->data()[slot];
}
-inline static void set_array_nth(array *array, cell slot, cell value)
-{
-#ifdef FACTOR_DEBUG
- assert(slot < array_capacity(array));
- assert(array->h.hi_tag() == ARRAY_TYPE);
- check_tagged_pointer(value);
-#endif
- array->data()[slot] = value;
- write_barrier(array);
-}
-
-array *allot_array(cell capacity, cell fill);
-
-cell allot_array_1(cell obj);
-cell allot_array_2(cell v1, cell v2);
-cell allot_array_4(cell v1, cell v2, cell v3, cell v4);
-
PRIMITIVE(array);
PRIMITIVE(resize_array);
-struct growable_array {
- cell count;
- gc_root<array> elements;
-
- growable_array(cell capacity = 10) : count(0), elements(allot_array(capacity,F)) {}
-
- void add(cell elt);
- void trim();
-};
}
/* :tabSize=2:indentSize=2:noTabs=true:
-Copyright (C) 1989-94 Massachusetts Institute of Technology
-Portions copyright (C) 2004-2008 Slava Pestov
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy and modify this software, to
-redistribute either the original software or a modified version, and
-to use this software for any purpose is granted, subject to the
-following restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
+ Copyright (C) 1989-94 Massachusetts Institute of Technology
+ Portions copyright (C) 2004-2008 Slava Pestov
+
+ This material was developed by the Scheme project at the Massachusetts
+ Institute of Technology, Department of Electrical Engineering and
+ Computer Science. Permission to copy and modify this software, to
+ redistribute either the original software or a modified version, and
+ to use this software for any purpose is granted, subject to the
+ following restrictions and understandings.
+
+ 1. Any copy made of this software must include this copyright notice
+ in full.
+
+ 2. Users of this software agree to make their best efforts (a) to
+ return to the MIT Scheme project any improvements or extensions that
+ they make, so that these may be included in future releases; and (b)
+ to inform MIT of noteworthy uses of this software.
+
+ 3. All materials developed as a consequence of the use of this
+ software shall duly acknowledge such use, in accordance with the usual
+ standards of acknowledging credit in academic research.
+
+ 4. MIT has made no warrantee or representation that the operation of
+ this software will be error-free, and MIT is under no obligation to
+ provide any services, by way of maintenance, update, or otherwise.
+
+ 5. In conjunction with products arising from the use of this material,
+ there shall be no use of the name of the Massachusetts Institute of
+ Technology nor of any adaptation thereof in any advertising,
+ promotional, or sales literature without prior written consent from
+ MIT in each case. */
/* Changes for Scheme 48:
* - Converted to ANSI.
/* Exports */
-int
-bignum_equal_p(bignum * x, bignum * y)
+int factorvm::bignum_equal_p(bignum * x, bignum * y)
{
- return
- ((BIGNUM_ZERO_P (x))
- ? (BIGNUM_ZERO_P (y))
- : ((! (BIGNUM_ZERO_P (y)))
- && ((BIGNUM_NEGATIVE_P (x))
- ? (BIGNUM_NEGATIVE_P (y))
- : (! (BIGNUM_NEGATIVE_P (y))))
- && (bignum_equal_p_unsigned (x, y))));
+ return
+ ((BIGNUM_ZERO_P (x))
+ ? (BIGNUM_ZERO_P (y))
+ : ((! (BIGNUM_ZERO_P (y)))
+ && ((BIGNUM_NEGATIVE_P (x))
+ ? (BIGNUM_NEGATIVE_P (y))
+ : (! (BIGNUM_NEGATIVE_P (y))))
+ && (bignum_equal_p_unsigned (x, y))));
}
-enum bignum_comparison
-bignum_compare(bignum * x, bignum * y)
+
+enum bignum_comparison factorvm::bignum_compare(bignum * x, bignum * y)
{
- return
- ((BIGNUM_ZERO_P (x))
- ? ((BIGNUM_ZERO_P (y))
- ? bignum_comparison_equal
- : (BIGNUM_NEGATIVE_P (y))
- ? bignum_comparison_greater
- : bignum_comparison_less)
- : (BIGNUM_ZERO_P (y))
- ? ((BIGNUM_NEGATIVE_P (x))
- ? bignum_comparison_less
- : bignum_comparison_greater)
- : (BIGNUM_NEGATIVE_P (x))
- ? ((BIGNUM_NEGATIVE_P (y))
- ? (bignum_compare_unsigned (y, x))
- : (bignum_comparison_less))
- : ((BIGNUM_NEGATIVE_P (y))
- ? (bignum_comparison_greater)
- : (bignum_compare_unsigned (x, y))));
+ return
+ ((BIGNUM_ZERO_P (x))
+ ? ((BIGNUM_ZERO_P (y))
+ ? bignum_comparison_equal
+ : (BIGNUM_NEGATIVE_P (y))
+ ? bignum_comparison_greater
+ : bignum_comparison_less)
+ : (BIGNUM_ZERO_P (y))
+ ? ((BIGNUM_NEGATIVE_P (x))
+ ? bignum_comparison_less
+ : bignum_comparison_greater)
+ : (BIGNUM_NEGATIVE_P (x))
+ ? ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_compare_unsigned (y, x))
+ : (bignum_comparison_less))
+ : ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_comparison_greater)
+ : (bignum_compare_unsigned (x, y))));
}
+
/* allocates memory */
-bignum *
-bignum_add(bignum * x, bignum * y)
+bignum *factorvm::bignum_add(bignum * x, bignum * y)
{
- return
- ((BIGNUM_ZERO_P (x))
- ? (y)
- : (BIGNUM_ZERO_P (y))
- ? (x)
- : ((BIGNUM_NEGATIVE_P (x))
- ? ((BIGNUM_NEGATIVE_P (y))
- ? (bignum_add_unsigned (x, y, 1))
- : (bignum_subtract_unsigned (y, x)))
- : ((BIGNUM_NEGATIVE_P (y))
- ? (bignum_subtract_unsigned (x, y))
- : (bignum_add_unsigned (x, y, 0)))));
+ return
+ ((BIGNUM_ZERO_P (x))
+ ? (y)
+ : (BIGNUM_ZERO_P (y))
+ ? (x)
+ : ((BIGNUM_NEGATIVE_P (x))
+ ? ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_add_unsigned (x, y, 1))
+ : (bignum_subtract_unsigned (y, x)))
+ : ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_subtract_unsigned (x, y))
+ : (bignum_add_unsigned (x, y, 0)))));
}
/* allocates memory */
-bignum *
-bignum_subtract(bignum * x, bignum * y)
+bignum *factorvm::bignum_subtract(bignum * x, bignum * y)
{
- return
- ((BIGNUM_ZERO_P (x))
- ? ((BIGNUM_ZERO_P (y))
- ? (y)
- : (bignum_new_sign (y, (! (BIGNUM_NEGATIVE_P (y))))))
- : ((BIGNUM_ZERO_P (y))
- ? (x)
- : ((BIGNUM_NEGATIVE_P (x))
- ? ((BIGNUM_NEGATIVE_P (y))
- ? (bignum_subtract_unsigned (y, x))
- : (bignum_add_unsigned (x, y, 1)))
- : ((BIGNUM_NEGATIVE_P (y))
- ? (bignum_add_unsigned (x, y, 0))
- : (bignum_subtract_unsigned (x, y))))));
+ return
+ ((BIGNUM_ZERO_P (x))
+ ? ((BIGNUM_ZERO_P (y))
+ ? (y)
+ : (bignum_new_sign (y, (! (BIGNUM_NEGATIVE_P (y))))))
+ : ((BIGNUM_ZERO_P (y))
+ ? (x)
+ : ((BIGNUM_NEGATIVE_P (x))
+ ? ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_subtract_unsigned (y, x))
+ : (bignum_add_unsigned (x, y, 1)))
+ : ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_add_unsigned (x, y, 0))
+ : (bignum_subtract_unsigned (x, y))))));
}
+
/* allocates memory */
-bignum *
-bignum_multiply(bignum * x, bignum * y)
+bignum *factorvm::bignum_multiply(bignum * x, bignum * y)
{
- bignum_length_type x_length = (BIGNUM_LENGTH (x));
- bignum_length_type y_length = (BIGNUM_LENGTH (y));
- int negative_p =
- ((BIGNUM_NEGATIVE_P (x))
- ? (! (BIGNUM_NEGATIVE_P (y)))
- : (BIGNUM_NEGATIVE_P (y)));
- if (BIGNUM_ZERO_P (x))
- return (x);
- if (BIGNUM_ZERO_P (y))
- return (y);
- if (x_length == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (x, 0));
- if (digit == 1)
- return (bignum_maybe_new_sign (y, negative_p));
- if (digit < BIGNUM_RADIX_ROOT)
- return (bignum_multiply_unsigned_small_factor (y, digit, negative_p));
- }
- if (y_length == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (y, 0));
- if (digit == 1)
- return (bignum_maybe_new_sign (x, negative_p));
- if (digit < BIGNUM_RADIX_ROOT)
- return (bignum_multiply_unsigned_small_factor (x, digit, negative_p));
- }
- return (bignum_multiply_unsigned (x, y, negative_p));
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ bignum_length_type y_length = (BIGNUM_LENGTH (y));
+ int negative_p =
+ ((BIGNUM_NEGATIVE_P (x))
+ ? (! (BIGNUM_NEGATIVE_P (y)))
+ : (BIGNUM_NEGATIVE_P (y)));
+ if (BIGNUM_ZERO_P (x))
+ return (x);
+ if (BIGNUM_ZERO_P (y))
+ return (y);
+ if (x_length == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (x, 0));
+ if (digit == 1)
+ return (bignum_maybe_new_sign (y, negative_p));
+ if (digit < BIGNUM_RADIX_ROOT)
+ return (bignum_multiply_unsigned_small_factor (y, digit, negative_p));
+ }
+ if (y_length == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (y, 0));
+ if (digit == 1)
+ return (bignum_maybe_new_sign (x, negative_p));
+ if (digit < BIGNUM_RADIX_ROOT)
+ return (bignum_multiply_unsigned_small_factor (x, digit, negative_p));
+ }
+ return (bignum_multiply_unsigned (x, y, negative_p));
}
+
/* allocates memory */
-void
-bignum_divide(bignum * numerator, bignum * denominator,
- bignum * * quotient, bignum * * remainder)
+void factorvm::bignum_divide(bignum * numerator, bignum * denominator, bignum * * quotient, bignum * * remainder)
{
- if (BIGNUM_ZERO_P (denominator))
- {
- divide_by_zero_error();
- return;
- }
- if (BIGNUM_ZERO_P (numerator))
- {
- (*quotient) = numerator;
- (*remainder) = numerator;
- }
- else
- {
- int r_negative_p = (BIGNUM_NEGATIVE_P (numerator));
- int q_negative_p =
- ((BIGNUM_NEGATIVE_P (denominator)) ? (! r_negative_p) : r_negative_p);
- switch (bignum_compare_unsigned (numerator, denominator))
- {
- case bignum_comparison_equal:
- {
- (*quotient) = (BIGNUM_ONE (q_negative_p));
- (*remainder) = (BIGNUM_ZERO ());
- break;
- }
- case bignum_comparison_less:
- {
- (*quotient) = (BIGNUM_ZERO ());
- (*remainder) = numerator;
- break;
- }
- case bignum_comparison_greater:
- {
- if ((BIGNUM_LENGTH (denominator)) == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
- if (digit == 1)
- {
- (*quotient) =
- (bignum_maybe_new_sign (numerator, q_negative_p));
- (*remainder) = (BIGNUM_ZERO ());
- break;
- }
- else if (digit < BIGNUM_RADIX_ROOT)
- {
- bignum_divide_unsigned_small_denominator
- (numerator, digit,
- quotient, remainder,
- q_negative_p, r_negative_p);
- break;
- }
- else
- {
- bignum_divide_unsigned_medium_denominator
- (numerator, digit,
- quotient, remainder,
- q_negative_p, r_negative_p);
- break;
- }
- }
- bignum_divide_unsigned_large_denominator
- (numerator, denominator,
- quotient, remainder,
- q_negative_p, r_negative_p);
- break;
- }
- }
- }
+ if (BIGNUM_ZERO_P (denominator))
+ {
+ divide_by_zero_error();
+ return;
+ }
+ if (BIGNUM_ZERO_P (numerator))
+ {
+ (*quotient) = numerator;
+ (*remainder) = numerator;
+ }
+ else
+ {
+ int r_negative_p = (BIGNUM_NEGATIVE_P (numerator));
+ int q_negative_p =
+ ((BIGNUM_NEGATIVE_P (denominator)) ? (! r_negative_p) : r_negative_p);
+ switch (bignum_compare_unsigned (numerator, denominator))
+ {
+ case bignum_comparison_equal:
+ {
+ (*quotient) = (BIGNUM_ONE (q_negative_p));
+ (*remainder) = (BIGNUM_ZERO ());
+ break;
+ }
+ case bignum_comparison_less:
+ {
+ (*quotient) = (BIGNUM_ZERO ());
+ (*remainder) = numerator;
+ break;
+ }
+ case bignum_comparison_greater:
+ {
+ if ((BIGNUM_LENGTH (denominator)) == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
+ if (digit == 1)
+ {
+ (*quotient) =
+ (bignum_maybe_new_sign (numerator, q_negative_p));
+ (*remainder) = (BIGNUM_ZERO ());
+ break;
+ }
+ else if (digit < BIGNUM_RADIX_ROOT)
+ {
+ bignum_divide_unsigned_small_denominator
+ (numerator, digit,
+ quotient, remainder,
+ q_negative_p, r_negative_p);
+ break;
+ }
+ else
+ {
+ bignum_divide_unsigned_medium_denominator
+ (numerator, digit,
+ quotient, remainder,
+ q_negative_p, r_negative_p);
+ break;
+ }
+ }
+ bignum_divide_unsigned_large_denominator
+ (numerator, denominator,
+ quotient, remainder,
+ q_negative_p, r_negative_p);
+ break;
+ }
+ }
+ }
}
+
/* allocates memory */
-bignum *
-bignum_quotient(bignum * numerator, bignum * denominator)
+bignum *factorvm::bignum_quotient(bignum * numerator, bignum * denominator)
{
- if (BIGNUM_ZERO_P (denominator))
- {
- divide_by_zero_error();
- return (BIGNUM_OUT_OF_BAND);
- }
- if (BIGNUM_ZERO_P (numerator))
- return numerator;
- {
- int q_negative_p =
- ((BIGNUM_NEGATIVE_P (denominator))
- ? (! (BIGNUM_NEGATIVE_P (numerator)))
- : (BIGNUM_NEGATIVE_P (numerator)));
- switch (bignum_compare_unsigned (numerator, denominator))
- {
- case bignum_comparison_equal:
- return (BIGNUM_ONE (q_negative_p));
- case bignum_comparison_less:
- return (BIGNUM_ZERO ());
- case bignum_comparison_greater:
- default: /* to appease gcc -Wall */
- {
- bignum * quotient;
- if ((BIGNUM_LENGTH (denominator)) == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
- if (digit == 1)
- return (bignum_maybe_new_sign (numerator, q_negative_p));
- if (digit < BIGNUM_RADIX_ROOT)
- bignum_divide_unsigned_small_denominator
- (numerator, digit,
- ("ient), ((bignum * *) 0),
- q_negative_p, 0);
- else
- bignum_divide_unsigned_medium_denominator
- (numerator, digit,
- ("ient), ((bignum * *) 0),
- q_negative_p, 0);
- }
- else
- bignum_divide_unsigned_large_denominator
- (numerator, denominator,
- ("ient), ((bignum * *) 0),
- q_negative_p, 0);
- return (quotient);
- }
- }
- }
+ if (BIGNUM_ZERO_P (denominator))
+ {
+ divide_by_zero_error();
+ return (BIGNUM_OUT_OF_BAND);
+ }
+ if (BIGNUM_ZERO_P (numerator))
+ return numerator;
+ {
+ int q_negative_p =
+ ((BIGNUM_NEGATIVE_P (denominator))
+ ? (! (BIGNUM_NEGATIVE_P (numerator)))
+ : (BIGNUM_NEGATIVE_P (numerator)));
+ switch (bignum_compare_unsigned (numerator, denominator))
+ {
+ case bignum_comparison_equal:
+ return (BIGNUM_ONE (q_negative_p));
+ case bignum_comparison_less:
+ return (BIGNUM_ZERO ());
+ case bignum_comparison_greater:
+ default: /* to appease gcc -Wall */
+ {
+ bignum * quotient;
+ if ((BIGNUM_LENGTH (denominator)) == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
+ if (digit == 1)
+ return (bignum_maybe_new_sign (numerator, q_negative_p));
+ if (digit < BIGNUM_RADIX_ROOT)
+ bignum_divide_unsigned_small_denominator
+ (numerator, digit,
+ ("ient), ((bignum * *) 0),
+ q_negative_p, 0);
+ else
+ bignum_divide_unsigned_medium_denominator
+ (numerator, digit,
+ ("ient), ((bignum * *) 0),
+ q_negative_p, 0);
+ }
+ else
+ bignum_divide_unsigned_large_denominator
+ (numerator, denominator,
+ ("ient), ((bignum * *) 0),
+ q_negative_p, 0);
+ return (quotient);
+ }
+ }
+ }
}
+
/* allocates memory */
-bignum *
-bignum_remainder(bignum * numerator, bignum * denominator)
+bignum *factorvm::bignum_remainder(bignum * numerator, bignum * denominator)
{
- if (BIGNUM_ZERO_P (denominator))
- {
- divide_by_zero_error();
- return (BIGNUM_OUT_OF_BAND);
- }
- if (BIGNUM_ZERO_P (numerator))
- return numerator;
- switch (bignum_compare_unsigned (numerator, denominator))
- {
- case bignum_comparison_equal:
- return (BIGNUM_ZERO ());
- case bignum_comparison_less:
- return numerator;
- case bignum_comparison_greater:
- default: /* to appease gcc -Wall */
- {
- bignum * remainder;
- if ((BIGNUM_LENGTH (denominator)) == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
- if (digit == 1)
- return (BIGNUM_ZERO ());
- if (digit < BIGNUM_RADIX_ROOT)
- return
- (bignum_remainder_unsigned_small_denominator
- (numerator, digit, (BIGNUM_NEGATIVE_P (numerator))));
- bignum_divide_unsigned_medium_denominator
- (numerator, digit,
- ((bignum * *) 0), (&remainder),
- 0, (BIGNUM_NEGATIVE_P (numerator)));
- }
- else
- bignum_divide_unsigned_large_denominator
- (numerator, denominator,
- ((bignum * *) 0), (&remainder),
- 0, (BIGNUM_NEGATIVE_P (numerator)));
- return (remainder);
- }
- }
+ if (BIGNUM_ZERO_P (denominator))
+ {
+ divide_by_zero_error();
+ return (BIGNUM_OUT_OF_BAND);
+ }
+ if (BIGNUM_ZERO_P (numerator))
+ return numerator;
+ switch (bignum_compare_unsigned (numerator, denominator))
+ {
+ case bignum_comparison_equal:
+ return (BIGNUM_ZERO ());
+ case bignum_comparison_less:
+ return numerator;
+ case bignum_comparison_greater:
+ default: /* to appease gcc -Wall */
+ {
+ bignum * remainder;
+ if ((BIGNUM_LENGTH (denominator)) == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
+ if (digit == 1)
+ return (BIGNUM_ZERO ());
+ if (digit < BIGNUM_RADIX_ROOT)
+ return
+ (bignum_remainder_unsigned_small_denominator
+ (numerator, digit, (BIGNUM_NEGATIVE_P (numerator))));
+ bignum_divide_unsigned_medium_denominator
+ (numerator, digit,
+ ((bignum * *) 0), (&remainder),
+ 0, (BIGNUM_NEGATIVE_P (numerator)));
+ }
+ else
+ bignum_divide_unsigned_large_denominator
+ (numerator, denominator,
+ ((bignum * *) 0), (&remainder),
+ 0, (BIGNUM_NEGATIVE_P (numerator)));
+ return (remainder);
+ }
+ }
}
-#define FOO_TO_BIGNUM(name,type,utype) \
- bignum * name##_to_bignum(type n) \
- { \
- int negative_p; \
- bignum_digit_type result_digits [BIGNUM_DIGITS_FOR(type)]; \
- bignum_digit_type * end_digits = result_digits; \
- /* Special cases win when these small constants are cached. */ \
- if (n == 0) return (BIGNUM_ZERO ()); \
- if (n == 1) return (BIGNUM_ONE (0)); \
- if (n < (type)0 && n == (type)-1) return (BIGNUM_ONE (1)); \
- { \
- utype accumulator = ((negative_p = (n < (type)0)) ? (-n) : n); \
- do \
- { \
- (*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK); \
- accumulator >>= BIGNUM_DIGIT_LENGTH; \
- } \
- while (accumulator != 0); \
- } \
- { \
- bignum * result = \
- (allot_bignum ((end_digits - result_digits), negative_p)); \
- bignum_digit_type * scan_digits = result_digits; \
- bignum_digit_type * scan_result = (BIGNUM_START_PTR (result)); \
- while (scan_digits < end_digits) \
- (*scan_result++) = (*scan_digits++); \
- return (result); \
- } \
- }
+
+#define FOO_TO_BIGNUM(name,type,utype) \
+bignum * factorvm::name##_to_bignum(type n) \
+{ \
+ int negative_p; \
+ bignum_digit_type result_digits [BIGNUM_DIGITS_FOR(type)]; \
+ bignum_digit_type * end_digits = result_digits; \
+ /* Special cases win when these small constants are cached. */ \
+ if (n == 0) return (BIGNUM_ZERO ()); \
+ if (n == 1) return (BIGNUM_ONE (0)); \
+ if (n < (type)0 && n == (type)-1) return (BIGNUM_ONE (1)); \
+ { \
+ utype accumulator = ((negative_p = (n < (type)0)) ? (-n) : n); \
+ do \
+ { \
+ (*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK); \
+ accumulator >>= BIGNUM_DIGIT_LENGTH; \
+ } \
+ while (accumulator != 0); \
+ } \
+ { \
+ bignum * result = \
+ (allot_bignum ((end_digits - result_digits), negative_p)); \
+ bignum_digit_type * scan_digits = result_digits; \
+ bignum_digit_type * scan_result = (BIGNUM_START_PTR (result)); \
+ while (scan_digits < end_digits) \
+ (*scan_result++) = (*scan_digits++); \
+ return (result); \
+ } \
+}
/* all below allocate memory */
FOO_TO_BIGNUM(cell,cell,cell)
FOO_TO_BIGNUM(long_long,s64,u64)
FOO_TO_BIGNUM(ulong_long,u64,u64)
-#define BIGNUM_TO_FOO(name,type,utype) \
- type bignum_to_##name(bignum * bignum) \
- { \
- if (BIGNUM_ZERO_P (bignum)) \
- return (0); \
- { \
- utype accumulator = 0; \
- bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); \
- bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); \
- while (start < scan) \
- accumulator = ((accumulator << BIGNUM_DIGIT_LENGTH) + (*--scan)); \
- return ((BIGNUM_NEGATIVE_P (bignum)) ? (-((type)accumulator)) : accumulator); \
- } \
- }
+#define BIGNUM_TO_FOO(name,type,utype) \
+ type factorvm::bignum_to_##name(bignum * bignum) \
+ { \
+ if (BIGNUM_ZERO_P (bignum)) \
+ return (0); \
+ { \
+ utype accumulator = 0; \
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); \
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); \
+ while (start < scan) \
+ accumulator = ((accumulator << BIGNUM_DIGIT_LENGTH) + (*--scan)); \
+ return ((BIGNUM_NEGATIVE_P (bignum)) ? (-((type)accumulator)) : accumulator); \
+ } \
+ }
/* all of the below allocate memory */
BIGNUM_TO_FOO(cell,cell,cell);
BIGNUM_TO_FOO(long_long,s64,u64)
BIGNUM_TO_FOO(ulong_long,u64,u64)
-double
-bignum_to_double(bignum * bignum)
+double factorvm::bignum_to_double(bignum * bignum)
{
- if (BIGNUM_ZERO_P (bignum))
- return (0);
- {
- double accumulator = 0;
- bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
- bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
- while (start < scan)
- accumulator = ((accumulator * BIGNUM_RADIX) + (*--scan));
- return ((BIGNUM_NEGATIVE_P (bignum)) ? (-accumulator) : accumulator);
- }
+ if (BIGNUM_ZERO_P (bignum))
+ return (0);
+ {
+ double accumulator = 0;
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
+ while (start < scan)
+ accumulator = ((accumulator * BIGNUM_RADIX) + (*--scan));
+ return ((BIGNUM_NEGATIVE_P (bignum)) ? (-accumulator) : accumulator);
+ }
}
-#define DTB_WRITE_DIGIT(factor) \
-{ \
- significand *= (factor); \
- digit = ((bignum_digit_type) significand); \
- (*--scan) = digit; \
- significand -= ((double) digit); \
+
+#define DTB_WRITE_DIGIT(factor) \
+{ \
+ significand *= (factor); \
+ digit = ((bignum_digit_type) significand); \
+ (*--scan) = digit; \
+ significand -= ((double) digit); \
}
/* allocates memory */
#define inf std::numeric_limits<double>::infinity()
-bignum *
-double_to_bignum(double x)
+bignum *factorvm::double_to_bignum(double x)
{
- if (x == inf || x == -inf || x != x) return (BIGNUM_ZERO ());
- int exponent;
- double significand = (frexp (x, (&exponent)));
- if (exponent <= 0) return (BIGNUM_ZERO ());
- if (exponent == 1) return (BIGNUM_ONE (x < 0));
- if (significand < 0) significand = (-significand);
- {
- bignum_length_type length = (BIGNUM_BITS_TO_DIGITS (exponent));
- bignum * result = (allot_bignum (length, (x < 0)));
- bignum_digit_type * start = (BIGNUM_START_PTR (result));
- bignum_digit_type * scan = (start + length);
- bignum_digit_type digit;
- int odd_bits = (exponent % BIGNUM_DIGIT_LENGTH);
- if (odd_bits > 0)
- DTB_WRITE_DIGIT ((fixnum)1 << odd_bits);
- while (start < scan)
- {
- if (significand == 0)
- {
- while (start < scan)
- (*--scan) = 0;
- break;
- }
- DTB_WRITE_DIGIT (BIGNUM_RADIX);
- }
- return (result);
- }
+ if (x == inf || x == -inf || x != x) return (BIGNUM_ZERO ());
+ int exponent;
+ double significand = (frexp (x, (&exponent)));
+ if (exponent <= 0) return (BIGNUM_ZERO ());
+ if (exponent == 1) return (BIGNUM_ONE (x < 0));
+ if (significand < 0) significand = (-significand);
+ {
+ bignum_length_type length = (BIGNUM_BITS_TO_DIGITS (exponent));
+ bignum * result = (allot_bignum (length, (x < 0)));
+ bignum_digit_type * start = (BIGNUM_START_PTR (result));
+ bignum_digit_type * scan = (start + length);
+ bignum_digit_type digit;
+ int odd_bits = (exponent % BIGNUM_DIGIT_LENGTH);
+ if (odd_bits > 0)
+ DTB_WRITE_DIGIT ((fixnum)1 << odd_bits);
+ while (start < scan)
+ {
+ if (significand == 0)
+ {
+ while (start < scan)
+ (*--scan) = 0;
+ break;
+ }
+ DTB_WRITE_DIGIT (BIGNUM_RADIX);
+ }
+ return (result);
+ }
}
+
#undef DTB_WRITE_DIGIT
/* Comparisons */
-int
-bignum_equal_p_unsigned(bignum * x, bignum * y)
+int factorvm::bignum_equal_p_unsigned(bignum * x, bignum * y)
{
- bignum_length_type length = (BIGNUM_LENGTH (x));
- if (length != (BIGNUM_LENGTH (y)))
- return (0);
- else
- {
- bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
- bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
- bignum_digit_type * end_x = (scan_x + length);
- while (scan_x < end_x)
- if ((*scan_x++) != (*scan_y++))
- return (0);
- return (1);
- }
+ bignum_length_type length = (BIGNUM_LENGTH (x));
+ if (length != (BIGNUM_LENGTH (y)))
+ return (0);
+ else
+ {
+ bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
+ bignum_digit_type * end_x = (scan_x + length);
+ while (scan_x < end_x)
+ if ((*scan_x++) != (*scan_y++))
+ return (0);
+ return (1);
+ }
}
-enum bignum_comparison
-bignum_compare_unsigned(bignum * x, bignum * y)
+
+enum bignum_comparison factorvm::bignum_compare_unsigned(bignum * x, bignum * y)
{
- bignum_length_type x_length = (BIGNUM_LENGTH (x));
- bignum_length_type y_length = (BIGNUM_LENGTH (y));
- if (x_length < y_length)
- return (bignum_comparison_less);
- if (x_length > y_length)
- return (bignum_comparison_greater);
- {
- bignum_digit_type * start_x = (BIGNUM_START_PTR (x));
- bignum_digit_type * scan_x = (start_x + x_length);
- bignum_digit_type * scan_y = ((BIGNUM_START_PTR (y)) + y_length);
- while (start_x < scan_x)
- {
- bignum_digit_type digit_x = (*--scan_x);
- bignum_digit_type digit_y = (*--scan_y);
- if (digit_x < digit_y)
- return (bignum_comparison_less);
- if (digit_x > digit_y)
- return (bignum_comparison_greater);
- }
- }
- return (bignum_comparison_equal);
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ bignum_length_type y_length = (BIGNUM_LENGTH (y));
+ if (x_length < y_length)
+ return (bignum_comparison_less);
+ if (x_length > y_length)
+ return (bignum_comparison_greater);
+ {
+ bignum_digit_type * start_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * scan_x = (start_x + x_length);
+ bignum_digit_type * scan_y = ((BIGNUM_START_PTR (y)) + y_length);
+ while (start_x < scan_x)
+ {
+ bignum_digit_type digit_x = (*--scan_x);
+ bignum_digit_type digit_y = (*--scan_y);
+ if (digit_x < digit_y)
+ return (bignum_comparison_less);
+ if (digit_x > digit_y)
+ return (bignum_comparison_greater);
+ }
+ }
+ return (bignum_comparison_equal);
}
+
/* Addition */
/* allocates memory */
-bignum *
-bignum_add_unsigned(bignum * x, bignum * y, int negative_p)
+bignum *factorvm::bignum_add_unsigned(bignum * x, bignum * y, int negative_p)
{
- GC_BIGNUM(x); GC_BIGNUM(y);
-
- if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
- {
- bignum * z = x;
- x = y;
- y = z;
- }
- {
- bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ GC_BIGNUM(x,this); GC_BIGNUM(y,this);
+
+ if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
+ {
+ bignum * z = x;
+ x = y;
+ y = z;
+ }
+ {
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
- bignum * r = (allot_bignum ((x_length + 1), negative_p));
-
- bignum_digit_type sum;
- bignum_digit_type carry = 0;
- bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
- bignum_digit_type * scan_r = (BIGNUM_START_PTR (r));
- {
- bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
- bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));
- while (scan_y < end_y)
- {
- sum = ((*scan_x++) + (*scan_y++) + carry);
- if (sum < BIGNUM_RADIX)
- {
- (*scan_r++) = sum;
- carry = 0;
- }
- else
- {
- (*scan_r++) = (sum - BIGNUM_RADIX);
- carry = 1;
- }
- }
- }
- {
- bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
- if (carry != 0)
- while (scan_x < end_x)
- {
- sum = ((*scan_x++) + 1);
- if (sum < BIGNUM_RADIX)
- {
- (*scan_r++) = sum;
- carry = 0;
- break;
- }
- else
- (*scan_r++) = (sum - BIGNUM_RADIX);
- }
- while (scan_x < end_x)
- (*scan_r++) = (*scan_x++);
- }
- if (carry != 0)
- {
- (*scan_r) = 1;
- return (r);
- }
- return (bignum_shorten_length (r, x_length));
- }
+ bignum * r = (allot_bignum ((x_length + 1), negative_p));
+
+ bignum_digit_type sum;
+ bignum_digit_type carry = 0;
+ bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * scan_r = (BIGNUM_START_PTR (r));
+ {
+ bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
+ bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));
+ while (scan_y < end_y)
+ {
+ sum = ((*scan_x++) + (*scan_y++) + carry);
+ if (sum < BIGNUM_RADIX)
+ {
+ (*scan_r++) = sum;
+ carry = 0;
+ }
+ else
+ {
+ (*scan_r++) = (sum - BIGNUM_RADIX);
+ carry = 1;
+ }
+ }
+ }
+ {
+ bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
+ if (carry != 0)
+ while (scan_x < end_x)
+ {
+ sum = ((*scan_x++) + 1);
+ if (sum < BIGNUM_RADIX)
+ {
+ (*scan_r++) = sum;
+ carry = 0;
+ break;
+ }
+ else
+ (*scan_r++) = (sum - BIGNUM_RADIX);
+ }
+ while (scan_x < end_x)
+ (*scan_r++) = (*scan_x++);
+ }
+ if (carry != 0)
+ {
+ (*scan_r) = 1;
+ return (r);
+ }
+ return (bignum_shorten_length (r, x_length));
+ }
}
+
/* Subtraction */
/* allocates memory */
-bignum *
-bignum_subtract_unsigned(bignum * x, bignum * y)
+bignum *factorvm::bignum_subtract_unsigned(bignum * x, bignum * y)
{
- GC_BIGNUM(x); GC_BIGNUM(y);
+ GC_BIGNUM(x,this); GC_BIGNUM(y,this);
- int negative_p = 0;
- switch (bignum_compare_unsigned (x, y))
- {
- case bignum_comparison_equal:
- return (BIGNUM_ZERO ());
- case bignum_comparison_less:
- {
- bignum * z = x;
- x = y;
- y = z;
- }
- negative_p = 1;
- break;
- case bignum_comparison_greater:
- negative_p = 0;
- break;
- }
- {
- bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ int negative_p = 0;
+ switch (bignum_compare_unsigned (x, y))
+ {
+ case bignum_comparison_equal:
+ return (BIGNUM_ZERO ());
+ case bignum_comparison_less:
+ {
+ bignum * z = x;
+ x = y;
+ y = z;
+ }
+ negative_p = 1;
+ break;
+ case bignum_comparison_greater:
+ negative_p = 0;
+ break;
+ }
+ {
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
- bignum * r = (allot_bignum (x_length, negative_p));
-
- bignum_digit_type difference;
- bignum_digit_type borrow = 0;
- bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
- bignum_digit_type * scan_r = (BIGNUM_START_PTR (r));
- {
- bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
- bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));
- while (scan_y < end_y)
- {
- difference = (((*scan_x++) - (*scan_y++)) - borrow);
- if (difference < 0)
- {
- (*scan_r++) = (difference + BIGNUM_RADIX);
- borrow = 1;
- }
- else
- {
- (*scan_r++) = difference;
- borrow = 0;
- }
- }
- }
- {
- bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
- if (borrow != 0)
- while (scan_x < end_x)
- {
- difference = ((*scan_x++) - borrow);
- if (difference < 0)
- (*scan_r++) = (difference + BIGNUM_RADIX);
- else
- {
- (*scan_r++) = difference;
- borrow = 0;
- break;
- }
- }
- BIGNUM_ASSERT (borrow == 0);
- while (scan_x < end_x)
- (*scan_r++) = (*scan_x++);
- }
- return (bignum_trim (r));
- }
+ bignum * r = (allot_bignum (x_length, negative_p));
+
+ bignum_digit_type difference;
+ bignum_digit_type borrow = 0;
+ bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * scan_r = (BIGNUM_START_PTR (r));
+ {
+ bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
+ bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));
+ while (scan_y < end_y)
+ {
+ difference = (((*scan_x++) - (*scan_y++)) - borrow);
+ if (difference < 0)
+ {
+ (*scan_r++) = (difference + BIGNUM_RADIX);
+ borrow = 1;
+ }
+ else
+ {
+ (*scan_r++) = difference;
+ borrow = 0;
+ }
+ }
+ }
+ {
+ bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
+ if (borrow != 0)
+ while (scan_x < end_x)
+ {
+ difference = ((*scan_x++) - borrow);
+ if (difference < 0)
+ (*scan_r++) = (difference + BIGNUM_RADIX);
+ else
+ {
+ (*scan_r++) = difference;
+ borrow = 0;
+ break;
+ }
+ }
+ BIGNUM_ASSERT (borrow == 0);
+ while (scan_x < end_x)
+ (*scan_r++) = (*scan_x++);
+ }
+ return (bignum_trim (r));
+ }
}
+
/* Multiplication
Maximum value for product_low or product_high:
- ((R * R) + (R * (R - 2)) + (R - 1))
+ ((R * R) + (R * (R - 2)) + (R - 1))
Maximum value for carry: ((R * (R - 1)) + (R - 1))
- where R == BIGNUM_RADIX_ROOT */
+ where R == BIGNUM_RADIX_ROOT */
/* allocates memory */
-bignum *
-bignum_multiply_unsigned(bignum * x, bignum * y, int negative_p)
+bignum *factorvm::bignum_multiply_unsigned(bignum * x, bignum * y, int negative_p)
{
- GC_BIGNUM(x); GC_BIGNUM(y);
-
- if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
- {
- bignum * z = x;
- x = y;
- y = z;
- }
- {
- bignum_digit_type carry;
- bignum_digit_type y_digit_low;
- bignum_digit_type y_digit_high;
- bignum_digit_type x_digit_low;
- bignum_digit_type x_digit_high;
- bignum_digit_type product_low;
- bignum_digit_type * scan_r;
- bignum_digit_type * scan_y;
- bignum_length_type x_length = (BIGNUM_LENGTH (x));
- bignum_length_type y_length = (BIGNUM_LENGTH (y));
-
- bignum * r =
- (allot_bignum_zeroed ((x_length + y_length), negative_p));
-
- bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
- bignum_digit_type * end_x = (scan_x + x_length);
- bignum_digit_type * start_y = (BIGNUM_START_PTR (y));
- bignum_digit_type * end_y = (start_y + y_length);
- bignum_digit_type * start_r = (BIGNUM_START_PTR (r));
+ GC_BIGNUM(x,this); GC_BIGNUM(y,this);
+
+ if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
+ {
+ bignum * z = x;
+ x = y;
+ y = z;
+ }
+ {
+ bignum_digit_type carry;
+ bignum_digit_type y_digit_low;
+ bignum_digit_type y_digit_high;
+ bignum_digit_type x_digit_low;
+ bignum_digit_type x_digit_high;
+ bignum_digit_type product_low;
+ bignum_digit_type * scan_r;
+ bignum_digit_type * scan_y;
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ bignum_length_type y_length = (BIGNUM_LENGTH (y));
+
+ bignum * r =
+ (allot_bignum_zeroed ((x_length + y_length), negative_p));
+
+ bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * end_x = (scan_x + x_length);
+ bignum_digit_type * start_y = (BIGNUM_START_PTR (y));
+ bignum_digit_type * end_y = (start_y + y_length);
+ bignum_digit_type * start_r = (BIGNUM_START_PTR (r));
#define x_digit x_digit_high
#define y_digit y_digit_high
#define product_high carry
- while (scan_x < end_x)
- {
- x_digit = (*scan_x++);
- x_digit_low = (HD_LOW (x_digit));
- x_digit_high = (HD_HIGH (x_digit));
- carry = 0;
- scan_y = start_y;
- scan_r = (start_r++);
- while (scan_y < end_y)
- {
- y_digit = (*scan_y++);
- y_digit_low = (HD_LOW (y_digit));
- y_digit_high = (HD_HIGH (y_digit));
- product_low =
- ((*scan_r) +
- (x_digit_low * y_digit_low) +
- (HD_LOW (carry)));
- product_high =
- ((x_digit_high * y_digit_low) +
- (x_digit_low * y_digit_high) +
- (HD_HIGH (product_low)) +
- (HD_HIGH (carry)));
- (*scan_r++) =
- (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
- carry =
- ((x_digit_high * y_digit_high) +
- (HD_HIGH (product_high)));
- }
- (*scan_r) += carry;
- }
- return (bignum_trim (r));
+ while (scan_x < end_x)
+ {
+ x_digit = (*scan_x++);
+ x_digit_low = (HD_LOW (x_digit));
+ x_digit_high = (HD_HIGH (x_digit));
+ carry = 0;
+ scan_y = start_y;
+ scan_r = (start_r++);
+ while (scan_y < end_y)
+ {
+ y_digit = (*scan_y++);
+ y_digit_low = (HD_LOW (y_digit));
+ y_digit_high = (HD_HIGH (y_digit));
+ product_low =
+ ((*scan_r) +
+ (x_digit_low * y_digit_low) +
+ (HD_LOW (carry)));
+ product_high =
+ ((x_digit_high * y_digit_low) +
+ (x_digit_low * y_digit_high) +
+ (HD_HIGH (product_low)) +
+ (HD_HIGH (carry)));
+ (*scan_r++) =
+ (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
+ carry =
+ ((x_digit_high * y_digit_high) +
+ (HD_HIGH (product_high)));
+ }
+ (*scan_r) += carry;
+ }
+ return (bignum_trim (r));
#undef x_digit
#undef y_digit
#undef product_high
- }
+ }
}
+
/* allocates memory */
-bignum *
-bignum_multiply_unsigned_small_factor(bignum * x, bignum_digit_type y,
- int negative_p)
+bignum *factorvm::bignum_multiply_unsigned_small_factor(bignum * x, bignum_digit_type y,int negative_p)
{
- GC_BIGNUM(x);
+ GC_BIGNUM(x,this);
- bignum_length_type length_x = (BIGNUM_LENGTH (x));
+ bignum_length_type length_x = (BIGNUM_LENGTH (x));
- bignum * p = (allot_bignum ((length_x + 1), negative_p));
+ bignum * p = (allot_bignum ((length_x + 1), negative_p));
- bignum_destructive_copy (x, p);
- (BIGNUM_REF (p, length_x)) = 0;
- bignum_destructive_scale_up (p, y);
- return (bignum_trim (p));
+ bignum_destructive_copy (x, p);
+ (BIGNUM_REF (p, length_x)) = 0;
+ bignum_destructive_scale_up (p, y);
+ return (bignum_trim (p));
}
-void
-bignum_destructive_add(bignum * bignum, bignum_digit_type n)
+
+void factorvm::bignum_destructive_add(bignum * bignum, bignum_digit_type n)
{
- bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
- bignum_digit_type digit;
- digit = ((*scan) + n);
- if (digit < BIGNUM_RADIX)
- {
- (*scan) = digit;
- return;
- }
- (*scan++) = (digit - BIGNUM_RADIX);
- while (1)
- {
- digit = ((*scan) + 1);
- if (digit < BIGNUM_RADIX)
- {
- (*scan) = digit;
- return;
- }
- (*scan++) = (digit - BIGNUM_RADIX);
- }
+ bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type digit;
+ digit = ((*scan) + n);
+ if (digit < BIGNUM_RADIX)
+ {
+ (*scan) = digit;
+ return;
+ }
+ (*scan++) = (digit - BIGNUM_RADIX);
+ while (1)
+ {
+ digit = ((*scan) + 1);
+ if (digit < BIGNUM_RADIX)
+ {
+ (*scan) = digit;
+ return;
+ }
+ (*scan++) = (digit - BIGNUM_RADIX);
+ }
}
-void
-bignum_destructive_scale_up(bignum * bignum, bignum_digit_type factor)
+
+void factorvm::bignum_destructive_scale_up(bignum * bignum, bignum_digit_type factor)
{
- bignum_digit_type carry = 0;
- bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
- bignum_digit_type two_digits;
- bignum_digit_type product_low;
+ bignum_digit_type carry = 0;
+ bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type two_digits;
+ bignum_digit_type product_low;
#define product_high carry
- bignum_digit_type * end = (scan + (BIGNUM_LENGTH (bignum)));
- BIGNUM_ASSERT ((factor > 1) && (factor < BIGNUM_RADIX_ROOT));
- while (scan < end)
- {
- two_digits = (*scan);
- product_low = ((factor * (HD_LOW (two_digits))) + (HD_LOW (carry)));
- product_high =
- ((factor * (HD_HIGH (two_digits))) +
- (HD_HIGH (product_low)) +
- (HD_HIGH (carry)));
- (*scan++) = (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
- carry = (HD_HIGH (product_high));
- }
- /* A carry here would be an overflow, i.e. it would not fit.
- Hopefully the callers allocate enough space that this will
- never happen.
- */
- BIGNUM_ASSERT (carry == 0);
- return;
+ bignum_digit_type * end = (scan + (BIGNUM_LENGTH (bignum)));
+ BIGNUM_ASSERT ((factor > 1) && (factor < BIGNUM_RADIX_ROOT));
+ while (scan < end)
+ {
+ two_digits = (*scan);
+ product_low = ((factor * (HD_LOW (two_digits))) + (HD_LOW (carry)));
+ product_high =
+ ((factor * (HD_HIGH (two_digits))) +
+ (HD_HIGH (product_low)) +
+ (HD_HIGH (carry)));
+ (*scan++) = (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
+ carry = (HD_HIGH (product_high));
+ }
+ /* A carry here would be an overflow, i.e. it would not fit.
+ Hopefully the callers allocate enough space that this will
+ never happen.
+ */
+ BIGNUM_ASSERT (carry == 0);
+ return;
#undef product_high
}
+
/* Division */
/* For help understanding this algorithm, see:
section 4.3.1, "Multiple-Precision Arithmetic". */
/* allocates memory */
-void
-bignum_divide_unsigned_large_denominator(bignum * numerator,
- bignum * denominator,
- bignum * * quotient,
- bignum * * remainder,
- int q_negative_p,
- int r_negative_p)
+void factorvm::bignum_divide_unsigned_large_denominator(bignum * numerator, bignum * denominator, bignum * * quotient, bignum * * remainder, int q_negative_p, int r_negative_p)
{
- GC_BIGNUM(numerator); GC_BIGNUM(denominator);
+ GC_BIGNUM(numerator,this); GC_BIGNUM(denominator,this);
- bignum_length_type length_n = ((BIGNUM_LENGTH (numerator)) + 1);
- bignum_length_type length_d = (BIGNUM_LENGTH (denominator));
-
- bignum * q =
- ((quotient != ((bignum * *) 0))
- ? (allot_bignum ((length_n - length_d), q_negative_p))
- : BIGNUM_OUT_OF_BAND);
- GC_BIGNUM(q);
+ bignum_length_type length_n = ((BIGNUM_LENGTH (numerator)) + 1);
+ bignum_length_type length_d = (BIGNUM_LENGTH (denominator));
+
+ bignum * q =
+ ((quotient != ((bignum * *) 0))
+ ? (allot_bignum ((length_n - length_d), q_negative_p))
+ : BIGNUM_OUT_OF_BAND);
+ GC_BIGNUM(q,this);
- bignum * u = (allot_bignum (length_n, r_negative_p));
- GC_BIGNUM(u);
+ bignum * u = (allot_bignum (length_n, r_negative_p));
+ GC_BIGNUM(u,this);
- int shift = 0;
- BIGNUM_ASSERT (length_d > 1);
- {
- bignum_digit_type v1 = (BIGNUM_REF ((denominator), (length_d - 1)));
- while (v1 < (BIGNUM_RADIX / 2))
- {
- v1 <<= 1;
- shift += 1;
- }
- }
- if (shift == 0)
- {
- bignum_destructive_copy (numerator, u);
- (BIGNUM_REF (u, (length_n - 1))) = 0;
- bignum_divide_unsigned_normalized (u, denominator, q);
- }
- else
- {
- bignum * v = (allot_bignum (length_d, 0));
-
- bignum_destructive_normalization (numerator, u, shift);
- bignum_destructive_normalization (denominator, v, shift);
- bignum_divide_unsigned_normalized (u, v, q);
- if (remainder != ((bignum * *) 0))
- bignum_destructive_unnormalization (u, shift);
- }
-
- if(q)
- q = bignum_trim (q);
-
- u = bignum_trim (u);
-
- if (quotient != ((bignum * *) 0))
- (*quotient) = q;
-
- if (remainder != ((bignum * *) 0))
- (*remainder) = u;
-
- return;
+ int shift = 0;
+ BIGNUM_ASSERT (length_d > 1);
+ {
+ bignum_digit_type v1 = (BIGNUM_REF ((denominator), (length_d - 1)));
+ while (v1 < (BIGNUM_RADIX / 2))
+ {
+ v1 <<= 1;
+ shift += 1;
+ }
+ }
+ if (shift == 0)
+ {
+ bignum_destructive_copy (numerator, u);
+ (BIGNUM_REF (u, (length_n - 1))) = 0;
+ bignum_divide_unsigned_normalized (u, denominator, q);
+ }
+ else
+ {
+ bignum * v = (allot_bignum (length_d, 0));
+
+ bignum_destructive_normalization (numerator, u, shift);
+ bignum_destructive_normalization (denominator, v, shift);
+ bignum_divide_unsigned_normalized (u, v, q);
+ if (remainder != ((bignum * *) 0))
+ bignum_destructive_unnormalization (u, shift);
+ }
+
+ if(q)
+ q = bignum_trim (q);
+
+ u = bignum_trim (u);
+
+ if (quotient != ((bignum * *) 0))
+ (*quotient) = q;
+
+ if (remainder != ((bignum * *) 0))
+ (*remainder) = u;
+
+ return;
}
-void
-bignum_divide_unsigned_normalized(bignum * u, bignum * v, bignum * q)
+
+void factorvm::bignum_divide_unsigned_normalized(bignum * u, bignum * v, bignum * q)
{
- bignum_length_type u_length = (BIGNUM_LENGTH (u));
- bignum_length_type v_length = (BIGNUM_LENGTH (v));
- bignum_digit_type * u_start = (BIGNUM_START_PTR (u));
- bignum_digit_type * u_scan = (u_start + u_length);
- bignum_digit_type * u_scan_limit = (u_start + v_length);
- bignum_digit_type * u_scan_start = (u_scan - v_length);
- bignum_digit_type * v_start = (BIGNUM_START_PTR (v));
- bignum_digit_type * v_end = (v_start + v_length);
- bignum_digit_type * q_scan = NULL;
- bignum_digit_type v1 = (v_end[-1]);
- bignum_digit_type v2 = (v_end[-2]);
- bignum_digit_type ph; /* high half of double-digit product */
- bignum_digit_type pl; /* low half of double-digit product */
- bignum_digit_type guess;
- bignum_digit_type gh; /* high half-digit of guess */
- bignum_digit_type ch; /* high half of double-digit comparand */
- bignum_digit_type v2l = (HD_LOW (v2));
- bignum_digit_type v2h = (HD_HIGH (v2));
- bignum_digit_type cl; /* low half of double-digit comparand */
+ bignum_length_type u_length = (BIGNUM_LENGTH (u));
+ bignum_length_type v_length = (BIGNUM_LENGTH (v));
+ bignum_digit_type * u_start = (BIGNUM_START_PTR (u));
+ bignum_digit_type * u_scan = (u_start + u_length);
+ bignum_digit_type * u_scan_limit = (u_start + v_length);
+ bignum_digit_type * u_scan_start = (u_scan - v_length);
+ bignum_digit_type * v_start = (BIGNUM_START_PTR (v));
+ bignum_digit_type * v_end = (v_start + v_length);
+ bignum_digit_type * q_scan = NULL;
+ bignum_digit_type v1 = (v_end[-1]);
+ bignum_digit_type v2 = (v_end[-2]);
+ bignum_digit_type ph; /* high half of double-digit product */
+ bignum_digit_type pl; /* low half of double-digit product */
+ bignum_digit_type guess;
+ bignum_digit_type gh; /* high half-digit of guess */
+ bignum_digit_type ch; /* high half of double-digit comparand */
+ bignum_digit_type v2l = (HD_LOW (v2));
+ bignum_digit_type v2h = (HD_HIGH (v2));
+ bignum_digit_type cl; /* low half of double-digit comparand */
#define gl ph /* low half-digit of guess */
#define uj pl
#define qj ph
- bignum_digit_type gm; /* memory loc for reference parameter */
- if (q != BIGNUM_OUT_OF_BAND)
- q_scan = ((BIGNUM_START_PTR (q)) + (BIGNUM_LENGTH (q)));
- while (u_scan_limit < u_scan)
- {
- uj = (*--u_scan);
- if (uj != v1)
- {
- /* comparand =
- (((((uj * BIGNUM_RADIX) + uj1) % v1) * BIGNUM_RADIX) + uj2);
- guess = (((uj * BIGNUM_RADIX) + uj1) / v1); */
- cl = (u_scan[-2]);
- ch = (bignum_digit_divide (uj, (u_scan[-1]), v1, (&gm)));
- guess = gm;
- }
- else
- {
- cl = (u_scan[-2]);
- ch = ((u_scan[-1]) + v1);
- guess = (BIGNUM_RADIX - 1);
- }
- while (1)
- {
- /* product = (guess * v2); */
- gl = (HD_LOW (guess));
- gh = (HD_HIGH (guess));
- pl = (v2l * gl);
- ph = ((v2l * gh) + (v2h * gl) + (HD_HIGH (pl)));
- pl = (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl))));
- ph = ((v2h * gh) + (HD_HIGH (ph)));
- /* if (comparand >= product) */
- if ((ch > ph) || ((ch == ph) && (cl >= pl)))
- break;
- guess -= 1;
- /* comparand += (v1 << BIGNUM_DIGIT_LENGTH) */
- ch += v1;
- /* if (comparand >= (BIGNUM_RADIX * BIGNUM_RADIX)) */
- if (ch >= BIGNUM_RADIX)
- break;
- }
- qj = (bignum_divide_subtract (v_start, v_end, guess, (--u_scan_start)));
- if (q != BIGNUM_OUT_OF_BAND)
- (*--q_scan) = qj;
- }
- return;
+ bignum_digit_type gm; /* memory loc for reference parameter */
+ if (q != BIGNUM_OUT_OF_BAND)
+ q_scan = ((BIGNUM_START_PTR (q)) + (BIGNUM_LENGTH (q)));
+ while (u_scan_limit < u_scan)
+ {
+ uj = (*--u_scan);
+ if (uj != v1)
+ {
+ /* comparand =
+ (((((uj * BIGNUM_RADIX) + uj1) % v1) * BIGNUM_RADIX) + uj2);
+ guess = (((uj * BIGNUM_RADIX) + uj1) / v1); */
+ cl = (u_scan[-2]);
+ ch = (bignum_digit_divide (uj, (u_scan[-1]), v1, (&gm)));
+ guess = gm;
+ }
+ else
+ {
+ cl = (u_scan[-2]);
+ ch = ((u_scan[-1]) + v1);
+ guess = (BIGNUM_RADIX - 1);
+ }
+ while (1)
+ {
+ /* product = (guess * v2); */
+ gl = (HD_LOW (guess));
+ gh = (HD_HIGH (guess));
+ pl = (v2l * gl);
+ ph = ((v2l * gh) + (v2h * gl) + (HD_HIGH (pl)));
+ pl = (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl))));
+ ph = ((v2h * gh) + (HD_HIGH (ph)));
+ /* if (comparand >= product) */
+ if ((ch > ph) || ((ch == ph) && (cl >= pl)))
+ break;
+ guess -= 1;
+ /* comparand += (v1 << BIGNUM_DIGIT_LENGTH) */
+ ch += v1;
+ /* if (comparand >= (BIGNUM_RADIX * BIGNUM_RADIX)) */
+ if (ch >= BIGNUM_RADIX)
+ break;
+ }
+ qj = (bignum_divide_subtract (v_start, v_end, guess, (--u_scan_start)));
+ if (q != BIGNUM_OUT_OF_BAND)
+ (*--q_scan) = qj;
+ }
+ return;
#undef gl
#undef uj
#undef qj
}
-bignum_digit_type
-bignum_divide_subtract(bignum_digit_type * v_start,
- bignum_digit_type * v_end,
- bignum_digit_type guess,
- bignum_digit_type * u_start)
+
+bignum_digit_type factorvm::bignum_divide_subtract(bignum_digit_type * v_start, bignum_digit_type * v_end, bignum_digit_type guess, bignum_digit_type * u_start)
{
- bignum_digit_type * v_scan = v_start;
- bignum_digit_type * u_scan = u_start;
- bignum_digit_type carry = 0;
- if (guess == 0) return (0);
- {
- bignum_digit_type gl = (HD_LOW (guess));
- bignum_digit_type gh = (HD_HIGH (guess));
- bignum_digit_type v;
- bignum_digit_type pl;
- bignum_digit_type vl;
+ bignum_digit_type * v_scan = v_start;
+ bignum_digit_type * u_scan = u_start;
+ bignum_digit_type carry = 0;
+ if (guess == 0) return (0);
+ {
+ bignum_digit_type gl = (HD_LOW (guess));
+ bignum_digit_type gh = (HD_HIGH (guess));
+ bignum_digit_type v;
+ bignum_digit_type pl;
+ bignum_digit_type vl;
#define vh v
#define ph carry
#define diff pl
- while (v_scan < v_end)
- {
- v = (*v_scan++);
- vl = (HD_LOW (v));
- vh = (HD_HIGH (v));
- pl = ((vl * gl) + (HD_LOW (carry)));
- ph = ((vl * gh) + (vh * gl) + (HD_HIGH (pl)) + (HD_HIGH (carry)));
- diff = ((*u_scan) - (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl)))));
- if (diff < 0)
- {
- (*u_scan++) = (diff + BIGNUM_RADIX);
- carry = ((vh * gh) + (HD_HIGH (ph)) + 1);
- }
- else
- {
- (*u_scan++) = diff;
- carry = ((vh * gh) + (HD_HIGH (ph)));
- }
- }
- if (carry == 0)
- return (guess);
- diff = ((*u_scan) - carry);
- if (diff < 0)
- (*u_scan) = (diff + BIGNUM_RADIX);
- else
- {
- (*u_scan) = diff;
- return (guess);
- }
+ while (v_scan < v_end)
+ {
+ v = (*v_scan++);
+ vl = (HD_LOW (v));
+ vh = (HD_HIGH (v));
+ pl = ((vl * gl) + (HD_LOW (carry)));
+ ph = ((vl * gh) + (vh * gl) + (HD_HIGH (pl)) + (HD_HIGH (carry)));
+ diff = ((*u_scan) - (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl)))));
+ if (diff < 0)
+ {
+ (*u_scan++) = (diff + BIGNUM_RADIX);
+ carry = ((vh * gh) + (HD_HIGH (ph)) + 1);
+ }
+ else
+ {
+ (*u_scan++) = diff;
+ carry = ((vh * gh) + (HD_HIGH (ph)));
+ }
+ }
+ if (carry == 0)
+ return (guess);
+ diff = ((*u_scan) - carry);
+ if (diff < 0)
+ (*u_scan) = (diff + BIGNUM_RADIX);
+ else
+ {
+ (*u_scan) = diff;
+ return (guess);
+ }
#undef vh
#undef ph
#undef diff
- }
- /* Subtraction generated carry, implying guess is one too large.
- Add v back in to bring it back down. */
- v_scan = v_start;
- u_scan = u_start;
- carry = 0;
- while (v_scan < v_end)
- {
- bignum_digit_type sum = ((*v_scan++) + (*u_scan) + carry);
- if (sum < BIGNUM_RADIX)
- {
- (*u_scan++) = sum;
- carry = 0;
- }
- else
- {
- (*u_scan++) = (sum - BIGNUM_RADIX);
- carry = 1;
- }
- }
- if (carry == 1)
- {
- bignum_digit_type sum = ((*u_scan) + carry);
- (*u_scan) = ((sum < BIGNUM_RADIX) ? sum : (sum - BIGNUM_RADIX));
- }
- return (guess - 1);
+ }
+ /* Subtraction generated carry, implying guess is one too large.
+ Add v back in to bring it back down. */
+ v_scan = v_start;
+ u_scan = u_start;
+ carry = 0;
+ while (v_scan < v_end)
+ {
+ bignum_digit_type sum = ((*v_scan++) + (*u_scan) + carry);
+ if (sum < BIGNUM_RADIX)
+ {
+ (*u_scan++) = sum;
+ carry = 0;
+ }
+ else
+ {
+ (*u_scan++) = (sum - BIGNUM_RADIX);
+ carry = 1;
+ }
+ }
+ if (carry == 1)
+ {
+ bignum_digit_type sum = ((*u_scan) + carry);
+ (*u_scan) = ((sum < BIGNUM_RADIX) ? sum : (sum - BIGNUM_RADIX));
+ }
+ return (guess - 1);
}
+
/* allocates memory */
-void
-bignum_divide_unsigned_medium_denominator(bignum * numerator,
- bignum_digit_type denominator,
- bignum * * quotient,
- bignum * * remainder,
- int q_negative_p,
- int r_negative_p)
+void factorvm::bignum_divide_unsigned_medium_denominator(bignum * numerator,bignum_digit_type denominator, bignum * * quotient, bignum * * remainder,int q_negative_p, int r_negative_p)
{
- GC_BIGNUM(numerator);
+ GC_BIGNUM(numerator,this);
- bignum_length_type length_n = (BIGNUM_LENGTH (numerator));
- bignum_length_type length_q;
- bignum * q = NULL;
- GC_BIGNUM(q);
+ bignum_length_type length_n = (BIGNUM_LENGTH (numerator));
+ bignum_length_type length_q;
+ bignum * q = NULL;
+ GC_BIGNUM(q,this);
- int shift = 0;
- /* Because `bignum_digit_divide' requires a normalized denominator. */
- while (denominator < (BIGNUM_RADIX / 2))
- {
- denominator <<= 1;
- shift += 1;
- }
- if (shift == 0)
- {
- length_q = length_n;
-
- q = (allot_bignum (length_q, q_negative_p));
- bignum_destructive_copy (numerator, q);
- }
- else
- {
- length_q = (length_n + 1);
-
- q = (allot_bignum (length_q, q_negative_p));
- bignum_destructive_normalization (numerator, q, shift);
- }
- {
- bignum_digit_type r = 0;
- bignum_digit_type * start = (BIGNUM_START_PTR (q));
- bignum_digit_type * scan = (start + length_q);
- bignum_digit_type qj;
-
- while (start < scan)
- {
- r = (bignum_digit_divide (r, (*--scan), denominator, (&qj)));
- (*scan) = qj;
- }
-
- q = bignum_trim (q);
-
- if (remainder != ((bignum * *) 0))
- {
- if (shift != 0)
- r >>= shift;
-
- (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
- }
-
- if (quotient != ((bignum * *) 0))
- (*quotient) = q;
- }
- return;
+ int shift = 0;
+ /* Because `bignum_digit_divide' requires a normalized denominator. */
+ while (denominator < (BIGNUM_RADIX / 2))
+ {
+ denominator <<= 1;
+ shift += 1;
+ }
+ if (shift == 0)
+ {
+ length_q = length_n;
+
+ q = (allot_bignum (length_q, q_negative_p));
+ bignum_destructive_copy (numerator, q);
+ }
+ else
+ {
+ length_q = (length_n + 1);
+
+ q = (allot_bignum (length_q, q_negative_p));
+ bignum_destructive_normalization (numerator, q, shift);
+ }
+ {
+ bignum_digit_type r = 0;
+ bignum_digit_type * start = (BIGNUM_START_PTR (q));
+ bignum_digit_type * scan = (start + length_q);
+ bignum_digit_type qj;
+
+ while (start < scan)
+ {
+ r = (bignum_digit_divide (r, (*--scan), denominator, (&qj)));
+ (*scan) = qj;
+ }
+
+ q = bignum_trim (q);
+
+ if (remainder != ((bignum * *) 0))
+ {
+ if (shift != 0)
+ r >>= shift;
+
+ (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
+ }
+
+ if (quotient != ((bignum * *) 0))
+ (*quotient) = q;
+ }
+ return;
}
-void
-bignum_destructive_normalization(bignum * source, bignum * target,
- int shift_left)
+
+void factorvm::bignum_destructive_normalization(bignum * source, bignum * target, int shift_left)
{
- bignum_digit_type digit;
- bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
- bignum_digit_type carry = 0;
- bignum_digit_type * scan_target = (BIGNUM_START_PTR (target));
- bignum_digit_type * end_source = (scan_source + (BIGNUM_LENGTH (source)));
- bignum_digit_type * end_target = (scan_target + (BIGNUM_LENGTH (target)));
- int shift_right = (BIGNUM_DIGIT_LENGTH - shift_left);
- bignum_digit_type mask = (((cell)1 << shift_right) - 1);
- while (scan_source < end_source)
- {
- digit = (*scan_source++);
- (*scan_target++) = (((digit & mask) << shift_left) | carry);
- carry = (digit >> shift_right);
- }
- if (scan_target < end_target)
- (*scan_target) = carry;
- else
- BIGNUM_ASSERT (carry == 0);
- return;
+ bignum_digit_type digit;
+ bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
+ bignum_digit_type carry = 0;
+ bignum_digit_type * scan_target = (BIGNUM_START_PTR (target));
+ bignum_digit_type * end_source = (scan_source + (BIGNUM_LENGTH (source)));
+ bignum_digit_type * end_target = (scan_target + (BIGNUM_LENGTH (target)));
+ int shift_right = (BIGNUM_DIGIT_LENGTH - shift_left);
+ bignum_digit_type mask = (((cell)1 << shift_right) - 1);
+ while (scan_source < end_source)
+ {
+ digit = (*scan_source++);
+ (*scan_target++) = (((digit & mask) << shift_left) | carry);
+ carry = (digit >> shift_right);
+ }
+ if (scan_target < end_target)
+ (*scan_target) = carry;
+ else
+ BIGNUM_ASSERT (carry == 0);
+ return;
}
-void
-bignum_destructive_unnormalization(bignum * bignum, int shift_right)
+
+void factorvm::bignum_destructive_unnormalization(bignum * bignum, int shift_right)
{
- bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
- bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
- bignum_digit_type digit;
- bignum_digit_type carry = 0;
- int shift_left = (BIGNUM_DIGIT_LENGTH - shift_right);
- bignum_digit_type mask = (((fixnum)1 << shift_right) - 1);
- while (start < scan)
- {
- digit = (*--scan);
- (*scan) = ((digit >> shift_right) | carry);
- carry = ((digit & mask) << shift_left);
- }
- BIGNUM_ASSERT (carry == 0);
- return;
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
+ bignum_digit_type digit;
+ bignum_digit_type carry = 0;
+ int shift_left = (BIGNUM_DIGIT_LENGTH - shift_right);
+ bignum_digit_type mask = (((fixnum)1 << shift_right) - 1);
+ while (start < scan)
+ {
+ digit = (*--scan);
+ (*scan) = ((digit >> shift_right) | carry);
+ carry = ((digit & mask) << shift_left);
+ }
+ BIGNUM_ASSERT (carry == 0);
+ return;
}
+
/* This is a reduced version of the division algorithm, applied to the
case of dividing two bignum digits by one bignum digit. It is
assumed that the numerator, denominator are normalized. */
-#define BDD_STEP(qn, j) \
-{ \
- uj = (u[j]); \
- if (uj != v1) \
- { \
- uj_uj1 = (HD_CONS (uj, (u[j + 1]))); \
- guess = (uj_uj1 / v1); \
- comparand = (HD_CONS ((uj_uj1 % v1), (u[j + 2]))); \
- } \
- else \
- { \
- guess = (BIGNUM_RADIX_ROOT - 1); \
- comparand = (HD_CONS (((u[j + 1]) + v1), (u[j + 2]))); \
- } \
- while ((guess * v2) > comparand) \
- { \
- guess -= 1; \
- comparand += (v1 << BIGNUM_HALF_DIGIT_LENGTH); \
- if (comparand >= BIGNUM_RADIX) \
- break; \
- } \
- qn = (bignum_digit_divide_subtract (v1, v2, guess, (&u[j]))); \
+#define BDD_STEP(qn, j) \
+{ \
+ uj = (u[j]); \
+ if (uj != v1) \
+ { \
+ uj_uj1 = (HD_CONS (uj, (u[j + 1]))); \
+ guess = (uj_uj1 / v1); \
+ comparand = (HD_CONS ((uj_uj1 % v1), (u[j + 2]))); \
+ } \
+ else \
+ { \
+ guess = (BIGNUM_RADIX_ROOT - 1); \
+ comparand = (HD_CONS (((u[j + 1]) + v1), (u[j + 2]))); \
+ } \
+ while ((guess * v2) > comparand) \
+ { \
+ guess -= 1; \
+ comparand += (v1 << BIGNUM_HALF_DIGIT_LENGTH); \
+ if (comparand >= BIGNUM_RADIX) \
+ break; \
+ } \
+ qn = (bignum_digit_divide_subtract (v1, v2, guess, (&u[j]))); \
}
-bignum_digit_type
-bignum_digit_divide(bignum_digit_type uh, bignum_digit_type ul,
- bignum_digit_type v,
- bignum_digit_type * q) /* return value */
+bignum_digit_type factorvm::bignum_digit_divide(bignum_digit_type uh, bignum_digit_type ul, bignum_digit_type v, bignum_digit_type * q) /* return value */
{
- bignum_digit_type guess;
- bignum_digit_type comparand;
- bignum_digit_type v1 = (HD_HIGH (v));
- bignum_digit_type v2 = (HD_LOW (v));
- bignum_digit_type uj;
- bignum_digit_type uj_uj1;
- bignum_digit_type q1;
- bignum_digit_type q2;
- bignum_digit_type u [4];
- if (uh == 0)
- {
- if (ul < v)
- {
- (*q) = 0;
- return (ul);
- }
- else if (ul == v)
- {
- (*q) = 1;
- return (0);
- }
- }
- (u[0]) = (HD_HIGH (uh));
- (u[1]) = (HD_LOW (uh));
- (u[2]) = (HD_HIGH (ul));
- (u[3]) = (HD_LOW (ul));
- v1 = (HD_HIGH (v));
- v2 = (HD_LOW (v));
- BDD_STEP (q1, 0);
- BDD_STEP (q2, 1);
- (*q) = (HD_CONS (q1, q2));
- return (HD_CONS ((u[2]), (u[3])));
+ bignum_digit_type guess;
+ bignum_digit_type comparand;
+ bignum_digit_type v1 = (HD_HIGH (v));
+ bignum_digit_type v2 = (HD_LOW (v));
+ bignum_digit_type uj;
+ bignum_digit_type uj_uj1;
+ bignum_digit_type q1;
+ bignum_digit_type q2;
+ bignum_digit_type u [4];
+ if (uh == 0)
+ {
+ if (ul < v)
+ {
+ (*q) = 0;
+ return (ul);
+ }
+ else if (ul == v)
+ {
+ (*q) = 1;
+ return (0);
+ }
+ }
+ (u[0]) = (HD_HIGH (uh));
+ (u[1]) = (HD_LOW (uh));
+ (u[2]) = (HD_HIGH (ul));
+ (u[3]) = (HD_LOW (ul));
+ v1 = (HD_HIGH (v));
+ v2 = (HD_LOW (v));
+ BDD_STEP (q1, 0);
+ BDD_STEP (q2, 1);
+ (*q) = (HD_CONS (q1, q2));
+ return (HD_CONS ((u[2]), (u[3])));
}
+
#undef BDD_STEP
-#define BDDS_MULSUB(vn, un, carry_in) \
-{ \
- product = ((vn * guess) + carry_in); \
- diff = (un - (HD_LOW (product))); \
- if (diff < 0) \
- { \
- un = (diff + BIGNUM_RADIX_ROOT); \
- carry = ((HD_HIGH (product)) + 1); \
- } \
- else \
- { \
- un = diff; \
- carry = (HD_HIGH (product)); \
- } \
+#define BDDS_MULSUB(vn, un, carry_in) \
+{ \
+ product = ((vn * guess) + carry_in); \
+ diff = (un - (HD_LOW (product))); \
+ if (diff < 0) \
+ { \
+ un = (diff + BIGNUM_RADIX_ROOT); \
+ carry = ((HD_HIGH (product)) + 1); \
+ } \
+ else \
+ { \
+ un = diff; \
+ carry = (HD_HIGH (product)); \
+ } \
}
-#define BDDS_ADD(vn, un, carry_in) \
-{ \
- sum = (vn + un + carry_in); \
- if (sum < BIGNUM_RADIX_ROOT) \
- { \
- un = sum; \
- carry = 0; \
- } \
- else \
- { \
- un = (sum - BIGNUM_RADIX_ROOT); \
- carry = 1; \
- } \
+#define BDDS_ADD(vn, un, carry_in) \
+{ \
+ sum = (vn + un + carry_in); \
+ if (sum < BIGNUM_RADIX_ROOT) \
+ { \
+ un = sum; \
+ carry = 0; \
+ } \
+ else \
+ { \
+ un = (sum - BIGNUM_RADIX_ROOT); \
+ carry = 1; \
+ } \
}
-bignum_digit_type
-bignum_digit_divide_subtract(bignum_digit_type v1, bignum_digit_type v2,
- bignum_digit_type guess, bignum_digit_type * u)
+bignum_digit_type factorvm::bignum_digit_divide_subtract(bignum_digit_type v1, bignum_digit_type v2, bignum_digit_type guess, bignum_digit_type * u)
{
- {
- bignum_digit_type product;
- bignum_digit_type diff;
- bignum_digit_type carry;
- BDDS_MULSUB (v2, (u[2]), 0);
- BDDS_MULSUB (v1, (u[1]), carry);
- if (carry == 0)
- return (guess);
- diff = ((u[0]) - carry);
- if (diff < 0)
- (u[0]) = (diff + BIGNUM_RADIX);
- else
- {
- (u[0]) = diff;
- return (guess);
- }
- }
- {
- bignum_digit_type sum;
- bignum_digit_type carry;
- BDDS_ADD(v2, (u[2]), 0);
- BDDS_ADD(v1, (u[1]), carry);
- if (carry == 1)
- (u[0]) += 1;
- }
- return (guess - 1);
+ {
+ bignum_digit_type product;
+ bignum_digit_type diff;
+ bignum_digit_type carry;
+ BDDS_MULSUB (v2, (u[2]), 0);
+ BDDS_MULSUB (v1, (u[1]), carry);
+ if (carry == 0)
+ return (guess);
+ diff = ((u[0]) - carry);
+ if (diff < 0)
+ (u[0]) = (diff + BIGNUM_RADIX);
+ else
+ {
+ (u[0]) = diff;
+ return (guess);
+ }
+ }
+ {
+ bignum_digit_type sum;
+ bignum_digit_type carry;
+ BDDS_ADD(v2, (u[2]), 0);
+ BDDS_ADD(v1, (u[1]), carry);
+ if (carry == 1)
+ (u[0]) += 1;
+ }
+ return (guess - 1);
}
+
#undef BDDS_MULSUB
#undef BDDS_ADD
/* allocates memory */
-void
-bignum_divide_unsigned_small_denominator(bignum * numerator,
- bignum_digit_type denominator,
- bignum * * quotient,
- bignum * * remainder,
- int q_negative_p,
- int r_negative_p)
+void factorvm::bignum_divide_unsigned_small_denominator(bignum * numerator, bignum_digit_type denominator, bignum * * quotient, bignum * * remainder,int q_negative_p, int r_negative_p)
{
- GC_BIGNUM(numerator);
+ GC_BIGNUM(numerator,this);
- bignum * q = (bignum_new_sign (numerator, q_negative_p));
- GC_BIGNUM(q);
+ bignum * q = (bignum_new_sign (numerator, q_negative_p));
+ GC_BIGNUM(q,this);
- bignum_digit_type r = (bignum_destructive_scale_down (q, denominator));
+ bignum_digit_type r = (bignum_destructive_scale_down (q, denominator));
- q = (bignum_trim (q));
+ q = (bignum_trim (q));
- if (remainder != ((bignum * *) 0))
- (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
+ if (remainder != ((bignum * *) 0))
+ (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
- (*quotient) = q;
+ (*quotient) = q;
- return;
+ return;
}
+
/* Given (denominator > 1), it is fairly easy to show that
(quotient_high < BIGNUM_RADIX_ROOT), after which it is easy to see
that all digits are < BIGNUM_RADIX. */
-bignum_digit_type
-bignum_destructive_scale_down(bignum * bignum, bignum_digit_type denominator)
+bignum_digit_type factorvm::bignum_destructive_scale_down(bignum * bignum, bignum_digit_type denominator)
{
- bignum_digit_type numerator;
- bignum_digit_type remainder = 0;
- bignum_digit_type two_digits;
+ bignum_digit_type numerator;
+ bignum_digit_type remainder = 0;
+ bignum_digit_type two_digits;
#define quotient_high remainder
- bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
- bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
- BIGNUM_ASSERT ((denominator > 1) && (denominator < BIGNUM_RADIX_ROOT));
- while (start < scan)
- {
- two_digits = (*--scan);
- numerator = (HD_CONS (remainder, (HD_HIGH (two_digits))));
- quotient_high = (numerator / denominator);
- numerator = (HD_CONS ((numerator % denominator), (HD_LOW (two_digits))));
- (*scan) = (HD_CONS (quotient_high, (numerator / denominator)));
- remainder = (numerator % denominator);
- }
- return (remainder);
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
+ BIGNUM_ASSERT ((denominator > 1) && (denominator < BIGNUM_RADIX_ROOT));
+ while (start < scan)
+ {
+ two_digits = (*--scan);
+ numerator = (HD_CONS (remainder, (HD_HIGH (two_digits))));
+ quotient_high = (numerator / denominator);
+ numerator = (HD_CONS ((numerator % denominator), (HD_LOW (two_digits))));
+ (*scan) = (HD_CONS (quotient_high, (numerator / denominator)));
+ remainder = (numerator % denominator);
+ }
+ return (remainder);
#undef quotient_high
}
+
/* allocates memory */
-bignum *
-bignum_remainder_unsigned_small_denominator(
- bignum * n, bignum_digit_type d, int negative_p)
+bignum * factorvm::bignum_remainder_unsigned_small_denominator(bignum * n, bignum_digit_type d, int negative_p)
{
- bignum_digit_type two_digits;
- bignum_digit_type * start = (BIGNUM_START_PTR (n));
- bignum_digit_type * scan = (start + (BIGNUM_LENGTH (n)));
- bignum_digit_type r = 0;
- BIGNUM_ASSERT ((d > 1) && (d < BIGNUM_RADIX_ROOT));
- while (start < scan)
- {
- two_digits = (*--scan);
- r =
- ((HD_CONS (((HD_CONS (r, (HD_HIGH (two_digits)))) % d),
- (HD_LOW (two_digits))))
- % d);
- }
- return (bignum_digit_to_bignum (r, negative_p));
+ bignum_digit_type two_digits;
+ bignum_digit_type * start = (BIGNUM_START_PTR (n));
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (n)));
+ bignum_digit_type r = 0;
+ BIGNUM_ASSERT ((d > 1) && (d < BIGNUM_RADIX_ROOT));
+ while (start < scan)
+ {
+ two_digits = (*--scan);
+ r =
+ ((HD_CONS (((HD_CONS (r, (HD_HIGH (two_digits)))) % d),
+ (HD_LOW (two_digits))))
+ % d);
+ }
+ return (bignum_digit_to_bignum (r, negative_p));
}
+
/* allocates memory */
-bignum *
-bignum_digit_to_bignum(bignum_digit_type digit, int negative_p)
+bignum *factorvm::bignum_digit_to_bignum(bignum_digit_type digit, int negative_p)
{
- if (digit == 0)
- return (BIGNUM_ZERO ());
- else
- {
- bignum * result = (allot_bignum (1, negative_p));
- (BIGNUM_REF (result, 0)) = digit;
- return (result);
- }
+ if (digit == 0)
+ return (BIGNUM_ZERO ());
+ else
+ {
+ bignum * result = (allot_bignum (1, negative_p));
+ (BIGNUM_REF (result, 0)) = digit;
+ return (result);
+ }
}
+
/* allocates memory */
-bignum *
-allot_bignum(bignum_length_type length, int negative_p)
+bignum *factorvm::allot_bignum(bignum_length_type length, int negative_p)
{
- BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX));
- bignum * result = allot_array_internal<bignum>(length + 1);
- BIGNUM_SET_NEGATIVE_P (result, negative_p);
- return (result);
+ BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX));
+ bignum * result = allot_array_internal<bignum>(length + 1);
+ BIGNUM_SET_NEGATIVE_P (result, negative_p);
+ return (result);
}
+
/* allocates memory */
-bignum *
-allot_bignum_zeroed(bignum_length_type length, int negative_p)
+bignum * factorvm::allot_bignum_zeroed(bignum_length_type length, int negative_p)
{
- bignum * result = allot_bignum(length,negative_p);
- bignum_digit_type * scan = (BIGNUM_START_PTR (result));
- bignum_digit_type * end = (scan + length);
- while (scan < end)
- (*scan++) = 0;
- return (result);
+ bignum * result = allot_bignum(length,negative_p);
+ bignum_digit_type * scan = (BIGNUM_START_PTR (result));
+ bignum_digit_type * end = (scan + length);
+ while (scan < end)
+ (*scan++) = 0;
+ return (result);
}
-#define BIGNUM_REDUCE_LENGTH(source, length) \
- source = reallot_array(source,length + 1)
+
+#define BIGNUM_REDUCE_LENGTH(source, length) \
+source = reallot_array(source,length + 1)
/* allocates memory */
-bignum *
-bignum_shorten_length(bignum * bignum, bignum_length_type length)
+bignum *factorvm::bignum_shorten_length(bignum * bignum, bignum_length_type length)
{
- bignum_length_type current_length = (BIGNUM_LENGTH (bignum));
- BIGNUM_ASSERT ((length >= 0) || (length <= current_length));
- if (length < current_length)
- {
- BIGNUM_REDUCE_LENGTH (bignum, length);
- BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum)));
- }
- return (bignum);
+ bignum_length_type current_length = (BIGNUM_LENGTH (bignum));
+ BIGNUM_ASSERT ((length >= 0) || (length <= current_length));
+ if (length < current_length)
+ {
+ BIGNUM_REDUCE_LENGTH (bignum, length);
+ BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum)));
+ }
+ return (bignum);
}
+
/* allocates memory */
-bignum *
-bignum_trim(bignum * bignum)
+bignum *factorvm::bignum_trim(bignum * bignum)
{
- bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
- bignum_digit_type * end = (start + (BIGNUM_LENGTH (bignum)));
- bignum_digit_type * scan = end;
- while ((start <= scan) && ((*--scan) == 0))
- ;
- scan += 1;
- if (scan < end)
- {
- bignum_length_type length = (scan - start);
- BIGNUM_REDUCE_LENGTH (bignum, length);
- BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum)));
- }
- return (bignum);
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type * end = (start + (BIGNUM_LENGTH (bignum)));
+ bignum_digit_type * scan = end;
+ while ((start <= scan) && ((*--scan) == 0))
+ ;
+ scan += 1;
+ if (scan < end)
+ {
+ bignum_length_type length = (scan - start);
+ BIGNUM_REDUCE_LENGTH (bignum, length);
+ BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum)));
+ }
+ return (bignum);
}
+
/* Copying */
/* allocates memory */
-bignum *
-bignum_new_sign(bignum * x, int negative_p)
+bignum *factorvm::bignum_new_sign(bignum * x, int negative_p)
{
- GC_BIGNUM(x);
- bignum * result = (allot_bignum ((BIGNUM_LENGTH (x)), negative_p));
+ GC_BIGNUM(x,this);
+ bignum * result = (allot_bignum ((BIGNUM_LENGTH (x)), negative_p));
- bignum_destructive_copy (x, result);
- return (result);
+ bignum_destructive_copy (x, result);
+ return (result);
}
+
/* allocates memory */
-bignum *
-bignum_maybe_new_sign(bignum * x, int negative_p)
+bignum *factorvm::bignum_maybe_new_sign(bignum * x, int negative_p)
{
- if ((BIGNUM_NEGATIVE_P (x)) ? negative_p : (! negative_p))
- return (x);
- else
- {
- bignum * result =
- (allot_bignum ((BIGNUM_LENGTH (x)), negative_p));
- bignum_destructive_copy (x, result);
- return (result);
- }
+ if ((BIGNUM_NEGATIVE_P (x)) ? negative_p : (! negative_p))
+ return (x);
+ else
+ {
+ bignum * result =
+ (allot_bignum ((BIGNUM_LENGTH (x)), negative_p));
+ bignum_destructive_copy (x, result);
+ return (result);
+ }
}
-void
-bignum_destructive_copy(bignum * source, bignum * target)
+
+void factorvm::bignum_destructive_copy(bignum * source, bignum * target)
{
- bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
- bignum_digit_type * end_source =
- (scan_source + (BIGNUM_LENGTH (source)));
- bignum_digit_type * scan_target = (BIGNUM_START_PTR (target));
- while (scan_source < end_source)
- (*scan_target++) = (*scan_source++);
- return;
+ bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
+ bignum_digit_type * end_source =
+ (scan_source + (BIGNUM_LENGTH (source)));
+ bignum_digit_type * scan_target = (BIGNUM_START_PTR (target));
+ while (scan_source < end_source)
+ (*scan_target++) = (*scan_source++);
+ return;
}
+
/*
* Added bitwise operations (and oddp).
*/
/* allocates memory */
-bignum *
-bignum_bitwise_not(bignum * x)
+bignum *factorvm::bignum_bitwise_not(bignum * x)
{
- return bignum_subtract(BIGNUM_ONE(1), x);
+ return bignum_subtract(BIGNUM_ONE(1), x);
}
+
/* allocates memory */
-bignum *
-bignum_arithmetic_shift(bignum * arg1, fixnum n)
+bignum *factorvm::bignum_arithmetic_shift(bignum * arg1, fixnum n)
{
- if (BIGNUM_NEGATIVE_P(arg1) && n < 0)
- return bignum_bitwise_not(bignum_magnitude_ash(bignum_bitwise_not(arg1), n));
- else
- return bignum_magnitude_ash(arg1, n);
+ if (BIGNUM_NEGATIVE_P(arg1) && n < 0)
+ return bignum_bitwise_not(bignum_magnitude_ash(bignum_bitwise_not(arg1), n));
+ else
+ return bignum_magnitude_ash(arg1, n);
}
+
#define AND_OP 0
#define IOR_OP 1
#define XOR_OP 2
/* allocates memory */
-bignum *
-bignum_bitwise_and(bignum * arg1, bignum * arg2)
+bignum *factorvm::bignum_bitwise_and(bignum * arg1, bignum * arg2)
{
- return(
- (BIGNUM_NEGATIVE_P (arg1))
- ? (BIGNUM_NEGATIVE_P (arg2))
+ return(
+ (BIGNUM_NEGATIVE_P (arg1))
+ ? (BIGNUM_NEGATIVE_P (arg2))
? bignum_negneg_bitwise_op(AND_OP, arg1, arg2)
: bignum_posneg_bitwise_op(AND_OP, arg2, arg1)
- : (BIGNUM_NEGATIVE_P (arg2))
+ : (BIGNUM_NEGATIVE_P (arg2))
? bignum_posneg_bitwise_op(AND_OP, arg1, arg2)
: bignum_pospos_bitwise_op(AND_OP, arg1, arg2)
- );
+ );
}
+
/* allocates memory */
-bignum *
-bignum_bitwise_ior(bignum * arg1, bignum * arg2)
+bignum *factorvm::bignum_bitwise_ior(bignum * arg1, bignum * arg2)
{
- return(
- (BIGNUM_NEGATIVE_P (arg1))
- ? (BIGNUM_NEGATIVE_P (arg2))
+ return(
+ (BIGNUM_NEGATIVE_P (arg1))
+ ? (BIGNUM_NEGATIVE_P (arg2))
? bignum_negneg_bitwise_op(IOR_OP, arg1, arg2)
: bignum_posneg_bitwise_op(IOR_OP, arg2, arg1)
- : (BIGNUM_NEGATIVE_P (arg2))
+ : (BIGNUM_NEGATIVE_P (arg2))
? bignum_posneg_bitwise_op(IOR_OP, arg1, arg2)
: bignum_pospos_bitwise_op(IOR_OP, arg1, arg2)
- );
+ );
}
+
/* allocates memory */
-bignum *
-bignum_bitwise_xor(bignum * arg1, bignum * arg2)
+bignum *factorvm::bignum_bitwise_xor(bignum * arg1, bignum * arg2)
{
- return(
- (BIGNUM_NEGATIVE_P (arg1))
- ? (BIGNUM_NEGATIVE_P (arg2))
+ return(
+ (BIGNUM_NEGATIVE_P (arg1))
+ ? (BIGNUM_NEGATIVE_P (arg2))
? bignum_negneg_bitwise_op(XOR_OP, arg1, arg2)
: bignum_posneg_bitwise_op(XOR_OP, arg2, arg1)
- : (BIGNUM_NEGATIVE_P (arg2))
+ : (BIGNUM_NEGATIVE_P (arg2))
? bignum_posneg_bitwise_op(XOR_OP, arg1, arg2)
: bignum_pospos_bitwise_op(XOR_OP, arg1, arg2)
- );
+ );
}
+
/* allocates memory */
/* ash for the magnitude */
/* assume arg1 is a big number, n is a long */
-bignum *
-bignum_magnitude_ash(bignum * arg1, fixnum n)
+bignum *factorvm::bignum_magnitude_ash(bignum * arg1, fixnum n)
{
- GC_BIGNUM(arg1);
+ GC_BIGNUM(arg1,this);
- bignum * result = NULL;
- bignum_digit_type *scan1;
- bignum_digit_type *scanr;
- bignum_digit_type *end;
+ bignum * result = NULL;
+ bignum_digit_type *scan1;
+ bignum_digit_type *scanr;
+ bignum_digit_type *end;
- fixnum digit_offset,bit_offset;
+ fixnum digit_offset,bit_offset;
- if (BIGNUM_ZERO_P (arg1)) return (arg1);
+ if (BIGNUM_ZERO_P (arg1)) return (arg1);
- if (n > 0) {
- digit_offset = n / BIGNUM_DIGIT_LENGTH;
- bit_offset = n % BIGNUM_DIGIT_LENGTH;
+ if (n > 0) {
+ digit_offset = n / BIGNUM_DIGIT_LENGTH;
+ bit_offset = n % BIGNUM_DIGIT_LENGTH;
- result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) + digit_offset + 1,
- BIGNUM_NEGATIVE_P(arg1));
+ result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) + digit_offset + 1,
+ BIGNUM_NEGATIVE_P(arg1));
- scanr = BIGNUM_START_PTR (result) + digit_offset;
- scan1 = BIGNUM_START_PTR (arg1);
- end = scan1 + BIGNUM_LENGTH (arg1);
+ scanr = BIGNUM_START_PTR (result) + digit_offset;
+ scan1 = BIGNUM_START_PTR (arg1);
+ end = scan1 + BIGNUM_LENGTH (arg1);
- while (scan1 < end) {
- *scanr = *scanr | (*scan1 & BIGNUM_DIGIT_MASK) << bit_offset;
- *scanr = *scanr & BIGNUM_DIGIT_MASK;
- scanr++;
- *scanr = *scan1++ >> (BIGNUM_DIGIT_LENGTH - bit_offset);
- *scanr = *scanr & BIGNUM_DIGIT_MASK;
- }
- }
- else if (n < 0
- && (-n >= (BIGNUM_LENGTH (arg1) * (bignum_length_type) BIGNUM_DIGIT_LENGTH)))
- result = BIGNUM_ZERO ();
-
- else if (n < 0) {
- digit_offset = -n / BIGNUM_DIGIT_LENGTH;
- bit_offset = -n % BIGNUM_DIGIT_LENGTH;
+ while (scan1 < end) {
+ *scanr = *scanr | (*scan1 & BIGNUM_DIGIT_MASK) << bit_offset;
+ *scanr = *scanr & BIGNUM_DIGIT_MASK;
+ scanr++;
+ *scanr = *scan1++ >> (BIGNUM_DIGIT_LENGTH - bit_offset);
+ *scanr = *scanr & BIGNUM_DIGIT_MASK;
+ }
+ }
+ else if (n < 0
+ && (-n >= (BIGNUM_LENGTH (arg1) * (bignum_length_type) BIGNUM_DIGIT_LENGTH)))
+ result = BIGNUM_ZERO ();
+
+ else if (n < 0) {
+ digit_offset = -n / BIGNUM_DIGIT_LENGTH;
+ bit_offset = -n % BIGNUM_DIGIT_LENGTH;
- result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) - digit_offset,
- BIGNUM_NEGATIVE_P(arg1));
+ result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) - digit_offset,
+ BIGNUM_NEGATIVE_P(arg1));
- scanr = BIGNUM_START_PTR (result);
- scan1 = BIGNUM_START_PTR (arg1) + digit_offset;
- end = scanr + BIGNUM_LENGTH (result) - 1;
+ scanr = BIGNUM_START_PTR (result);
+ scan1 = BIGNUM_START_PTR (arg1) + digit_offset;
+ end = scanr + BIGNUM_LENGTH (result) - 1;
- while (scanr < end) {
- *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ;
- *scanr = (*scanr |
- *scan1 << (BIGNUM_DIGIT_LENGTH - bit_offset)) & BIGNUM_DIGIT_MASK;
- scanr++;
- }
- *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ;
- }
- else if (n == 0) result = arg1;
+ while (scanr < end) {
+ *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ;
+ *scanr = (*scanr |
+ *scan1 << (BIGNUM_DIGIT_LENGTH - bit_offset)) & BIGNUM_DIGIT_MASK;
+ scanr++;
+ }
+ *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ;
+ }
+ else if (n == 0) result = arg1;
- return (bignum_trim (result));
+ return (bignum_trim (result));
}
+
/* allocates memory */
-bignum *
-bignum_pospos_bitwise_op(int op, bignum * arg1, bignum * arg2)
+bignum *factorvm::bignum_pospos_bitwise_op(int op, bignum * arg1, bignum * arg2)
{
- GC_BIGNUM(arg1); GC_BIGNUM(arg2);
+ GC_BIGNUM(arg1,this); GC_BIGNUM(arg2,this);
- bignum * result;
- bignum_length_type max_length;
-
- bignum_digit_type *scan1, *end1, digit1;
- bignum_digit_type *scan2, *end2, digit2;
- bignum_digit_type *scanr, *endr;
-
- max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2))
- ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2);
-
- result = allot_bignum(max_length, 0);
-
- scanr = BIGNUM_START_PTR(result);
- scan1 = BIGNUM_START_PTR(arg1);
- scan2 = BIGNUM_START_PTR(arg2);
- endr = scanr + max_length;
- end1 = scan1 + BIGNUM_LENGTH(arg1);
- end2 = scan2 + BIGNUM_LENGTH(arg2);
-
- while (scanr < endr) {
- digit1 = (scan1 < end1) ? *scan1++ : 0;
- digit2 = (scan2 < end2) ? *scan2++ : 0;
- *scanr++ = (op == AND_OP) ? digit1 & digit2 :
- (op == IOR_OP) ? digit1 | digit2 :
- digit1 ^ digit2;
- }
- return bignum_trim(result);
+ bignum * result;
+ bignum_length_type max_length;
+
+ bignum_digit_type *scan1, *end1, digit1;
+ bignum_digit_type *scan2, *end2, digit2;
+ bignum_digit_type *scanr, *endr;
+
+ max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2))
+ ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2);
+
+ result = allot_bignum(max_length, 0);
+
+ scanr = BIGNUM_START_PTR(result);
+ scan1 = BIGNUM_START_PTR(arg1);
+ scan2 = BIGNUM_START_PTR(arg2);
+ endr = scanr + max_length;
+ end1 = scan1 + BIGNUM_LENGTH(arg1);
+ end2 = scan2 + BIGNUM_LENGTH(arg2);
+
+ while (scanr < endr) {
+ digit1 = (scan1 < end1) ? *scan1++ : 0;
+ digit2 = (scan2 < end2) ? *scan2++ : 0;
+ *scanr++ = (op == AND_OP) ? digit1 & digit2 :
+ (op == IOR_OP) ? digit1 | digit2 :
+ digit1 ^ digit2;
+ }
+ return bignum_trim(result);
}
+
/* allocates memory */
-bignum *
-bignum_posneg_bitwise_op(int op, bignum * arg1, bignum * arg2)
+bignum *factorvm::bignum_posneg_bitwise_op(int op, bignum * arg1, bignum * arg2)
{
- GC_BIGNUM(arg1); GC_BIGNUM(arg2);
+ GC_BIGNUM(arg1,this); GC_BIGNUM(arg2,this);
- bignum * result;
- bignum_length_type max_length;
+ bignum * result;
+ bignum_length_type max_length;
- bignum_digit_type *scan1, *end1, digit1;
- bignum_digit_type *scan2, *end2, digit2, carry2;
- bignum_digit_type *scanr, *endr;
+ bignum_digit_type *scan1, *end1, digit1;
+ bignum_digit_type *scan2, *end2, digit2, carry2;
+ bignum_digit_type *scanr, *endr;
- char neg_p = op == IOR_OP || op == XOR_OP;
+ char neg_p = op == IOR_OP || op == XOR_OP;
- max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2) + 1)
- ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2) + 1;
+ max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2) + 1)
+ ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2) + 1;
- result = allot_bignum(max_length, neg_p);
+ result = allot_bignum(max_length, neg_p);
- scanr = BIGNUM_START_PTR(result);
- scan1 = BIGNUM_START_PTR(arg1);
- scan2 = BIGNUM_START_PTR(arg2);
- endr = scanr + max_length;
- end1 = scan1 + BIGNUM_LENGTH(arg1);
- end2 = scan2 + BIGNUM_LENGTH(arg2);
+ scanr = BIGNUM_START_PTR(result);
+ scan1 = BIGNUM_START_PTR(arg1);
+ scan2 = BIGNUM_START_PTR(arg2);
+ endr = scanr + max_length;
+ end1 = scan1 + BIGNUM_LENGTH(arg1);
+ end2 = scan2 + BIGNUM_LENGTH(arg2);
- carry2 = 1;
+ carry2 = 1;
- while (scanr < endr) {
- digit1 = (scan1 < end1) ? *scan1++ : 0;
- digit2 = (~((scan2 < end2) ? *scan2++ : 0) & BIGNUM_DIGIT_MASK)
- + carry2;
+ while (scanr < endr) {
+ digit1 = (scan1 < end1) ? *scan1++ : 0;
+ digit2 = (~((scan2 < end2) ? *scan2++ : 0) & BIGNUM_DIGIT_MASK)
+ + carry2;
- if (digit2 < BIGNUM_RADIX)
- carry2 = 0;
- else
- {
- digit2 = (digit2 - BIGNUM_RADIX);
- carry2 = 1;
- }
+ if (digit2 < BIGNUM_RADIX)
+ carry2 = 0;
+ else
+ {
+ digit2 = (digit2 - BIGNUM_RADIX);
+ carry2 = 1;
+ }
- *scanr++ = (op == AND_OP) ? digit1 & digit2 :
- (op == IOR_OP) ? digit1 | digit2 :
- digit1 ^ digit2;
- }
+ *scanr++ = (op == AND_OP) ? digit1 & digit2 :
+ (op == IOR_OP) ? digit1 | digit2 :
+ digit1 ^ digit2;
+ }
- if (neg_p)
- bignum_negate_magnitude(result);
+ if (neg_p)
+ bignum_negate_magnitude(result);
- return bignum_trim(result);
+ return bignum_trim(result);
}
+
/* allocates memory */
-bignum *
-bignum_negneg_bitwise_op(int op, bignum * arg1, bignum * arg2)
+bignum *factorvm::bignum_negneg_bitwise_op(int op, bignum * arg1, bignum * arg2)
{
- GC_BIGNUM(arg1); GC_BIGNUM(arg2);
+ GC_BIGNUM(arg1,this); GC_BIGNUM(arg2,this);
- bignum * result;
- bignum_length_type max_length;
+ bignum * result;
+ bignum_length_type max_length;
- bignum_digit_type *scan1, *end1, digit1, carry1;
- bignum_digit_type *scan2, *end2, digit2, carry2;
- bignum_digit_type *scanr, *endr;
+ bignum_digit_type *scan1, *end1, digit1, carry1;
+ bignum_digit_type *scan2, *end2, digit2, carry2;
+ bignum_digit_type *scanr, *endr;
- char neg_p = op == AND_OP || op == IOR_OP;
+ char neg_p = op == AND_OP || op == IOR_OP;
- max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2))
- ? BIGNUM_LENGTH(arg1) + 1 : BIGNUM_LENGTH(arg2) + 1;
+ max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2))
+ ? BIGNUM_LENGTH(arg1) + 1 : BIGNUM_LENGTH(arg2) + 1;
- result = allot_bignum(max_length, neg_p);
+ result = allot_bignum(max_length, neg_p);
- scanr = BIGNUM_START_PTR(result);
- scan1 = BIGNUM_START_PTR(arg1);
- scan2 = BIGNUM_START_PTR(arg2);
- endr = scanr + max_length;
- end1 = scan1 + BIGNUM_LENGTH(arg1);
- end2 = scan2 + BIGNUM_LENGTH(arg2);
+ scanr = BIGNUM_START_PTR(result);
+ scan1 = BIGNUM_START_PTR(arg1);
+ scan2 = BIGNUM_START_PTR(arg2);
+ endr = scanr + max_length;
+ end1 = scan1 + BIGNUM_LENGTH(arg1);
+ end2 = scan2 + BIGNUM_LENGTH(arg2);
- carry1 = 1;
- carry2 = 1;
+ carry1 = 1;
+ carry2 = 1;
- while (scanr < endr) {
- digit1 = (~((scan1 < end1) ? *scan1++ : 0) & BIGNUM_DIGIT_MASK) + carry1;
- digit2 = (~((scan2 < end2) ? *scan2++ : 0) & BIGNUM_DIGIT_MASK) + carry2;
+ while (scanr < endr) {
+ digit1 = (~((scan1 < end1) ? *scan1++ : 0) & BIGNUM_DIGIT_MASK) + carry1;
+ digit2 = (~((scan2 < end2) ? *scan2++ : 0) & BIGNUM_DIGIT_MASK) + carry2;
- if (digit1 < BIGNUM_RADIX)
- carry1 = 0;
- else
- {
- digit1 = (digit1 - BIGNUM_RADIX);
- carry1 = 1;
- }
+ if (digit1 < BIGNUM_RADIX)
+ carry1 = 0;
+ else
+ {
+ digit1 = (digit1 - BIGNUM_RADIX);
+ carry1 = 1;
+ }
- if (digit2 < BIGNUM_RADIX)
- carry2 = 0;
- else
- {
- digit2 = (digit2 - BIGNUM_RADIX);
- carry2 = 1;
- }
+ if (digit2 < BIGNUM_RADIX)
+ carry2 = 0;
+ else
+ {
+ digit2 = (digit2 - BIGNUM_RADIX);
+ carry2 = 1;
+ }
- *scanr++ = (op == AND_OP) ? digit1 & digit2 :
- (op == IOR_OP) ? digit1 | digit2 :
- digit1 ^ digit2;
- }
+ *scanr++ = (op == AND_OP) ? digit1 & digit2 :
+ (op == IOR_OP) ? digit1 | digit2 :
+ digit1 ^ digit2;
+ }
- if (neg_p)
- bignum_negate_magnitude(result);
+ if (neg_p)
+ bignum_negate_magnitude(result);
- return bignum_trim(result);
+ return bignum_trim(result);
}
-void
-bignum_negate_magnitude(bignum * arg)
+
+void factorvm::bignum_negate_magnitude(bignum * arg)
{
- bignum_digit_type *scan;
- bignum_digit_type *end;
- bignum_digit_type digit;
- bignum_digit_type carry;
-
- scan = BIGNUM_START_PTR(arg);
- end = scan + BIGNUM_LENGTH(arg);
-
- carry = 1;
-
- while (scan < end) {
- digit = (~*scan & BIGNUM_DIGIT_MASK) + carry;
-
- if (digit < BIGNUM_RADIX)
- carry = 0;
- else
- {
- digit = (digit - BIGNUM_RADIX);
- carry = 1;
- }
+ bignum_digit_type *scan;
+ bignum_digit_type *end;
+ bignum_digit_type digit;
+ bignum_digit_type carry;
+
+ scan = BIGNUM_START_PTR(arg);
+ end = scan + BIGNUM_LENGTH(arg);
+
+ carry = 1;
+
+ while (scan < end) {
+ digit = (~*scan & BIGNUM_DIGIT_MASK) + carry;
+
+ if (digit < BIGNUM_RADIX)
+ carry = 0;
+ else
+ {
+ digit = (digit - BIGNUM_RADIX);
+ carry = 1;
+ }
- *scan++ = digit;
- }
+ *scan++ = digit;
+ }
}
+
/* Allocates memory */
-bignum *
-bignum_integer_length(bignum * x)
+bignum *factorvm::bignum_integer_length(bignum * x)
{
- GC_BIGNUM(x);
+ GC_BIGNUM(x,this);
- bignum_length_type index = ((BIGNUM_LENGTH (x)) - 1);
- bignum_digit_type digit = (BIGNUM_REF (x, index));
+ bignum_length_type index = ((BIGNUM_LENGTH (x)) - 1);
+ bignum_digit_type digit = (BIGNUM_REF (x, index));
- bignum * result = (allot_bignum (2, 0));
+ bignum * result = (allot_bignum (2, 0));
- (BIGNUM_REF (result, 0)) = index;
- (BIGNUM_REF (result, 1)) = 0;
- bignum_destructive_scale_up (result, BIGNUM_DIGIT_LENGTH);
- while (digit > 1)
- {
- bignum_destructive_add (result, ((bignum_digit_type) 1));
- digit >>= 1;
- }
- return (bignum_trim (result));
+ (BIGNUM_REF (result, 0)) = index;
+ (BIGNUM_REF (result, 1)) = 0;
+ bignum_destructive_scale_up (result, BIGNUM_DIGIT_LENGTH);
+ while (digit > 1)
+ {
+ bignum_destructive_add (result, ((bignum_digit_type) 1));
+ digit >>= 1;
+ }
+ return (bignum_trim (result));
}
+
/* Allocates memory */
-int
-bignum_logbitp(int shift, bignum * arg)
+int factorvm::bignum_logbitp(int shift, bignum * arg)
{
- return((BIGNUM_NEGATIVE_P (arg))
- ? !bignum_unsigned_logbitp (shift, bignum_bitwise_not (arg))
- : bignum_unsigned_logbitp (shift,arg));
+ return((BIGNUM_NEGATIVE_P (arg))
+ ? !bignum_unsigned_logbitp (shift, bignum_bitwise_not (arg))
+ : bignum_unsigned_logbitp (shift,arg));
}
-int
-bignum_unsigned_logbitp(int shift, bignum * bignum)
+
+int factorvm::bignum_unsigned_logbitp(int shift, bignum * bignum)
{
- bignum_length_type len = (BIGNUM_LENGTH (bignum));
- int index = shift / BIGNUM_DIGIT_LENGTH;
- if (index >= len)
- return 0;
- bignum_digit_type digit = (BIGNUM_REF (bignum, index));
- int p = shift % BIGNUM_DIGIT_LENGTH;
- bignum_digit_type mask = ((fixnum)1) << p;
- return (digit & mask) ? 1 : 0;
+ bignum_length_type len = (BIGNUM_LENGTH (bignum));
+ int index = shift / BIGNUM_DIGIT_LENGTH;
+ if (index >= len)
+ return 0;
+ bignum_digit_type digit = (BIGNUM_REF (bignum, index));
+ int p = shift % BIGNUM_DIGIT_LENGTH;
+ bignum_digit_type mask = ((fixnum)1) << p;
+ return (digit & mask) ? 1 : 0;
}
+
/* Allocates memory */
-bignum *
-digit_stream_to_bignum(unsigned int n_digits,
- unsigned int (*producer)(unsigned int),
- unsigned int radix,
- int negative_p)
+bignum *factorvm::digit_stream_to_bignum(unsigned int n_digits, unsigned int (*producer)(unsigned int, factorvm*), unsigned int radix, int negative_p)
{
- BIGNUM_ASSERT ((radix > 1) && (radix <= BIGNUM_RADIX_ROOT));
- if (n_digits == 0)
- return (BIGNUM_ZERO ());
- if (n_digits == 1)
- {
- fixnum digit = ((fixnum) ((*producer) (0)));
- return (fixnum_to_bignum (negative_p ? (- digit) : digit));
- }
- {
- bignum_length_type length;
- {
- unsigned int radix_copy = radix;
- unsigned int log_radix = 0;
- while (radix_copy > 0)
- {
- radix_copy >>= 1;
- log_radix += 1;
- }
- /* This length will be at least as large as needed. */
- length = (BIGNUM_BITS_TO_DIGITS (n_digits * log_radix));
- }
- {
- bignum * result = (allot_bignum_zeroed (length, negative_p));
- while ((n_digits--) > 0)
- {
- bignum_destructive_scale_up (result, ((bignum_digit_type) radix));
- bignum_destructive_add
- (result, ((bignum_digit_type) ((*producer) (n_digits))));
- }
- return (bignum_trim (result));
- }
- }
+ BIGNUM_ASSERT ((radix > 1) && (radix <= BIGNUM_RADIX_ROOT));
+ if (n_digits == 0)
+ return (BIGNUM_ZERO ());
+ if (n_digits == 1)
+ {
+ fixnum digit = ((fixnum) ((*producer) (0,this)));
+ return (fixnum_to_bignum (negative_p ? (- digit) : digit));
+ }
+ {
+ bignum_length_type length;
+ {
+ unsigned int radix_copy = radix;
+ unsigned int log_radix = 0;
+ while (radix_copy > 0)
+ {
+ radix_copy >>= 1;
+ log_radix += 1;
+ }
+ /* This length will be at least as large as needed. */
+ length = (BIGNUM_BITS_TO_DIGITS (n_digits * log_radix));
+ }
+ {
+ bignum * result = (allot_bignum_zeroed (length, negative_p));
+ while ((n_digits--) > 0)
+ {
+ bignum_destructive_scale_up (result, ((bignum_digit_type) radix));
+ bignum_destructive_add
+ (result, ((bignum_digit_type) ((*producer) (n_digits,this))));
+ }
+ return (bignum_trim (result));
+ }
+ }
}
+
}
bignum_comparison_greater = 1
};
-int bignum_equal_p(bignum *, bignum *);
-enum bignum_comparison bignum_compare(bignum *, bignum *);
-bignum * bignum_add(bignum *, bignum *);
-bignum * bignum_subtract(bignum *, bignum *);
-bignum * bignum_negate(bignum *);
-bignum * bignum_multiply(bignum *, bignum *);
-void
-bignum_divide(bignum * numerator, bignum * denominator,
- bignum * * quotient, bignum * * remainder);
-bignum * bignum_quotient(bignum *, bignum *);
-bignum * bignum_remainder(bignum *, bignum *);
-bignum * fixnum_to_bignum(fixnum);
-bignum * cell_to_bignum(cell);
-bignum * long_long_to_bignum(s64 n);
-bignum * ulong_long_to_bignum(u64 n);
-fixnum bignum_to_fixnum(bignum *);
-cell bignum_to_cell(bignum *);
-s64 bignum_to_long_long(bignum *);
-u64 bignum_to_ulong_long(bignum *);
-bignum * double_to_bignum(double);
-double bignum_to_double(bignum *);
-
-/* Added bitwise operators. */
-
-bignum * bignum_bitwise_not(bignum *);
-bignum * bignum_arithmetic_shift(bignum *, fixnum);
-bignum * bignum_bitwise_and(bignum *, bignum *);
-bignum * bignum_bitwise_ior(bignum *, bignum *);
-bignum * bignum_bitwise_xor(bignum *, bignum *);
-
-/* Forward references */
-int bignum_equal_p_unsigned(bignum *, bignum *);
-enum bignum_comparison bignum_compare_unsigned(bignum *, bignum *);
-bignum * bignum_add_unsigned(bignum *, bignum *, int);
-bignum * bignum_subtract_unsigned(bignum *, bignum *);
-bignum * bignum_multiply_unsigned(bignum *, bignum *, int);
-bignum * bignum_multiply_unsigned_small_factor
- (bignum *, bignum_digit_type, int);
-void bignum_destructive_scale_up(bignum *, bignum_digit_type);
-void bignum_destructive_add(bignum *, bignum_digit_type);
-void bignum_divide_unsigned_large_denominator
- (bignum *, bignum *, bignum * *, bignum * *, int, int);
-void bignum_destructive_normalization(bignum *, bignum *, int);
-void bignum_destructive_unnormalization(bignum *, int);
-void bignum_divide_unsigned_normalized(bignum *, bignum *, bignum *);
-bignum_digit_type bignum_divide_subtract
- (bignum_digit_type *, bignum_digit_type *, bignum_digit_type,
- bignum_digit_type *);
-void bignum_divide_unsigned_medium_denominator
- (bignum *, bignum_digit_type, bignum * *, bignum * *, int, int);
-bignum_digit_type bignum_digit_divide
- (bignum_digit_type, bignum_digit_type, bignum_digit_type, bignum_digit_type *);
-bignum_digit_type bignum_digit_divide_subtract
- (bignum_digit_type, bignum_digit_type, bignum_digit_type, bignum_digit_type *);
-void bignum_divide_unsigned_small_denominator
- (bignum *, bignum_digit_type, bignum * *, bignum * *, int, int);
-bignum_digit_type bignum_destructive_scale_down
- (bignum *, bignum_digit_type);
-bignum * bignum_remainder_unsigned_small_denominator
- (bignum *, bignum_digit_type, int);
-bignum * bignum_digit_to_bignum(bignum_digit_type, int);
-bignum * allot_bignum(bignum_length_type, int);
-bignum * allot_bignum_zeroed(bignum_length_type, int);
-bignum * bignum_shorten_length(bignum *, bignum_length_type);
-bignum * bignum_trim(bignum *);
-bignum * bignum_new_sign(bignum *, int);
-bignum * bignum_maybe_new_sign(bignum *, int);
-void bignum_destructive_copy(bignum *, bignum *);
-
-/* Added for bitwise operations. */
-bignum * bignum_magnitude_ash(bignum * arg1, fixnum n);
-bignum * bignum_pospos_bitwise_op(int op, bignum *, bignum *);
-bignum * bignum_posneg_bitwise_op(int op, bignum *, bignum *);
-bignum * bignum_negneg_bitwise_op(int op, bignum *, bignum *);
-void bignum_negate_magnitude(bignum *);
-
-bignum * bignum_integer_length(bignum * arg1);
-int bignum_unsigned_logbitp(int shift, bignum * bignum);
-int bignum_logbitp(int shift, bignum * arg);
+struct factorvm;
bignum * digit_stream_to_bignum(unsigned int n_digits,
- unsigned int (*producer)(unsigned int),
+ unsigned int (*producer)(unsigned int,factorvm*),
unsigned int radix,
int negative_p);
namespace factor
{
-VM_C_API void box_boolean(bool value)
+void factorvm::box_boolean(bool value)
{
dpush(value ? T : F);
}
-VM_C_API bool to_boolean(cell value)
+VM_C_API void box_boolean(bool value, factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_boolean(value);
+}
+
+bool factorvm::to_boolean(cell value)
{
return value != F;
}
+VM_C_API bool to_boolean(cell value, factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->to_boolean(value);
+}
+
}
namespace factor
{
-inline static cell tag_boolean(cell untagged)
-{
- return (untagged ? T : F);
-}
-VM_C_API void box_boolean(bool value);
-VM_C_API bool to_boolean(cell value);
+VM_C_API void box_boolean(bool value, factorvm *vm);
+VM_C_API bool to_boolean(cell value, factorvm *vm);
}
namespace factor
{
-byte_array *allot_byte_array(cell size)
+byte_array *factorvm::allot_byte_array(cell size)
{
byte_array *array = allot_array_internal<byte_array>(size);
memset(array + 1,0,size);
return array;
}
-PRIMITIVE(byte_array)
+
+inline void factorvm::vmprim_byte_array()
{
cell size = unbox_array_size();
dpush(tag<byte_array>(allot_byte_array(size)));
}
-PRIMITIVE(uninitialized_byte_array)
+PRIMITIVE(byte_array)
+{
+ PRIMITIVE_GETVM()->vmprim_byte_array();
+}
+
+inline void factorvm::vmprim_uninitialized_byte_array()
{
cell size = unbox_array_size();
dpush(tag<byte_array>(allot_array_internal<byte_array>(size)));
}
-PRIMITIVE(resize_byte_array)
+PRIMITIVE(uninitialized_byte_array)
+{
+ PRIMITIVE_GETVM()->vmprim_uninitialized_byte_array();
+}
+
+inline void factorvm::vmprim_resize_byte_array()
{
byte_array *array = untag_check<byte_array>(dpop());
cell capacity = unbox_array_size();
dpush(tag<byte_array>(reallot_array(array,capacity)));
}
+PRIMITIVE(resize_byte_array)
+{
+ PRIMITIVE_GETVM()->vmprim_resize_byte_array();
+}
+
void growable_byte_array::append_bytes(void *elts, cell len)
{
cell new_size = count + len;
-
+ factorvm *myvm = elements.myvm;
if(new_size >= array_capacity(elements.untagged()))
- elements = reallot_array(elements.untagged(),new_size * 2);
+ elements = myvm->reallot_array(elements.untagged(),new_size * 2);
memcpy(&elements->data<u8>()[count],elts,len);
void growable_byte_array::append_byte_array(cell byte_array_)
{
- gc_root<byte_array> byte_array(byte_array_);
+ gc_root<byte_array> byte_array(byte_array_,elements.myvm);
cell len = array_capacity(byte_array.untagged());
cell new_size = count + len;
-
+ factorvm *myvm = elements.myvm;
if(new_size >= array_capacity(elements.untagged()))
- elements = reallot_array(elements.untagged(),new_size * 2);
+ elements = myvm->reallot_array(elements.untagged(),new_size * 2);
memcpy(&elements->data<u8>()[count],byte_array->data<u8>(),len);
void growable_byte_array::trim()
{
- elements = reallot_array(elements.untagged(),count);
+ factorvm *myvm = elements.myvm;
+ elements = myvm->reallot_array(elements.untagged(),count);
}
}
namespace factor
{
-byte_array *allot_byte_array(cell size);
-
PRIMITIVE(byte_array);
PRIMITIVE(uninitialized_byte_array);
PRIMITIVE(resize_byte_array);
-struct growable_byte_array {
- cell count;
- gc_root<byte_array> elements;
-
- growable_byte_array(cell capacity = 40) : count(0), elements(allot_byte_array(capacity)) { }
-
- void append_bytes(void *elts, cell len);
- void append_byte_array(cell elts);
-
- void trim();
-};
}
namespace factor
{
-static void check_frame(stack_frame *frame)
+void factorvm::check_frame(stack_frame *frame)
{
#ifdef FACTOR_DEBUG
check_code_pointer((cell)frame->xt);
#endif
}
-callstack *allot_callstack(cell size)
+callstack *factorvm::allot_callstack(cell size)
{
callstack *stack = allot<callstack>(callstack_size(size));
stack->length = tag_fixnum(size);
return stack;
}
-stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom)
+stack_frame *factorvm::fix_callstack_top(stack_frame *top, stack_frame *bottom)
{
stack_frame *frame = bottom - 1;
will have popped a necessary frame... however this word is only
called by continuation implementation, and user code shouldn't
be calling it at all, so we leave it as it is for now. */
-stack_frame *capture_start()
+stack_frame *factorvm::capture_start()
{
stack_frame *frame = stack_chain->callstack_bottom - 1;
while(frame >= stack_chain->callstack_top
return frame + 1;
}
-PRIMITIVE(callstack)
+inline void factorvm::vmprim_callstack()
{
stack_frame *top = capture_start();
stack_frame *bottom = stack_chain->callstack_bottom;
dpush(tag<callstack>(stack));
}
-PRIMITIVE(set_callstack)
+PRIMITIVE(callstack)
+{
+ PRIMITIVE_GETVM()->vmprim_callstack();
+}
+
+inline void factorvm::vmprim_set_callstack()
{
callstack *stack = untag_check<callstack>(dpop());
critical_error("Bug in set_callstack()",0);
}
-code_block *frame_code(stack_frame *frame)
+PRIMITIVE(set_callstack)
+{
+ PRIMITIVE_GETVM()->vmprim_set_callstack();
+}
+
+code_block *factorvm::frame_code(stack_frame *frame)
{
check_frame(frame);
return (code_block *)frame->xt - 1;
}
-cell frame_type(stack_frame *frame)
+
+cell factorvm::frame_type(stack_frame *frame)
{
return frame_code(frame)->type;
}
-cell frame_executing(stack_frame *frame)
+cell factorvm::frame_executing(stack_frame *frame)
{
code_block *compiled = frame_code(frame);
if(compiled->literals == F || !stack_traces_p())
}
}
-stack_frame *frame_successor(stack_frame *frame)
+stack_frame *factorvm::frame_successor(stack_frame *frame)
{
check_frame(frame);
return (stack_frame *)((cell)frame - frame->size);
}
/* Allocates memory */
-cell frame_scan(stack_frame *frame)
+cell factorvm::frame_scan(stack_frame *frame)
{
switch(frame_type(frame))
{
struct stack_frame_accumulator {
growable_array frames;
- void operator()(stack_frame *frame)
+ stack_frame_accumulator(factorvm *vm) : frames(vm) {}
+
+ void operator()(stack_frame *frame, factorvm *myvm)
{
- gc_root<object> executing(frame_executing(frame));
- gc_root<object> scan(frame_scan(frame));
+ gc_root<object> executing(myvm->frame_executing(frame),myvm);
+ gc_root<object> scan(myvm->frame_scan(frame),myvm);
frames.add(executing.value());
frames.add(scan.value());
}
-PRIMITIVE(callstack_to_array)
+inline void factorvm::vmprim_callstack_to_array()
{
- gc_root<callstack> callstack(dpop());
+ gc_root<callstack> callstack(dpop(),this);
- stack_frame_accumulator accum;
+ stack_frame_accumulator accum(this);
iterate_callstack_object(callstack.untagged(),accum);
accum.frames.trim();
dpush(accum.frames.elements.value());
}
-stack_frame *innermost_stack_frame(callstack *stack)
+PRIMITIVE(callstack_to_array)
+{
+ PRIMITIVE_GETVM()->vmprim_callstack_to_array();
+}
+
+stack_frame *factorvm::innermost_stack_frame(callstack *stack)
{
stack_frame *top = stack->top();
stack_frame *bottom = stack->bottom();
return frame;
}
-stack_frame *innermost_stack_frame_quot(callstack *callstack)
+stack_frame *factorvm::innermost_stack_frame_quot(callstack *callstack)
{
stack_frame *inner = innermost_stack_frame(callstack);
- tagged<quotation>(frame_executing(inner)).untag_check();
+ tagged<quotation>(frame_executing(inner)).untag_check(this);
return inner;
}
/* Some primitives implementing a limited form of callstack mutation.
Used by the single stepper. */
-PRIMITIVE(innermost_stack_frame_executing)
+inline void factorvm::vmprim_innermost_stack_frame_executing()
{
dpush(frame_executing(innermost_stack_frame(untag_check<callstack>(dpop()))));
}
-PRIMITIVE(innermost_stack_frame_scan)
+PRIMITIVE(innermost_stack_frame_executing)
+{
+ PRIMITIVE_GETVM()->vmprim_innermost_stack_frame_executing();
+}
+
+inline void factorvm::vmprim_innermost_stack_frame_scan()
{
dpush(frame_scan(innermost_stack_frame_quot(untag_check<callstack>(dpop()))));
}
-PRIMITIVE(set_innermost_stack_frame_quot)
+PRIMITIVE(innermost_stack_frame_scan)
{
- gc_root<callstack> callstack(dpop());
- gc_root<quotation> quot(dpop());
+ PRIMITIVE_GETVM()->vmprim_innermost_stack_frame_scan();
+}
- callstack.untag_check();
- quot.untag_check();
+inline void factorvm::vmprim_set_innermost_stack_frame_quot()
+{
+ gc_root<callstack> callstack(dpop(),this);
+ gc_root<quotation> quot(dpop(),this);
+
+ callstack.untag_check(this);
+ quot.untag_check(this);
jit_compile(quot.value(),true);
FRAME_RETURN_ADDRESS(inner) = (char *)quot->xt + offset;
}
+PRIMITIVE(set_innermost_stack_frame_quot)
+{
+ PRIMITIVE_GETVM()->vmprim_set_innermost_stack_frame_quot();
+}
+
/* called before entry into Factor code. */
-VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom)
+void factorvm::save_callstack_bottom(stack_frame *callstack_bottom)
{
stack_chain->callstack_bottom = callstack_bottom;
}
+VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom, factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->save_callstack_bottom(callstack_bottom);
+}
+
}
return sizeof(callstack) + size;
}
-stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom);
-stack_frame *frame_successor(stack_frame *frame);
-code_block *frame_code(stack_frame *frame);
-cell frame_executing(stack_frame *frame);
-cell frame_scan(stack_frame *frame);
-cell frame_type(stack_frame *frame);
-
PRIMITIVE(callstack);
PRIMITIVE(set_callstack);
PRIMITIVE(callstack_to_array);
PRIMITIVE(innermost_stack_frame_scan);
PRIMITIVE(set_innermost_stack_frame_quot);
-VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom);
-
-template<typename T> void iterate_callstack(cell top, cell bottom, T &iterator)
-{
- stack_frame *frame = (stack_frame *)bottom - 1;
+VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom,factorvm *vm);
- while((cell)frame >= top)
- {
- iterator(frame);
- frame = frame_successor(frame);
- }
-}
-/* This is a little tricky. The iterator may allocate memory, so we
-keep the callstack in a GC root and use relative offsets */
-template<typename T> void iterate_callstack_object(callstack *stack_, T &iterator)
-{
- gc_root<callstack> stack(stack_);
- fixnum frame_offset = untag_fixnum(stack->length) - sizeof(stack_frame);
-
- while(frame_offset >= 0)
- {
- stack_frame *frame = stack->frame_at(frame_offset);
- frame_offset -= frame->size;
- iterator(frame);
- }
-}
}
namespace factor
{
-static relocation_type relocation_type_of(relocation_entry r)
+relocation_type factorvm::relocation_type_of(relocation_entry r)
{
return (relocation_type)((r & 0xf0000000) >> 28);
}
-static relocation_class relocation_class_of(relocation_entry r)
+
+relocation_class factorvm::relocation_class_of(relocation_entry r)
{
return (relocation_class)((r & 0x0f000000) >> 24);
}
-static cell relocation_offset_of(relocation_entry r)
+
+cell factorvm::relocation_offset_of(relocation_entry r)
{
return (r & 0x00ffffff);
}
-void flush_icache_for(code_block *block)
+
+void factorvm::flush_icache_for(code_block *block)
{
flush_icache((cell)block,block->size);
}
-static int number_of_parameters(relocation_type type)
+
+int factorvm::number_of_parameters(relocation_type type)
{
switch(type)
{
case RT_THIS:
case RT_STACK_CHAIN:
case RT_MEGAMORPHIC_CACHE_HITS:
+ case RT_VM:
return 0;
default:
critical_error("Bad rel type",type);
}
}
-void *object_xt(cell obj)
+
+void *factorvm::object_xt(cell obj)
{
switch(tagged<object>(obj).type())
{
}
}
-static void *xt_pic(word *w, cell tagged_quot)
+
+void *factorvm::xt_pic(word *w, cell tagged_quot)
{
if(tagged_quot == F || max_pic_size == 0)
return w->xt;
}
}
-void *word_xt_pic(word *w)
+
+void *factorvm::word_xt_pic(word *w)
{
return xt_pic(w,w->pic_def);
}
-void *word_xt_pic_tail(word *w)
+
+void *factorvm::word_xt_pic_tail(word *w)
{
return xt_pic(w,w->pic_tail_def);
}
+
/* References to undefined symbols are patched up to call this function on
image load */
-void undefined_symbol()
+void factorvm::undefined_symbol()
{
general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
}
+void undefined_symbol(factorvm *myvm)
+{
+ return myvm->undefined_symbol();
+}
+
/* Look up an external library symbol referenced by a compiled code block */
-void *get_rel_symbol(array *literals, cell index)
+void *factorvm::get_rel_symbol(array *literals, cell index)
{
cell symbol = array_nth(literals,index);
cell library = array_nth(literals,index + 1);
dll *d = (library == F ? NULL : untag<dll>(library));
if(d != NULL && !d->dll)
- return (void *)undefined_symbol;
+ return (void *)factor::undefined_symbol;
switch(tagged<object>(symbol).type())
{
return sym;
else
{
- return (void *)undefined_symbol;
+ return (void *)factor::undefined_symbol;
}
}
case ARRAY_TYPE:
if(sym)
return sym;
}
- return (void *)undefined_symbol;
+ return (void *)factor::undefined_symbol;
}
default:
critical_error("Bad symbol specifier",symbol);
- return (void *)undefined_symbol;
+ return (void *)factor::undefined_symbol;
}
}
-cell compute_relocation(relocation_entry rel, cell index, code_block *compiled)
+
+cell factorvm::compute_relocation(relocation_entry rel, cell index, code_block *compiled)
{
array *literals = untag<array>(compiled->literals);
cell offset = relocation_offset_of(rel) + (cell)compiled->xt();
return untag_fixnum(ARG);
case RT_MEGAMORPHIC_CACHE_HITS:
return (cell)&megamorphic_cache_hits;
+ case RT_VM:
+ return (cell)this;
default:
critical_error("Bad rel type",rel);
return 0; /* Can't happen */
#undef ARG
}
-void iterate_relocations(code_block *compiled, relocation_iterator iter)
+
+void factorvm::iterate_relocations(code_block *compiled, relocation_iterator iter)
{
if(compiled->relocation != F)
{
for(cell i = 0; i < length; i++)
{
relocation_entry rel = relocation->data<relocation_entry>()[i];
- iter(rel,index,compiled);
+ iter(rel,index,compiled,this);
index += number_of_parameters(relocation_type_of(rel));
}
}
}
+
/* Store a 32-bit value into a PowerPC LIS/ORI sequence */
-static void store_address_2_2(cell *ptr, cell value)
+void factorvm::store_address_2_2(cell *ptr, cell value)
{
ptr[-1] = ((ptr[-1] & ~0xffff) | ((value >> 16) & 0xffff));
ptr[ 0] = ((ptr[ 0] & ~0xffff) | (value & 0xffff));
}
+
/* Store a value into a bitfield of a PowerPC instruction */
-static void store_address_masked(cell *ptr, fixnum value, cell mask, fixnum shift)
+void factorvm::store_address_masked(cell *ptr, fixnum value, cell mask, fixnum shift)
{
/* This is unaccurate but good enough */
fixnum test = (fixnum)mask >> 1;
*ptr = ((*ptr & ~mask) | ((value >> shift) & mask));
}
+
/* Perform a fixup on a code block */
-void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value)
+void factorvm::store_address_in_code_block(cell klass, cell offset, fixnum absolute_value)
{
fixnum relative_value = absolute_value - offset;
}
}
-void update_literal_references_step(relocation_entry rel, cell index, code_block *compiled)
+
+void factorvm::update_literal_references_step(relocation_entry rel, cell index, code_block *compiled)
{
if(relocation_type_of(rel) == RT_IMMEDIATE)
{
}
}
+void update_literal_references_step(relocation_entry rel, cell index, code_block *compiled, factorvm *myvm)
+{
+ return myvm->update_literal_references_step(rel,index,compiled);
+}
+
/* Update pointers to literals from compiled code. */
-void update_literal_references(code_block *compiled)
+void factorvm::update_literal_references(code_block *compiled)
{
if(!compiled->needs_fixup)
{
- iterate_relocations(compiled,update_literal_references_step);
+ iterate_relocations(compiled,factor::update_literal_references_step);
flush_icache_for(compiled);
}
}
+
/* Copy all literals referenced from a code block to newspace. Only for
aging and nursery collections */
-void copy_literal_references(code_block *compiled)
+void factorvm::copy_literal_references(code_block *compiled)
{
if(collecting_gen >= compiled->last_scan)
{
}
}
+void copy_literal_references(code_block *compiled, factorvm *myvm)
+{
+ return myvm->copy_literal_references(compiled);
+}
+
/* Compute an address to store at a relocation */
-void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled)
+void factorvm::relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled)
{
#ifdef FACTOR_DEBUG
- tagged<array>(compiled->literals).untag_check();
- tagged<byte_array>(compiled->relocation).untag_check();
+ tagged<array>(compiled->literals).untag_check(this);
+ tagged<byte_array>(compiled->relocation).untag_check(this);
#endif
store_address_in_code_block(relocation_class_of(rel),
compute_relocation(rel,index,compiled));
}
-void update_word_references_step(relocation_entry rel, cell index, code_block *compiled)
+void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled, factorvm *myvm)
+{
+ return myvm->relocate_code_block_step(rel,index,compiled);
+}
+
+void factorvm::update_word_references_step(relocation_entry rel, cell index, code_block *compiled)
{
relocation_type type = relocation_type_of(rel);
if(type == RT_XT || type == RT_XT_PIC || type == RT_XT_PIC_TAIL)
relocate_code_block_step(rel,index,compiled);
}
+void update_word_references_step(relocation_entry rel, cell index, code_block *compiled, factorvm *myvm)
+{
+ return myvm->update_word_references_step(rel,index,compiled);
+}
+
/* Relocate new code blocks completely; updating references to literals,
dlsyms, and words. For all other words in the code heap, we only need
to update references to other words, without worrying about literals
or dlsyms. */
-void update_word_references(code_block *compiled)
+void factorvm::update_word_references(code_block *compiled)
{
if(compiled->needs_fixup)
relocate_code_block(compiled);
heap_free(&code,compiled);
else
{
- iterate_relocations(compiled,update_word_references_step);
+ iterate_relocations(compiled,factor::update_word_references_step);
flush_icache_for(compiled);
}
}
-void update_literal_and_word_references(code_block *compiled)
+void update_word_references(code_block *compiled, factorvm *myvm)
+{
+ return myvm->update_word_references(compiled);
+}
+
+void factorvm::update_literal_and_word_references(code_block *compiled)
{
update_literal_references(compiled);
update_word_references(compiled);
}
-static void check_code_address(cell address)
+void update_literal_and_word_references(code_block *compiled, factorvm *myvm)
+{
+ return myvm->update_literal_and_word_references(compiled);
+}
+
+void factorvm::check_code_address(cell address)
{
#ifdef FACTOR_DEBUG
assert(address >= code.seg->start && address < code.seg->end);
#endif
}
+
/* Update references to words. This is done after a new code block
is added to the heap. */
/* Mark all literals referenced from a word XT. Only for tenured
collections */
-void mark_code_block(code_block *compiled)
+void factorvm::mark_code_block(code_block *compiled)
{
check_code_address((cell)compiled);
copy_handle(&compiled->relocation);
}
-void mark_stack_frame_step(stack_frame *frame)
+
+void factorvm::mark_stack_frame_step(stack_frame *frame)
{
mark_code_block(frame_code(frame));
}
+void mark_stack_frame_step(stack_frame *frame, factorvm *myvm)
+{
+ return myvm->mark_stack_frame_step(frame);
+}
+
/* Mark code blocks executing in currently active stack frames. */
-void mark_active_blocks(context *stacks)
+void factorvm::mark_active_blocks(context *stacks)
{
if(collecting_gen == data->tenured())
{
cell top = (cell)stacks->callstack_top;
cell bottom = (cell)stacks->callstack_bottom;
- iterate_callstack(top,bottom,mark_stack_frame_step);
+ iterate_callstack(top,bottom,factor::mark_stack_frame_step);
}
}
-void mark_object_code_block(object *object)
+
+void factorvm::mark_object_code_block(object *object)
{
switch(object->h.hi_tag())
{
case CALLSTACK_TYPE:
{
callstack *stack = (callstack *)object;
- iterate_callstack_object(stack,mark_stack_frame_step);
+ iterate_callstack_object(stack,factor::mark_stack_frame_step);
break;
}
}
}
+
/* Perform all fixups on a code block */
-void relocate_code_block(code_block *compiled)
+void factorvm::relocate_code_block(code_block *compiled)
{
compiled->last_scan = data->nursery();
compiled->needs_fixup = false;
- iterate_relocations(compiled,relocate_code_block_step);
+ iterate_relocations(compiled,factor::relocate_code_block_step);
flush_icache_for(compiled);
}
+void relocate_code_block(code_block *compiled, factorvm *myvm)
+{
+ return myvm->relocate_code_block(compiled);
+}
+
/* Fixup labels. This is done at compile time, not image load time */
-void fixup_labels(array *labels, code_block *compiled)
+void factorvm::fixup_labels(array *labels, code_block *compiled)
{
cell i;
cell size = array_capacity(labels);
}
}
+
/* Might GC */
-code_block *allot_code_block(cell size)
+code_block *factorvm::allot_code_block(cell size)
{
heap_block *block = heap_allot(&code,size + sizeof(code_block));
return (code_block *)block;
}
+
/* Might GC */
-code_block *add_code_block(
- cell type,
- cell code_,
- cell labels_,
- cell relocation_,
- cell literals_)
-{
- gc_root<byte_array> code(code_);
- gc_root<object> labels(labels_);
- gc_root<byte_array> relocation(relocation_);
- gc_root<array> literals(literals_);
+code_block *factorvm::add_code_block(cell type,cell code_,cell labels_,cell relocation_,cell literals_)
+{
+ gc_root<byte_array> code(code_,this);
+ gc_root<object> labels(labels_,this);
+ gc_root<byte_array> relocation(relocation_,this);
+ gc_root<array> literals(literals_,this);
cell code_length = align8(array_capacity(code.untagged()));
code_block *compiled = allot_code_block(code_length);
return compiled;
}
+
}
RT_UNTAGGED,
/* address of megamorphic_cache_hits var */
RT_MEGAMORPHIC_CACHE_HITS,
+ /* address of vm object*/
+ RT_VM,
};
enum relocation_class {
/* code relocation table consists of a table of entries for each fixup */
typedef u32 relocation_entry;
-void flush_icache_for(code_block *compiled);
+struct factorvm;
-typedef void (*relocation_iterator)(relocation_entry rel, cell index, code_block *compiled);
+typedef void (*relocation_iterator)(relocation_entry rel, cell index, code_block *compiled, factorvm *vm);
-void iterate_relocations(code_block *compiled, relocation_iterator iter);
-
-void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value);
-
-void relocate_code_block(code_block *compiled);
-
-void update_literal_references(code_block *compiled);
-
-void copy_literal_references(code_block *compiled);
-
-void update_word_references(code_block *compiled);
-
-void update_literal_and_word_references(code_block *compiled);
-
-void mark_code_block(code_block *compiled);
-
-void mark_active_blocks(context *stacks);
-
-void mark_object_code_block(object *scan);
-
-void relocate_code_block(code_block *relocating);
-
-inline static bool stack_traces_p()
-{
- return userenv[STACK_TRACES_ENV] != F;
-}
-
-code_block *add_code_block(cell type, cell code, cell labels, cell relocation, cell literals);
+// callback functions
+void relocate_code_block(code_block *compiled, factorvm *myvm);
+void copy_literal_references(code_block *compiled, factorvm *myvm);
+void update_word_references(code_block *compiled, factorvm *myvm);
+void update_literal_and_word_references(code_block *compiled, factorvm *myvm);
}
namespace factor
{
-static void clear_free_list(heap *heap)
+void factorvm::clear_free_list(heap *heap)
{
memset(&heap->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 new_heap(heap *heap, cell size)
+void factorvm::new_heap(heap *heap, cell size)
{
heap->seg = alloc_segment(align_page(size));
if(!heap->seg)
clear_free_list(heap);
}
-static void add_to_free_list(heap *heap, free_heap_block *block)
+
+void factorvm::add_to_free_list(heap *heap, free_heap_block *block)
{
if(block->size < free_list_count * block_size_increment)
{
}
}
+
/* Called after reading the code heap from the image file, and after code GC.
In the former case, we must add a large free block from compiling.base + size to
compiling.limit. */
-void build_free_list(heap *heap, cell size)
+void factorvm::build_free_list(heap *heap, cell size)
{
heap_block *prev = NULL;
}
-static void assert_free_block(free_heap_block *block)
+
+void factorvm::assert_free_block(free_heap_block *block)
{
if(block->status != B_FREE)
critical_error("Invalid block in free list",(cell)block);
}
+
-static free_heap_block *find_free_block(heap *heap, cell size)
+free_heap_block *factorvm::find_free_block(heap *heap, cell size)
{
cell attempt = size;
return NULL;
}
-static free_heap_block *split_free_block(heap *heap, free_heap_block *block, cell size)
+
+free_heap_block *factorvm::split_free_block(heap *heap, free_heap_block *block, cell size)
{
if(block->size != size )
{
return block;
}
+
/* Allocate a block of memory from the mark and sweep GC heap */
-heap_block *heap_allot(heap *heap, cell size)
+heap_block *factorvm::heap_allot(heap *heap, cell size)
{
size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
return NULL;
}
+
/* Deallocates a block manually */
-void heap_free(heap *heap, heap_block *block)
+void factorvm::heap_free(heap *heap, heap_block *block)
{
block->status = B_FREE;
add_to_free_list(heap,(free_heap_block *)block);
}
-void mark_block(heap_block *block)
+
+void factorvm::mark_block(heap_block *block)
{
/* If already marked, do nothing */
switch(block->status)
}
}
+
/* If in the middle of code GC, we have to grow the heap, data GC restarts from
scratch, so we have to unmark any marked blocks. */
-void unmark_marked(heap *heap)
+void factorvm::unmark_marked(heap *heap)
{
heap_block *scan = first_block(heap);
}
}
+
/* 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 free_unmarked(heap *heap, heap_iterator iter)
+void factorvm::free_unmarked(heap *heap, heap_iterator iter)
{
clear_free_list(heap);
add_to_free_list(heap,(free_heap_block *)prev);
scan->status = B_ALLOCATED;
prev = scan;
- iter(scan);
+ iter(scan,this);
break;
default:
critical_error("Invalid scan->status",(cell)scan);
add_to_free_list(heap,(free_heap_block *)prev);
}
+
/* Compute total sum of sizes of free blocks, and size of largest free block */
-void heap_usage(heap *heap, cell *used, cell *total_free, cell *max_free)
+void factorvm::heap_usage(heap *heap, cell *used, cell *total_free, cell *max_free)
{
*used = 0;
*total_free = 0;
}
}
+
/* The size of the heap, not including the last block if it's free */
-cell heap_size(heap *heap)
+cell factorvm::heap_size(heap *heap)
{
heap_block *scan = first_block(heap);
return heap->seg->size;
}
+
/* Compute where each block is going to go, after compaction */
-cell compute_heap_forwarding(heap *heap, unordered_map<heap_block *,char *> &forwarding)
+cell factorvm::compute_heap_forwarding(heap *heap, unordered_map<heap_block *,char *> &forwarding)
{
heap_block *scan = first_block(heap);
char *address = (char *)first_block(heap);
return (cell)address - heap->seg->start;
}
-void compact_heap(heap *heap, unordered_map<heap_block *,char *> &forwarding)
+
+void factorvm::compact_heap(heap *heap, unordered_map<heap_block *,char *> &forwarding)
{
heap_block *scan = first_block(heap);
heap_free_list free;
};
-typedef void (*heap_iterator)(heap_block *compiled);
-
-void new_heap(heap *h, cell size);
-void build_free_list(heap *h, cell size);
-heap_block *heap_allot(heap *h, cell size);
-void heap_free(heap *h, 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 *h, cell *used, cell *total_free, cell *max_free);
-cell heap_size(heap *h);
-cell compute_heap_forwarding(heap *h, unordered_map<heap_block *,char *> &forwarding);
-void compact_heap(heap *h, unordered_map<heap_block *,char *> &forwarding);
+typedef void (*heap_iterator)(heap_block *compiled,factorvm *vm);
inline static heap_block *next_block(heap *h, heap_block *block)
{
namespace factor
{
-heap code;
-
/* Allocate a code heap during startup */
-void init_code_heap(cell size)
+void factorvm::init_code_heap(cell size)
{
new_heap(&code,size);
}
-bool in_code_heap_p(cell ptr)
+bool factorvm::in_code_heap_p(cell ptr)
{
return (ptr >= code.seg->start && ptr <= code.seg->end);
}
/* Compile a word definition with the non-optimizing compiler. Allocates memory */
-void jit_compile_word(cell word_, cell def_, bool relocate)
+void factorvm::jit_compile_word(cell word_, cell def_, bool relocate)
{
- gc_root<word> word(word_);
- gc_root<quotation> def(def_);
+ gc_root<word> word(word_,this);
+ gc_root<quotation> def(def_,this);
jit_compile(def.value(),relocate);
if(word->pic_tail_def != F) jit_compile(word->pic_tail_def,relocate);
}
+
/* Apply a function to every code block */
-void iterate_code_heap(code_heap_iterator iter)
+void factorvm::iterate_code_heap(code_heap_iterator iter)
{
heap_block *scan = first_block(&code);
while(scan)
{
if(scan->status != B_FREE)
- iter((code_block *)scan);
+ iter((code_block *)scan,this);
scan = next_block(&code,scan);
}
}
+
/* Copy literals referenced from all code blocks to newspace. Only for
aging and nursery collections */
-void copy_code_heap_roots()
+void factorvm::copy_code_heap_roots()
{
- iterate_code_heap(copy_literal_references);
+ iterate_code_heap(factor::copy_literal_references);
}
+
/* Update pointers to words referenced from all code blocks. Only after
defining a new word. */
-void update_code_heap_words()
+void factorvm::update_code_heap_words()
{
- iterate_code_heap(update_word_references);
+ iterate_code_heap(factor::update_word_references);
}
-PRIMITIVE(modify_code_heap)
+
+inline void factorvm::vmprim_modify_code_heap()
{
- gc_root<array> alist(dpop());
+ gc_root<array> alist(dpop(),this);
cell count = array_capacity(alist.untagged());
cell i;
for(i = 0; i < count; i++)
{
- gc_root<array> pair(array_nth(alist.untagged(),i));
+ gc_root<array> pair(array_nth(alist.untagged(),i),this);
- gc_root<word> word(array_nth(pair.untagged(),0));
- gc_root<object> data(array_nth(pair.untagged(),1));
+ gc_root<word> word(array_nth(pair.untagged(),0),this);
+ gc_root<object> data(array_nth(pair.untagged(),1),this);
switch(data.type())
{
update_code_heap_words();
}
+PRIMITIVE(modify_code_heap)
+{
+ PRIMITIVE_GETVM()->vmprim_modify_code_heap();
+}
+
/* Push the free space and total size of the code heap */
-PRIMITIVE(code_room)
+inline void factorvm::vmprim_code_room()
{
cell used, total_free, max_free;
heap_usage(&code,&used,&total_free,&max_free);
dpush(tag_fixnum(max_free / 1024));
}
-static unordered_map<heap_block *,char *> forwarding;
+PRIMITIVE(code_room)
+{
+ PRIMITIVE_GETVM()->vmprim_code_room();
+}
-code_block *forward_xt(code_block *compiled)
+
+code_block *factorvm::forward_xt(code_block *compiled)
{
return (code_block *)forwarding[compiled];
}
-void forward_frame_xt(stack_frame *frame)
+
+void factorvm::forward_frame_xt(stack_frame *frame)
{
cell offset = (cell)FRAME_RETURN_ADDRESS(frame) - (cell)frame_code(frame);
code_block *forwarded = forward_xt(frame_code(frame));
FRAME_RETURN_ADDRESS(frame) = (void *)((cell)forwarded + offset);
}
-void forward_object_xts()
+void forward_frame_xt(stack_frame *frame,factorvm *myvm)
+{
+ return myvm->forward_frame_xt(frame);
+}
+
+void factorvm::forward_object_xts()
{
begin_scan();
case CALLSTACK_TYPE:
{
callstack *stack = untag<callstack>(obj);
- iterate_callstack_object(stack,forward_frame_xt);
+ iterate_callstack_object(stack,factor::forward_frame_xt);
}
break;
default:
end_scan();
}
+
/* Set the XT fields now that the heap has been compacted */
-void fixup_object_xts()
+void factorvm::fixup_object_xts()
{
begin_scan();
end_scan();
}
+
/* Move all free space to the end of the code heap. This is not very efficient,
since it makes several passes over the code and data heaps, but we only ever
do this before saving a deployed image and exiting, so performaance is not
critical here */
-void compact_code_heap()
+void factorvm::compact_code_heap()
{
/* Free all unreachable code blocks */
gc();
namespace factor
{
-
-/* compiled code */
-extern heap code;
-
-void init_code_heap(cell size);
-
-bool in_code_heap_p(cell ptr);
-
-void jit_compile_word(cell word, cell def, bool relocate);
-
-typedef void (*code_heap_iterator)(code_block *compiled);
-
-void iterate_code_heap(code_heap_iterator iter);
-
-void copy_code_heap_roots();
+struct factorvm;
+typedef void (*code_heap_iterator)(code_block *compiled,factorvm *myvm);
PRIMITIVE(modify_code_heap);
-
PRIMITIVE(code_room);
-void compact_code_heap();
-
-inline static void check_code_pointer(cell ptr)
-{
-#ifdef FACTOR_DEBUG
- assert(in_code_heap_p(ptr));
-#endif
-}
-
}
#include "master.hpp"
-factor::context *stack_chain;
-
namespace factor
{
-cell ds_size, rs_size;
-context *unused_contexts;
-void reset_datastack()
+void factorvm::reset_datastack()
{
ds = ds_bot - sizeof(cell);
}
-void reset_retainstack()
+void factorvm::reset_retainstack()
{
rs = rs_bot - sizeof(cell);
}
static const cell stack_reserved = (64 * sizeof(cell));
-void fix_stacks()
+void factorvm::fix_stacks()
{
if(ds + sizeof(cell) < ds_bot || ds + stack_reserved >= ds_top) reset_datastack();
if(rs + sizeof(cell) < rs_bot || rs + stack_reserved >= rs_top) reset_retainstack();
/* called before entry into foreign C code. Note that ds and rs might
be stored in registers, so callbacks must save and restore the correct values */
-void save_stacks()
+void factorvm::save_stacks()
{
if(stack_chain)
{
}
}
-context *alloc_context()
+context *factorvm::alloc_context()
{
context *new_context;
return new_context;
}
-void dealloc_context(context *old_context)
+void factorvm::dealloc_context(context *old_context)
{
old_context->next = unused_contexts;
unused_contexts = old_context;
}
/* called on entry into a compiled callback */
-void nest_stacks()
+void factorvm::nest_stacks()
{
context *new_context = alloc_context();
reset_retainstack();
}
+void nest_stacks(factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->nest_stacks();
+}
+
/* called when leaving a compiled callback */
-void unnest_stacks()
+void factorvm::unnest_stacks()
{
ds = stack_chain->datastack_save;
rs = stack_chain->retainstack_save;
dealloc_context(old_stacks);
}
+void unnest_stacks(factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->unnest_stacks();
+}
+
/* called on startup */
-void init_stacks(cell ds_size_, cell rs_size_)
+void factorvm::init_stacks(cell ds_size_, cell rs_size_)
{
ds_size = ds_size_;
rs_size = rs_size_;
unused_contexts = NULL;
}
-bool stack_to_array(cell bottom, cell top)
+bool factorvm::stack_to_array(cell bottom, cell top)
{
fixnum depth = (fixnum)(top - bottom + sizeof(cell));
}
}
-PRIMITIVE(datastack)
+inline void factorvm::vmprim_datastack()
{
if(!stack_to_array(ds_bot,ds))
general_error(ERROR_DS_UNDERFLOW,F,F,NULL);
}
-PRIMITIVE(retainstack)
+PRIMITIVE(datastack)
+{
+ PRIMITIVE_GETVM()->vmprim_datastack();
+}
+
+inline void factorvm::vmprim_retainstack()
{
if(!stack_to_array(rs_bot,rs))
general_error(ERROR_RS_UNDERFLOW,F,F,NULL);
}
+PRIMITIVE(retainstack)
+{
+ PRIMITIVE_GETVM()->vmprim_retainstack();
+}
+
/* returns pointer to top of stack */
-cell array_to_stack(array *array, cell bottom)
+cell factorvm::array_to_stack(array *array, cell bottom)
{
cell depth = array_capacity(array) * sizeof(cell);
memcpy((void*)bottom,array + 1,depth);
return bottom + depth - sizeof(cell);
}
-PRIMITIVE(set_datastack)
+inline void factorvm::vmprim_set_datastack()
{
ds = array_to_stack(untag_check<array>(dpop()),ds_bot);
}
-PRIMITIVE(set_retainstack)
+PRIMITIVE(set_datastack)
+{
+ PRIMITIVE_GETVM()->vmprim_set_datastack();
+}
+
+inline void factorvm::vmprim_set_retainstack()
{
rs = array_to_stack(untag_check<array>(dpop()),rs_bot);
}
+PRIMITIVE(set_retainstack)
+{
+ PRIMITIVE_GETVM()->vmprim_set_retainstack();
+}
+
/* Used to implement call( */
-PRIMITIVE(check_datastack)
+inline void factorvm::vmprim_check_datastack()
{
fixnum out = to_fixnum(dpop());
fixnum in = to_fixnum(dpop());
}
}
+PRIMITIVE(check_datastack)
+{
+ PRIMITIVE_GETVM()->vmprim_check_datastack();
+}
+
}
context *next;
};
-extern cell ds_size, rs_size;
-
#define ds_bot (stack_chain->datastack_region->start)
#define ds_top (stack_chain->datastack_region->end)
#define rs_bot (stack_chain->retainstack_region->start)
DEFPUSHPOP(d,ds)
DEFPUSHPOP(r,rs)
-void reset_datastack();
-void reset_retainstack();
-void fix_stacks();
-void init_stacks(cell ds_size, cell rs_size);
-
PRIMITIVE(datastack);
PRIMITIVE(retainstack);
PRIMITIVE(set_datastack);
PRIMITIVE(set_retainstack);
PRIMITIVE(check_datastack);
-VM_C_API void save_stacks();
-VM_C_API void nest_stacks();
-VM_C_API void unnest_stacks();
+struct factorvm;
+VM_C_API void nest_stacks(factorvm *vm);
+VM_C_API void unnest_stacks(factorvm *vm);
}
-VM_C_API factor::context *stack_chain;
#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");
}
/* Defined in assembly */
-VM_ASM_API void c_to_factor(cell quot);
-VM_ASM_API void throw_impl(cell quot, stack_frame *rewind);
-VM_ASM_API void lazy_jit_compile(cell quot);
+VM_ASM_API void c_to_factor(cell quot, void *vm);
+VM_ASM_API void throw_impl(cell quot, stack_frame *rewind, void *vm);
+VM_ASM_API void lazy_jit_compile(cell quot, void *vm);
VM_ASM_API void flush_icache(cell start, cell len);
VM_ASM_API void set_callstack(stack_frame *to,
#define ARG0 %eax
#define ARG1 %edx
+#define ARG2 %ecx
#define STACK_REG %esp
#define DS_REG %esi
#define RETURN_REG %eax
rdtsc
ret
-DEF(void,primitive_inline_cache_miss,(void)):
+DEF(void,primitive_inline_cache_miss,(void *vm)):
mov (%esp),%ebx
-DEF(void,primitive_inline_cache_miss_tail,(void)):
+DEF(void,primitive_inline_cache_miss_tail,(void *vm)):
sub $8,%esp
+ push ARG0 /* push vm ptr */
push %ebx
call MANGLE(inline_cache_miss)
- add $12,%esp
+ add $16,%esp
jmp *%eax
DEF(void,get_sse_env,(void*)):
fldcw 2(%eax)
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 */
+ /* clear x87 stack, but preserve rounding mode and exception flags */
+ sub $2,STACK_REG
+ fnstcw (STACK_REG)
+ fninit
+ fldcw (STACK_REG)
+ /* rewind_to */
+ mov ARG1,STACK_REG
+ mov NV_TEMP_REG,ARG1
+ jmp *QUOT_XT_OFFSET(ARG0)
+
+
+DEF(F_FASTCALL void,lazy_jit_compile,(CELL quot, void *vm)):
+ mov ARG1,NV_TEMP_REG /* stash vm ptr */
+ mov STACK_REG,ARG1 /* Save stack pointer */
+ sub $STACK_PADDING,STACK_REG
+ push NV_TEMP_REG /* push vm ptr as arg3 */
+ call MANGLE(lazy_jit_compile_impl)
+ pop NV_TEMP_REG
+ mov RETURN_REG,ARG0 /* No-op on 32-bit */
+ add $STACK_PADDING,STACK_REG
+ jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */
+
+
#include "cpu-x86.S"
#ifdef WINDOWS
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)))
}
or %rdx,%rax
ret
-DEF(void,primitive_inline_cache_miss,(void)):
+DEF(void,primitive_inline_cache_miss,(void *vm)):
mov (%rsp),%rbx
-DEF(void,primitive_inline_cache_miss_tail,(void)):
+DEF(void,primitive_inline_cache_miss_tail,(void *vm)):
sub $STACK_PADDING,%rsp
+ mov ARG0,ARG1
mov %rbx,ARG0
call MANGLE(inline_cache_miss)
add $STACK_PADDING,%rsp
jmp *%rax
+
DEF(void,get_sse_env,(void*)):
stmxcsr (%rdi)
ret
fldcw 2(%rdi)
ret
+DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to, void *vm)):
+ /* clear x87 stack, but preserve rounding mode and exception flags */
+ sub $2,STACK_REG
+ fnstcw (STACK_REG)
+ fninit
+ fldcw (STACK_REG)
+ /* rewind_to */
+ mov ARG1,STACK_REG
+ mov ARG2,ARG1 /* make vm ptr 2nd arg in case quot_xt = lazy_jit_compile */
+ jmp *QUOT_XT_OFFSET(ARG0)
+
+DEF(F_FASTCALL void,lazy_jit_compile,(CELL quot, void *vm)):
+ mov ARG1,ARG2 /* vm is 3rd arg */
+ mov STACK_REG,ARG1 /* Save stack pointer */
+ sub $STACK_PADDING,STACK_REG
+ call MANGLE(lazy_jit_compile_impl)
+ mov RETURN_REG,ARG0 /* No-op on 32-bit */
+ add $STACK_PADDING,STACK_REG
+ jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */
+
+
#include "cpu-x86.S"
register cell rs asm("r15");
#define VM_ASM_API VM_C_API
-
+#define VM_ASM_API_OVERFLOW VM_C_API
}
-DEF(void,primitive_fixnum_add,(void)):
+DEF(void,primitive_fixnum_add,(void *myvm)):
+ mov ARG0, ARG2 /* save vm ptr for overflow */
mov (DS_REG),ARG0
mov -CELL_SIZE(DS_REG),ARG1
sub $CELL_SIZE,DS_REG
mov ARITH_TEMP_1,(DS_REG)
ret
-DEF(void,primitive_fixnum_subtract,(void)):
+DEF(void,primitive_fixnum_subtract,(void *myvm)):
+ mov ARG0, ARG2 /* save vm ptr for overflow */
mov (DS_REG),ARG1
mov -CELL_SIZE(DS_REG),ARG0
sub $CELL_SIZE,DS_REG
mov ARITH_TEMP_1,(DS_REG)
ret
-DEF(void,primitive_fixnum_multiply,(void)):
+DEF(void,primitive_fixnum_multiply,(void *myvm)):
+ push ARG0 /* save vm ptr for overflow */
mov (DS_REG),ARITH_TEMP_1
mov ARITH_TEMP_1,DIV_RESULT
mov -CELL_SIZE(DS_REG),ARITH_TEMP_2
imul ARITH_TEMP_2
jo multiply_overflow
mov DIV_RESULT,(DS_REG)
+ pop ARG2
ret
multiply_overflow:
sar $3,ARITH_TEMP_1
mov ARITH_TEMP_1,ARG0
mov ARITH_TEMP_2,ARG1
+ pop ARG2
jmp MANGLE(overflow_fixnum_multiply)
-DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
+
+DEF(F_FASTCALL void,c_to_factor,(CELL quot, void *vm)):
PUSH_NONVOLATILE
mov ARG0,NV_TEMP_REG
-
/* Create register shadow area for Win64 */
sub $32,STACK_REG
/* Save stack pointer */
lea -CELL_SIZE(STACK_REG),ARG0
+ push ARG1 /* save vm ptr */
call MANGLE(save_callstack_bottom)
-
+ pop ARG1
+
/* Call quot-xt */
mov NV_TEMP_REG,ARG0
call *QUOT_XT_OFFSET(ARG0)
POP_NONVOLATILE
ret
-DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
- /* clear x87 stack, but preserve rounding mode and exception flags */
- sub $2,STACK_REG
- fnstcw (STACK_REG)
- fninit
- fldcw (STACK_REG)
- /* rewind_to */
- mov ARG1,STACK_REG
- jmp *QUOT_XT_OFFSET(ARG0)
-
-DEF(F_FASTCALL void,lazy_jit_compile,(CELL quot)):
- mov STACK_REG,ARG1 /* Save stack pointer */
- sub $STACK_PADDING,STACK_REG
- call MANGLE(lazy_jit_compile_impl)
- mov RETURN_REG,ARG0 /* No-op on 32-bit */
- add $STACK_PADDING,STACK_REG
- jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */
-
/* cpu.x86.features calls this */
DEF(bool,sse_version,(void)):
mov $0x1,RETURN_REG
sse_1:
mov $10,RETURN_REG
ret
+
#ifdef WINDOWS
.section .drectve
.ascii " -export:sse_version"
}
/* Defined in assembly */
-VM_ASM_API void c_to_factor(cell quot);
-VM_ASM_API void throw_impl(cell quot, stack_frame *rewind_to);
-VM_ASM_API void lazy_jit_compile(cell quot);
+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);
VM_C_API void set_callstack(stack_frame *to,
stack_frame *from,
namespace factor
{
-/* used during garbage collection only */
-zone *newspace;
-bool performing_gc;
-bool performing_compaction;
-cell collecting_gen;
-
-/* if true, we are collecting aging space for the second time, so if it is still
-full, we go on to collect tenured */
-bool collecting_aging_again;
-
-/* in case a generation fills up in the middle of a gc, we jump back
-up to try collecting the next generation. */
-jmp_buf gc_jmp;
-
-gc_stats stats[max_gen_count];
-u64 cards_scanned;
-u64 decks_scanned;
-u64 card_scan_time;
-cell code_heap_scans;
-
-/* What generation was being collected when copy_code_heap_roots() was last
-called? Until the next call to add_code_block(), future
-collections of younger generations don't have to touch the code
-heap. */
-cell last_code_heap_scan;
-
-/* sometimes we grow the heap */
-bool growing_data_heap;
-data_heap *old_data_heap;
-
-void init_data_gc()
+void factorvm::init_data_gc()
{
performing_gc = false;
last_code_heap_scan = data->nursery();
collecting_aging_again = false;
}
+
/* Given a pointer to oldspace, copy it to newspace */
-static object *copy_untagged_object_impl(object *pointer, cell size)
+object *factorvm::copy_untagged_object_impl(object *pointer, cell size)
{
if(newspace->here + size >= newspace->end)
longjmp(gc_jmp,1);
return newpointer;
}
-static object *copy_object_impl(object *untagged)
+
+object *factorvm::copy_object_impl(object *untagged)
{
object *newpointer = copy_untagged_object_impl(untagged,untagged_object_size(untagged));
untagged->h.forward_to(newpointer);
return newpointer;
}
-static bool should_copy_p(object *untagged)
+
+bool factorvm::should_copy_p(object *untagged)
{
if(in_zone(newspace,untagged))
return false;
}
}
+
/* Follow a chain of forwarding pointers */
-static object *resolve_forwarding(object *untagged)
+object *factorvm::resolve_forwarding(object *untagged)
{
check_data_pointer(untagged);
}
}
-template <typename T> static T *copy_untagged_object(T *untagged)
+
+template <typename TYPE> TYPE *factorvm::copy_untagged_object(TYPE *untagged)
{
check_data_pointer(untagged);
if(untagged->h.forwarding_pointer_p())
- untagged = (T *)resolve_forwarding(untagged->h.forwarding_pointer());
+ untagged = (TYPE *)resolve_forwarding(untagged->h.forwarding_pointer());
else
{
untagged->h.check_header();
- untagged = (T *)copy_object_impl(untagged);
+ untagged = (TYPE *)copy_object_impl(untagged);
}
return untagged;
}
-static cell copy_object(cell pointer)
+
+cell factorvm::copy_object(cell pointer)
{
return RETAG(copy_untagged_object(untag<object>(pointer)),TAG(pointer));
}
-void copy_handle(cell *handle)
+
+void factorvm::copy_handle(cell *handle)
{
cell pointer = *handle;
}
}
+
/* Scan all the objects in the card */
-static void copy_card(card *ptr, cell gen, cell here)
+void factorvm::copy_card(card *ptr, cell gen, cell here)
{
cell card_scan = card_to_addr(ptr) + card_offset(ptr);
cell card_end = card_to_addr(ptr + 1);
cards_scanned++;
}
-static void copy_card_deck(card_deck *deck, cell gen, card mask, card unmask)
+
+void factorvm::copy_card_deck(card_deck *deck, cell gen, card mask, card unmask)
{
card *first_card = deck_to_card(deck);
card *last_card = deck_to_card(deck + 1);
decks_scanned++;
}
+
/* Copy all newspace objects referenced from marked cards to the destination */
-static void copy_gen_cards(cell gen)
+void factorvm::copy_gen_cards(cell gen)
{
card_deck *first_deck = addr_to_deck(data->generations[gen].start);
card_deck *last_deck = addr_to_deck(data->generations[gen].end);
}
}
+
/* Scan cards in all generations older than the one being collected, copying
old->new references */
-static void copy_cards()
+void factorvm::copy_cards()
{
u64 start = current_micros();
card_scan_time += (current_micros() - start);
}
+
/* Copy all tagged pointers in a range of memory */
-static void copy_stack_elements(segment *region, cell top)
+void factorvm::copy_stack_elements(segment *region, cell top)
{
cell ptr = region->start;
copy_handle((cell*)ptr);
}
-static void copy_registered_locals()
+
+void factorvm::copy_registered_locals()
{
std::vector<cell>::const_iterator iter = gc_locals.begin();
std::vector<cell>::const_iterator end = gc_locals.end();
copy_handle((cell *)(*iter));
}
-static void copy_registered_bignums()
+
+void factorvm::copy_registered_bignums()
{
std::vector<cell>::const_iterator iter = gc_bignums.begin();
std::vector<cell>::const_iterator end = gc_bignums.end();
}
}
+
/* Copy roots over at the start of GC, namely various constants, stacks,
the user environment and extra roots registered by local_roots.hpp */
-static void copy_roots()
+void factorvm::copy_roots()
{
copy_handle(&T);
copy_handle(&bignum_zero);
copy_handle(&userenv[i]);
}
-static cell copy_next_from_nursery(cell scan)
+
+cell factorvm::copy_next_from_nursery(cell scan)
{
cell *obj = (cell *)scan;
cell *end = (cell *)(scan + binary_payload_start((object *)scan));
return scan + untagged_object_size((object *)scan);
}
-static cell copy_next_from_aging(cell scan)
+
+cell factorvm::copy_next_from_aging(cell scan)
{
cell *obj = (cell *)scan;
cell *end = (cell *)(scan + binary_payload_start((object *)scan));
return scan + untagged_object_size((object *)scan);
}
-static cell copy_next_from_tenured(cell scan)
+
+cell factorvm::copy_next_from_tenured(cell scan)
{
cell *obj = (cell *)scan;
cell *end = (cell *)(scan + binary_payload_start((object *)scan));
return scan + untagged_object_size((object *)scan);
}
-void copy_reachable_objects(cell scan, cell *end)
+
+void factorvm::copy_reachable_objects(cell scan, cell *end)
{
if(collecting_gen == data->nursery())
{
}
}
+
/* Prepare to start copying reachable objects into an unused zone */
-static void begin_gc(cell requested_bytes)
+void factorvm::begin_gc(cell requested_bytes)
{
if(growing_data_heap)
{
}
}
-static void end_gc(cell gc_elapsed)
+
+void factorvm::end_gc(cell gc_elapsed)
{
gc_stats *s = &stats[collecting_gen];
collecting_aging_again = false;
}
+
/* Collect gen and all younger generations.
If growing_data_heap_ is true, we must grow the data heap to such a size that
an allocation of requested_bytes won't fail */
-void garbage_collection(cell gen,
- bool growing_data_heap_,
- cell requested_bytes)
+void factorvm::garbage_collection(cell gen,bool growing_data_heap_,cell requested_bytes)
{
if(gc_off)
{
code_heap_scans++;
if(collecting_gen == data->tenured())
- free_unmarked(&code,(heap_iterator)update_literal_and_word_references);
+ free_unmarked(&code,(heap_iterator)factor::update_literal_and_word_references);
else
copy_code_heap_roots();
performing_gc = false;
}
-void gc()
+
+void factorvm::gc()
{
garbage_collection(data->tenured(),false,0);
}
-PRIMITIVE(gc)
+
+inline void factorvm::vmprim_gc()
{
gc();
}
-PRIMITIVE(gc_stats)
+PRIMITIVE(gc)
+{
+ PRIMITIVE_GETVM()->vmprim_gc();
+}
+
+inline void factorvm::vmprim_gc_stats()
{
- growable_array result;
+ growable_array result(this);
cell i;
u64 total_gc_time = 0;
dpush(result.elements.value());
}
-void clear_gc_stats()
+PRIMITIVE(gc_stats)
+{
+ PRIMITIVE_GETVM()->vmprim_gc_stats();
+}
+
+void factorvm::clear_gc_stats()
{
for(cell i = 0; i < max_gen_count; i++)
memset(&stats[i],0,sizeof(gc_stats));
code_heap_scans = 0;
}
-PRIMITIVE(clear_gc_stats)
+inline void factorvm::vmprim_clear_gc_stats()
{
clear_gc_stats();
}
+PRIMITIVE(clear_gc_stats)
+{
+ PRIMITIVE_GETVM()->vmprim_clear_gc_stats();
+}
+
/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this
to coalesce equal but distinct quotations and wrappers. */
-PRIMITIVE(become)
+inline void factorvm::vmprim_become()
{
array *new_objects = untag_check<array>(dpop());
array *old_objects = untag_check<array>(dpop());
compile_all_words();
}
-VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size)
+PRIMITIVE(become)
+{
+ PRIMITIVE_GETVM()->vmprim_become();
+}
+
+void factorvm::inline_gc(cell *gc_roots_base, cell gc_roots_size)
{
for(cell i = 0; i < gc_roots_size; i++)
gc_locals.push_back((cell)&gc_roots_base[i]);
gc_locals.pop_back();
}
+VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factorvm *myvm)
+{
+ ASSERTVM();
+ VM_PTR->inline_gc(gc_roots_base,gc_roots_size);
+}
+
}
u64 bytes_copied;
};
-extern zone *newspace;
-
-extern bool performing_compaction;
-extern cell collecting_gen;
-extern bool collecting_aging_again;
-
-extern cell last_code_heap_scan;
-
-void init_data_gc();
-
-void gc();
-
-inline static bool collecting_accumulation_gen_p()
-{
- return ((data->have_aging_p()
- && collecting_gen == data->aging()
- && !collecting_aging_again)
- || collecting_gen == data->tenured());
-}
-
-void copy_handle(cell *handle);
-
-void garbage_collection(volatile cell gen,
- bool growing_data_heap_,
- cell requested_bytes);
-
/* We leave this many bytes free at the top of the nursery so that inline
allocation (which does not call GC because of possible roots in volatile
registers) does not run out of memory */
static const cell allot_buffer_zone = 1024;
-inline static object *allot_zone(zone *z, cell a)
-{
- cell h = z->here;
- z->here = h + align8(a);
- object *obj = (object *)h;
- allot_barrier(obj);
- return obj;
-}
-
-/*
- * It is up to the caller to fill in the object's fields in a meaningful
- * fashion!
- */
-inline static object *allot_object(header header, cell size)
-{
-#ifdef GC_DEBUG
- if(!gc_off)
- gc();
-#endif
-
- object *obj;
-
- if(nursery.size - allot_buffer_zone > size)
- {
- /* If there is insufficient room, collect the nursery */
- if(nursery.here + allot_buffer_zone + size > nursery.end)
- garbage_collection(data->nursery(),false,0);
-
- cell h = nursery.here;
- nursery.here = h + align8(size);
- obj = (object *)h;
- }
- /* If the object is bigger than the nursery, allocate it in
- tenured space */
- else
- {
- zone *tenured = &data->generations[data->tenured()];
-
- /* If tenured space does not have enough room, collect */
- if(tenured->here + size > tenured->end)
- {
- gc();
- tenured = &data->generations[data->tenured()];
- }
-
- /* If it still won't fit, grow the heap */
- if(tenured->here + size > tenured->end)
- {
- garbage_collection(data->tenured(),true,size);
- tenured = &data->generations[data->tenured()];
- }
-
- obj = allot_zone(tenured,size);
-
- /* Allows initialization code to store old->new pointers
- without hitting the write barrier in the common case of
- a nursery allocation */
- write_barrier(obj);
- }
-
- obj->h = header;
- return obj;
-}
-
-template<typename T> T *allot(cell size)
-{
- return (T *)allot_object(header(T::type_number),size);
-}
-
-void copy_reachable_objects(cell scan, cell *end);
-
PRIMITIVE(gc);
PRIMITIVE(gc_stats);
-void clear_gc_stats();
PRIMITIVE(clear_gc_stats);
PRIMITIVE(become);
-
-extern bool growing_data_heap;
-
-inline static void check_data_pointer(object *pointer)
-{
-#ifdef FACTOR_DEBUG
- if(!growing_data_heap)
- {
- assert((cell)pointer >= data->seg->start
- && (cell)pointer < data->seg->end);
- }
-#endif
-}
-
-inline static void check_tagged_pointer(cell tagged)
-{
-#ifdef FACTOR_DEBUG
- if(!immediate_p(tagged))
- {
- object *obj = untag<object>(tagged);
- check_data_pointer(obj);
- obj->h.hi_tag();
- }
-#endif
-}
-
-VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size);
+struct factorvm;
+VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factorvm *myvm);
}
#include "master.hpp"
-factor::zone nursery;
-
namespace factor
{
-/* Set by the -securegc command line argument */
-bool secure_gc;
-
-/* new objects are allocated here */
-VM_C_API zone nursery;
-
-/* GC is off during heap walking */
-bool gc_off;
-
-data_heap *data;
-
-cell init_zone(zone *z, cell size, cell start)
+cell factorvm::init_zone(zone *z, cell size, cell start)
{
z->size = size;
z->start = z->here = start;
return z->end;
}
-void init_card_decks()
+
+void factorvm::init_card_decks()
{
cell start = align(data->seg->start,deck_size);
allot_markers_offset = (cell)data->allot_markers - (start >> card_bits);
decks_offset = (cell)data->decks - (start >> deck_bits);
}
-data_heap *alloc_data_heap(cell gens,
- cell young_size,
- cell aging_size,
- cell tenured_size)
+data_heap *factorvm::alloc_data_heap(cell gens, cell young_size,cell aging_size,cell tenured_size)
{
young_size = align(young_size,deck_size);
aging_size = align(aging_size,deck_size);
return data;
}
-data_heap *grow_data_heap(data_heap *data, cell requested_bytes)
+
+data_heap *factorvm::grow_data_heap(data_heap *data, cell requested_bytes)
{
cell new_tenured_size = (data->tenured_size * 2) + requested_bytes;
new_tenured_size);
}
-void dealloc_data_heap(data_heap *data)
+
+void factorvm::dealloc_data_heap(data_heap *data)
{
dealloc_segment(data->seg);
free(data->generations);
free(data);
}
-void clear_cards(cell from, cell to)
+
+void factorvm::clear_cards(cell from, cell to)
{
/* NOTE: reverse order due to heap layout. */
card *first_card = addr_to_card(data->generations[to].start);
memset(first_card,0,last_card - first_card);
}
-void clear_decks(cell from, cell to)
+
+void factorvm::clear_decks(cell from, cell to)
{
/* NOTE: reverse order due to heap layout. */
card_deck *first_deck = addr_to_deck(data->generations[to].start);
memset(first_deck,0,last_deck - first_deck);
}
-void clear_allot_markers(cell from, cell to)
+
+void factorvm::clear_allot_markers(cell from, cell to)
{
/* NOTE: reverse order due to heap layout. */
card *first_card = addr_to_allot_marker((object *)data->generations[to].start);
memset(first_card,invalid_allot_marker,last_card - first_card);
}
-void reset_generation(cell i)
+
+void factorvm::reset_generation(cell i)
{
zone *z = (i == data->nursery() ? &nursery : &data->generations[i]);
memset((void*)z->start,69,z->size);
}
+
/* After garbage collection, any generations which are now empty need to have
their allocation pointers and cards reset. */
-void reset_generations(cell from, cell to)
+void factorvm::reset_generations(cell from, cell to)
{
cell i;
for(i = from; i <= to; i++)
clear_allot_markers(from,to);
}
-void set_data_heap(data_heap *data_)
+
+void factorvm::set_data_heap(data_heap *data_)
{
data = data_;
nursery = data->generations[data->nursery()];
clear_allot_markers(data->nursery(),data->tenured());
}
-void init_data_heap(cell gens,
- cell young_size,
- cell aging_size,
- cell tenured_size,
- bool secure_gc_)
+
+void factorvm::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));
secure_gc = secure_gc_;
init_data_gc();
}
+
/* Size of the object pointed to by a tagged pointer */
-cell object_size(cell tagged)
+cell factorvm::object_size(cell tagged)
{
if(immediate_p(tagged))
return 0;
return untagged_object_size(untag<object>(tagged));
}
+
/* Size of the object pointed to by an untagged pointer */
-cell untagged_object_size(object *pointer)
+cell factorvm::untagged_object_size(object *pointer)
{
return align8(unaligned_object_size(pointer));
}
+
/* Size of the data area of an object pointed to by an untagged pointer */
-cell unaligned_object_size(object *pointer)
+cell factorvm::unaligned_object_size(object *pointer)
{
switch(pointer->h.hi_tag())
{
}
}
-PRIMITIVE(size)
+
+inline void factorvm::vmprim_size()
{
box_unsigned_cell(object_size(dpop()));
}
+PRIMITIVE(size)
+{
+ PRIMITIVE_GETVM()->vmprim_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
we ignore. */
-cell binary_payload_start(object *pointer)
+cell factorvm::binary_payload_start(object *pointer)
{
switch(pointer->h.hi_tag())
{
}
}
+
/* Push memory usage statistics in data heap */
-PRIMITIVE(data_room)
+inline void factorvm::vmprim_data_room()
{
dpush(tag_fixnum((data->cards_end - data->cards) >> 10));
dpush(tag_fixnum((data->decks_end - data->decks) >> 10));
- growable_array a;
+ growable_array a(this);
cell gen;
for(gen = 0; gen < data->gen_count; gen++)
dpush(a.elements.value());
}
-/* A heap walk allows useful things to be done, like finding all
-references to an object for debugging purposes. */
-cell heap_scan_ptr;
+PRIMITIVE(data_room)
+{
+ PRIMITIVE_GETVM()->vmprim_data_room();
+}
/* Disables GC and activates next-object ( -- obj ) primitive */
-void begin_scan()
+void factorvm::begin_scan()
{
heap_scan_ptr = data->generations[data->tenured()].start;
gc_off = true;
}
-void end_scan()
+
+void factorvm::end_scan()
{
gc_off = false;
}
-PRIMITIVE(begin_scan)
+
+inline void factorvm::vmprim_begin_scan()
{
begin_scan();
}
-cell next_object()
+PRIMITIVE(begin_scan)
+{
+ PRIMITIVE_GETVM()->vmprim_begin_scan();
+}
+
+cell factorvm::next_object()
{
if(!gc_off)
general_error(ERROR_HEAP_SCAN,F,F,NULL);
return tag_dynamic(obj);
}
+
/* Push object at heap scan cursor and advance; pushes f when done */
-PRIMITIVE(next_object)
+inline void factorvm::vmprim_next_object()
{
dpush(next_object());
}
+PRIMITIVE(next_object)
+{
+ PRIMITIVE_GETVM()->vmprim_next_object();
+}
+
/* Re-enables GC */
-PRIMITIVE(end_scan)
+inline void factorvm::vmprim_end_scan()
{
gc_off = false;
}
-template<typename T> void each_object(T &functor)
+PRIMITIVE(end_scan)
+{
+ PRIMITIVE_GETVM()->vmprim_end_scan();
+}
+
+template<typename TYPE> void factorvm::each_object(TYPE &functor)
{
begin_scan();
cell obj;
end_scan();
}
+
namespace
{
struct word_accumulator {
growable_array words;
- word_accumulator(int count) : words(count) {}
+ word_accumulator(int count,factorvm *vm) : words(vm,count) {}
void operator()(tagged<object> obj) { if(obj.type_p(WORD_TYPE)) words.add(obj.value()); }
};
}
-cell find_all_words()
+cell factorvm::find_all_words()
{
word_counter counter;
each_object(counter);
- word_accumulator accum(counter.count);
+ word_accumulator accum(counter.count,this);
each_object(accum);
accum.words.trim();
return accum.words.elements.value();
}
+
}
namespace factor
{
-/* Set by the -securegc command line argument */
-extern bool secure_gc;
/* generational copying GC divides memory into zones */
struct zone {
bool have_aging_p() { return gen_count > 2; }
};
-extern data_heap *data;
static const cell max_gen_count = 3;
return (cell)pointer >= z->start && (cell)pointer < z->end;
}
-cell init_zone(zone *z, cell size, cell base);
-
-void init_card_decks();
-
-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);
-void reset_generation(cell i);
-void reset_generations(cell from, cell to);
-
-void set_data_heap(data_heap *data_heap_);
-
-void init_data_heap(cell gens,
- cell young_size,
- cell aging_size,
- cell tenured_size,
- bool secure_gc_);
-
/* set up guard pages to check for under/overflow.
size must be a multiple of the page size */
-segment *alloc_segment(cell size);
+segment *alloc_segment(cell size); // defined in OS-*.cpp files PD
void dealloc_segment(segment *block);
-cell untagged_object_size(object *pointer);
-cell unaligned_object_size(object *pointer);
-cell binary_payload_start(object *pointer);
-cell object_size(cell tagged);
-
-void begin_scan();
-void end_scan();
-cell next_object();
-
PRIMITIVE(data_room);
PRIMITIVE(size);
PRIMITIVE(next_object);
PRIMITIVE(end_scan);
-/* GC is off during heap walking */
-extern bool gc_off;
-
-cell find_all_words();
-
-/* Every object has a regular representation in the runtime, which makes GC
-much simpler. Every slot of the object until binary_payload_start is a pointer
-to some other object. */
-inline static void do_slots(cell obj, void (* iter)(cell *))
-{
- cell scan = obj;
- cell payload_start = binary_payload_start((object *)obj);
- cell end = obj + payload_start;
-
- scan += sizeof(cell);
-
- while(scan < end)
- {
- iter((cell *)scan);
- scan += sizeof(cell);
- }
-}
-
}
-
-/* new objects are allocated here */
-VM_C_API factor::zone nursery;
namespace factor
{
-static bool fep_disabled;
-static bool full_output;
-void print_chars(string* str)
+void factorvm::print_chars(string* str)
{
cell i;
for(i = 0; i < string_capacity(str); i++)
putchar(string_nth(str,i));
}
-void print_word(word* word, cell nesting)
+
+void factorvm::print_word(word* word, cell nesting)
{
if(tagged<object>(word->vocabulary).type_p(STRING_TYPE))
{
}
}
-void print_factor_string(string* str)
+
+void factorvm::print_factor_string(string* str)
{
putchar('"');
print_chars(str);
putchar('"');
}
-void print_array(array* array, cell nesting)
+
+void factorvm::print_array(array* array, cell nesting)
{
cell length = array_capacity(array);
cell i;
print_string("...");
}
-void print_tuple(tuple *tuple, cell nesting)
+
+void factorvm::print_tuple(tuple *tuple, cell nesting)
{
tuple_layout *layout = untag<tuple_layout>(tuple->layout);
cell length = to_fixnum(layout->size);
print_string("...");
}
-void print_nested_obj(cell obj, fixnum nesting)
+
+void factorvm::print_nested_obj(cell obj, fixnum nesting)
{
if(nesting <= 0 && !full_output)
{
}
}
-void print_obj(cell obj)
+
+void factorvm::print_obj(cell obj)
{
print_nested_obj(obj,10);
}
-void print_objects(cell *start, cell *end)
+
+void factorvm::print_objects(cell *start, cell *end)
{
for(; start <= end; start++)
{
}
}
-void print_datastack()
+
+void factorvm::print_datastack()
{
print_string("==== DATA STACK:\n");
print_objects((cell *)ds_bot,(cell *)ds);
}
-void print_retainstack()
+
+void factorvm::print_retainstack()
{
print_string("==== RETAIN STACK:\n");
print_objects((cell *)rs_bot,(cell *)rs);
}
-void print_stack_frame(stack_frame *frame)
+
+void factorvm::print_stack_frame(stack_frame *frame)
{
print_obj(frame_executing(frame));
print_string("\n");
print_string("\n");
}
-void print_callstack()
+void print_stack_frame(stack_frame *frame, factorvm *myvm)
+{
+ return myvm->print_stack_frame(frame);
+}
+
+void factorvm::print_callstack()
{
print_string("==== CALL STACK:\n");
cell bottom = (cell)stack_chain->callstack_bottom;
cell top = (cell)stack_chain->callstack_top;
- iterate_callstack(top,bottom,print_stack_frame);
+ iterate_callstack(top,bottom,factor::print_stack_frame);
}
-void dump_cell(cell x)
+
+void factorvm::dump_cell(cell x)
{
print_cell_hex_pad(x); print_string(": ");
x = *(cell *)x;
nl();
}
-void dump_memory(cell from, cell to)
+
+void factorvm::dump_memory(cell from, cell to)
{
from = UNTAG(from);
dump_cell(from);
}
-void dump_zone(zone *z)
+
+void factorvm::dump_zone(zone *z)
{
print_string("Start="); print_cell(z->start);
print_string(", size="); print_cell(z->size);
print_string(", here="); print_cell(z->here - z->start); nl();
}
-void dump_generations()
+
+void factorvm::dump_generations()
{
cell i;
nl();
}
-void dump_objects(cell type)
+
+void factorvm::dump_objects(cell type)
{
gc();
begin_scan();
end_scan();
}
-cell look_for;
-cell obj;
-void find_data_references_step(cell *scan)
+
+void factorvm::find_data_references_step(cell *scan)
{
if(look_for == *scan)
{
}
}
-void find_data_references(cell look_for_)
+void find_data_references_step(cell *scan,factorvm *myvm)
+{
+ return myvm->find_data_references_step(scan);
+}
+
+void factorvm::find_data_references(cell look_for_)
{
look_for = look_for_;
begin_scan();
while((obj = next_object()) != F)
- do_slots(UNTAG(obj),find_data_references_step);
+ do_slots(UNTAG(obj),factor::find_data_references_step);
end_scan();
}
+
/* Dump all code blocks for debugging */
-void dump_code_heap()
+void factorvm::dump_code_heap()
{
cell reloc_size = 0, literal_size = 0;
print_cell(literal_size); print_string(" bytes of literal data\n");
}
-void factorbug()
+
+void factorvm::factorbug()
{
if(fep_disabled)
{
}
}
-PRIMITIVE(die)
+
+inline void factorvm::vmprim_die()
{
print_string("The die word was called by the library. Unless you called it yourself,\n");
print_string("you have triggered a bug in Factor. Please report.\n");
factorbug();
}
+PRIMITIVE(die)
+{
+ PRIMITIVE_GETVM()->vmprim_die();
+}
+
}
namespace factor
{
-void print_obj(cell obj);
-void print_nested_obj(cell obj, fixnum nesting);
-void dump_generations();
-void factorbug();
-void dump_zone(zone *z);
PRIMITIVE(die);
namespace factor
{
-cell megamorphic_cache_hits;
-cell megamorphic_cache_misses;
-
-static cell search_lookup_alist(cell table, cell klass)
+cell factorvm::search_lookup_alist(cell table, cell klass)
{
array *elements = untag<array>(table);
fixnum index = array_capacity(elements) - 2;
return F;
}
-static cell search_lookup_hash(cell table, cell klass, cell hashcode)
+cell factorvm::search_lookup_hash(cell table, cell klass, cell hashcode)
{
array *buckets = untag<array>(table);
cell bucket = array_nth(buckets,hashcode & (array_capacity(buckets) - 1));
return search_lookup_alist(bucket,klass);
}
-static cell nth_superclass(tuple_layout *layout, fixnum echelon)
+cell factorvm::nth_superclass(tuple_layout *layout, fixnum echelon)
{
cell *ptr = (cell *)(layout + 1);
return ptr[echelon * 2];
}
-static cell nth_hashcode(tuple_layout *layout, fixnum echelon)
+cell factorvm::nth_hashcode(tuple_layout *layout, fixnum echelon)
{
cell *ptr = (cell *)(layout + 1);
return ptr[echelon * 2 + 1];
}
-static cell lookup_tuple_method(cell obj, cell methods)
+cell factorvm::lookup_tuple_method(cell obj, cell methods)
{
tuple_layout *layout = untag<tuple_layout>(untag<tuple>(obj)->layout);
return F;
}
-static cell lookup_hi_tag_method(cell obj, cell methods)
+cell factorvm::lookup_hi_tag_method(cell obj, cell methods)
{
array *hi_tag_methods = untag<array>(methods);
cell tag = untag<object>(obj)->h.hi_tag() - HEADER_TYPE;
return array_nth(hi_tag_methods,tag);
}
-static cell lookup_hairy_method(cell obj, cell methods)
+cell factorvm::lookup_hairy_method(cell obj, cell methods)
{
cell method = array_nth(untag<array>(methods),TAG(obj));
if(tagged<object>(method).type_p(WORD_TYPE))
}
}
-cell lookup_method(cell obj, cell methods)
+cell factorvm::lookup_method(cell obj, cell methods)
{
cell tag = TAG(obj);
if(tag == TUPLE_TYPE || tag == OBJECT_TYPE)
return array_nth(untag<array>(methods),TAG(obj));
}
-PRIMITIVE(lookup_method)
+inline void factorvm::vmprim_lookup_method()
{
cell methods = dpop();
cell obj = dpop();
dpush(lookup_method(obj,methods));
}
-cell object_class(cell obj)
+PRIMITIVE(lookup_method)
+{
+ PRIMITIVE_GETVM()->vmprim_lookup_method();
+}
+
+cell factorvm::object_class(cell obj)
{
switch(TAG(obj))
{
}
}
-static cell method_cache_hashcode(cell klass, array *array)
+cell factorvm::method_cache_hashcode(cell klass, array *array)
{
cell capacity = (array_capacity(array) >> 1) - 1;
return ((klass >> TAG_BITS) & capacity) << 1;
}
-static void update_method_cache(cell cache, cell klass, cell method)
+void factorvm::update_method_cache(cell cache, cell klass, cell method)
{
array *cache_elements = untag<array>(cache);
cell hashcode = method_cache_hashcode(klass,cache_elements);
set_array_nth(cache_elements,hashcode + 1,method);
}
-PRIMITIVE(mega_cache_miss)
+inline void factorvm::vmprim_mega_cache_miss()
{
megamorphic_cache_misses++;
dpush(method);
}
-PRIMITIVE(reset_dispatch_stats)
+PRIMITIVE(mega_cache_miss)
+{
+ PRIMITIVE_GETVM()->vmprim_mega_cache_miss();
+}
+
+inline void factorvm::vmprim_reset_dispatch_stats()
{
megamorphic_cache_hits = megamorphic_cache_misses = 0;
}
-PRIMITIVE(dispatch_stats)
+PRIMITIVE(reset_dispatch_stats)
+{
+ PRIMITIVE_GETVM()->vmprim_reset_dispatch_stats();
+}
+
+inline void factorvm::vmprim_dispatch_stats()
{
- growable_array stats;
+ growable_array stats(this);
stats.add(allot_cell(megamorphic_cache_hits));
stats.add(allot_cell(megamorphic_cache_misses));
stats.trim();
dpush(stats.elements.value());
}
+PRIMITIVE(dispatch_stats)
+{
+ PRIMITIVE_GETVM()->vmprim_dispatch_stats();
+}
+
void quotation_jit::emit_mega_cache_lookup(cell methods_, fixnum index, cell cache_)
{
- gc_root<array> methods(methods_);
- gc_root<array> cache(cache_);
+ gc_root<array> methods(methods_,myvm);
+ gc_root<array> cache(cache_,myvm);
/* Generate machine code to determine the object's class. */
emit_class_lookup(index,PIC_HI_TAG_TUPLE);
/* Do a cache lookup. */
- emit_with(userenv[MEGA_LOOKUP],cache.value());
+ emit_with(myvm->userenv[MEGA_LOOKUP],cache.value());
/* If we end up here, the cache missed. */
- emit(userenv[JIT_PROLOG]);
+ emit(myvm->userenv[JIT_PROLOG]);
/* Push index, method table and cache on the stack. */
push(methods.value());
push(tag_fixnum(index));
push(cache.value());
- word_call(userenv[MEGA_MISS_WORD]);
+ word_call(myvm->userenv[MEGA_MISS_WORD]);
/* Now the new method has been stored into the cache, and its on
the stack. */
- emit(userenv[JIT_EPILOG]);
- emit(userenv[JIT_EXECUTE_JUMP]);
+ emit(myvm->userenv[JIT_EPILOG]);
+ emit(myvm->userenv[JIT_EXECUTE_JUMP]);
}
}
namespace factor
{
-extern cell megamorphic_cache_hits;
-extern cell megamorphic_cache_misses;
-
-cell lookup_method(cell object, cell methods);
PRIMITIVE(lookup_method);
-
-cell object_class(cell object);
-
PRIMITIVE(mega_cache_miss);
-
PRIMITIVE(reset_dispatch_stats);
PRIMITIVE(dispatch_stats);
-void jit_emit_class_lookup(jit *jit, fixnum index, cell type);
-
-void jit_emit_mega_cache_lookup(jit *jit, cell methods, fixnum index, cell cache);
-
}
namespace factor
{
-/* Global variables used to pass fault handler state from signal handler to
-user-space */
-cell signal_number;
-cell signal_fault_addr;
-unsigned int signal_fpu_status;
-stack_frame *signal_callstack_top;
-
-void out_of_memory()
+void factorvm::out_of_memory()
{
print_string("Out of memory\n\n");
dump_generations();
exit(1);
}
-void critical_error(const char* msg, cell tagged)
+void factorvm::critical_error(const char* msg, cell tagged)
{
print_string("You have triggered a bug in Factor. Please report.\n");
print_string("critical_error: "); print_string(msg);
factorbug();
}
-void throw_error(cell error, stack_frame *callstack_top)
+void factorvm::throw_error(cell error, stack_frame *callstack_top)
{
/* If the error handler is set, we rewind any C stack frames and
pass the error to user-space. */
else
callstack_top = stack_chain->callstack_top;
- throw_impl(userenv[BREAK_ENV],callstack_top);
+ throw_impl(userenv[BREAK_ENV],callstack_top,this);
}
/* Error was thrown in early startup before error handler is set, just
crash. */
}
}
-void general_error(vm_error_type error, cell arg1, cell arg2,
- stack_frame *callstack_top)
+void factorvm::general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *callstack_top)
{
throw_error(allot_array_4(userenv[ERROR_ENV],
tag_fixnum(error),arg1,arg2),callstack_top);
}
-void type_error(cell type, cell tagged)
+
+void factorvm::type_error(cell type, cell tagged)
{
general_error(ERROR_TYPE,tag_fixnum(type),tagged,NULL);
}
-void not_implemented_error()
+void factorvm::not_implemented_error()
{
general_error(ERROR_NOT_IMPLEMENTED,F,F,NULL);
}
+
/* Test if 'fault' is in the guard page at the top or bottom (depending on
offset being 0 or -1) of area+area_size */
-bool in_page(cell fault, cell area, cell area_size, int offset)
+bool factorvm::in_page(cell fault, cell area, cell area_size, int offset)
{
int pagesize = getpagesize();
area += area_size;
return fault >= area && fault <= area + pagesize;
}
-void memory_protection_error(cell addr, stack_frame *native_stack)
+void factorvm::memory_protection_error(cell addr, stack_frame *native_stack)
{
if(in_page(addr, ds_bot, 0, -1))
general_error(ERROR_DS_UNDERFLOW,F,F,native_stack);
general_error(ERROR_MEMORY,allot_cell(addr),F,native_stack);
}
-void signal_error(int signal, stack_frame *native_stack)
+void factorvm::signal_error(int signal, stack_frame *native_stack)
{
general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack);
}
-void divide_by_zero_error()
+void factorvm::divide_by_zero_error()
{
general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL);
}
-void fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top)
+void factorvm::fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top)
{
general_error(ERROR_FP_TRAP,tag_fixnum(fpu_status),F,signal_callstack_top);
}
+inline void factorvm::vmprim_call_clear()
+{
+ throw_impl(dpop(),stack_chain->callstack_bottom,this);
+}
+
PRIMITIVE(call_clear)
{
- throw_impl(dpop(),stack_chain->callstack_bottom);
+ PRIMITIVE_GETVM()->vmprim_call_clear();
}
/* For testing purposes */
-PRIMITIVE(unimplemented)
+inline void factorvm::vmprim_unimplemented()
{
not_implemented_error();
}
-void memory_signal_handler_impl()
+PRIMITIVE(unimplemented)
+{
+ PRIMITIVE_GETVM()->vmprim_unimplemented();
+}
+
+void factorvm::memory_signal_handler_impl()
{
memory_protection_error(signal_fault_addr,signal_callstack_top);
}
-void misc_signal_handler_impl()
+void memory_signal_handler_impl()
+{
+ SIGNAL_VM_PTR()->memory_signal_handler_impl();
+}
+
+void factorvm::misc_signal_handler_impl()
{
signal_error(signal_number,signal_callstack_top);
}
-void fp_signal_handler_impl()
+void misc_signal_handler_impl()
+{
+ SIGNAL_VM_PTR()->misc_signal_handler_impl();
+}
+
+void factorvm::fp_signal_handler_impl()
{
fp_trap_error(signal_fpu_status,signal_callstack_top);
}
+void fp_signal_handler_impl()
+{
+ SIGNAL_VM_PTR()->fp_signal_handler_impl();
+}
+
}
ERROR_FP_TRAP,
};
-void out_of_memory();
-void fatal_error(const char* msg, cell tagged);
-void critical_error(const char* msg, cell tagged);
-
PRIMITIVE(die);
-
-void throw_error(cell error, stack_frame *native_stack);
-void general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *native_stack);
-void divide_by_zero_error();
-void memory_protection_error(cell addr, stack_frame *native_stack);
-void signal_error(int signal, stack_frame *native_stack);
-void type_error(cell type, cell tagged);
-void not_implemented_error();
-void fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top);
-
PRIMITIVE(call_clear);
PRIMITIVE(unimplemented);
-/* Global variables used to pass fault handler state from signal handler to
-user-space */
-extern cell signal_number;
-extern cell signal_fault_addr;
-extern unsigned int signal_fpu_status;
-extern stack_frame *signal_callstack_top;
-
+void fatal_error(const char* msg, cell tagged);
void memory_signal_handler_impl();
void fp_signal_handler_impl();
void misc_signal_handler_impl();
namespace factor
{
-VM_C_API void default_parameters(vm_parameters *p)
+factorvm *vm;
+
+void init_globals()
+{
+ init_platform_globals();
+}
+
+void factorvm::default_parameters(vm_parameters *p)
{
p->image_path = NULL;
#ifdef WINDOWS
p->console = false;
#else
- p->console = true;
+ if (this == vm)
+ p->console = true;
+ else
+ p->console = false;
+
#endif
p->stack_traces = true;
}
-static bool factor_arg(const vm_char* str, const vm_char* arg, cell* value)
+bool factorvm::factor_arg(const vm_char* str, const vm_char* arg, cell* value)
{
int val;
if(SSCANF(str,arg,&val) > 0)
return false;
}
-VM_C_API void init_parameters_from_args(vm_parameters *p, int argc, vm_char **argv)
+void factorvm::init_parameters_from_args(vm_parameters *p, int argc, vm_char **argv)
{
default_parameters(p);
p->executable_path = argv[0];
}
/* Do some initialization that we do once only */
-static void do_stage1_init()
+void factorvm::do_stage1_init()
{
print_string("*** Stage 2 early init... ");
fflush(stdout);
fflush(stdout);
}
-VM_C_API void init_factor(vm_parameters *p)
+void factorvm::init_factor(vm_parameters *p)
{
/* Kilobytes */
p->ds_size = align_page(p->ds_size << 10);
}
/* May allocate memory */
-VM_C_API void pass_args_to_factor(int argc, vm_char **argv)
+void factorvm::pass_args_to_factor(int argc, vm_char **argv)
{
- growable_array args;
+ growable_array args(this);
int i;
- for(i = 1; i < argc; i++)
+ for(i = 1; i < argc; i++){
args.add(allot_alien(F,(cell)argv[i]));
+ }
args.trim();
userenv[ARGS_ENV] = args.elements.value();
}
-static void start_factor(vm_parameters *p)
+void factorvm::start_factor(vm_parameters *p)
{
if(p->fep) factorbug();
unnest_stacks();
}
-VM_C_API void start_embedded_factor(vm_parameters *p)
+
+char *factorvm::factor_eval_string(char *string)
+{
+ char *(*callback)(char *) = (char *(*)(char *))alien_offset(userenv[EVAL_CALLBACK_ENV]);
+ return callback(string);
+}
+
+void factorvm::factor_eval_free(char *result)
{
- userenv[EMBEDDED_ENV] = T;
- start_factor(p);
+ free(result);
}
-VM_C_API void start_standalone_factor(int argc, vm_char **argv)
+void factorvm::factor_yield()
+{
+ void (*callback)() = (void (*)())alien_offset(userenv[YIELD_CALLBACK_ENV]);
+ callback();
+}
+
+void factorvm::factor_sleep(long us)
+{
+ void (*callback)(long) = (void (*)(long))alien_offset(userenv[SLEEP_CALLBACK_ENV]);
+ callback(us);
+}
+
+void factorvm::start_standalone_factor(int argc, vm_char **argv)
{
vm_parameters p;
default_parameters(&p);
start_factor(&p);
}
-VM_C_API char *factor_eval_string(char *string)
-{
- char *(*callback)(char *) = (char *(*)(char *))alien_offset(userenv[EVAL_CALLBACK_ENV]);
- return callback(string);
-}
+struct startargs {
+ int argc;
+ vm_char **argv;
+};
-VM_C_API void factor_eval_free(char *result)
+void* start_standalone_factor_thread(void *arg)
{
- free(result);
+ factorvm *newvm = new factorvm;
+ register_vm_with_thread(newvm);
+ startargs *args = (startargs*) arg;
+ newvm->start_standalone_factor(args->argc, args->argv);
+ return 0;
}
-VM_C_API void factor_yield()
+
+VM_C_API void start_standalone_factor(int argc, vm_char **argv)
{
- void (*callback)() = (void (*)())alien_offset(userenv[YIELD_CALLBACK_ENV]);
- callback();
+ factorvm *newvm = new factorvm;
+ vm = newvm;
+ register_vm_with_thread(newvm);
+ return newvm->start_standalone_factor(argc,argv);
}
-VM_C_API void factor_sleep(long us)
+VM_C_API THREADHANDLE start_standalone_factor_in_new_thread(int argc, vm_char **argv)
{
- void (*callback)(long) = (void (*)(long))alien_offset(userenv[SLEEP_CALLBACK_ENV]);
- callback(us);
+ startargs *args = new startargs; // leaks startargs structure
+ args->argc = argc; args->argv = argv;
+ return start_thread(start_standalone_factor_thread,args);
}
}
namespace factor
{
-VM_C_API void default_parameters(vm_parameters *p);
-VM_C_API void init_parameters_from_args(vm_parameters *p, int argc, vm_char **argv);
-VM_C_API void init_factor(vm_parameters *p);
-VM_C_API void pass_args_to_factor(int argc, vm_char **argv);
-VM_C_API void start_embedded_factor(vm_parameters *p);
-VM_C_API void start_standalone_factor(int argc, vm_char **argv);
-
-VM_C_API char *factor_eval_string(char *string);
-VM_C_API void factor_eval_free(char *result);
-VM_C_API void factor_yield();
-VM_C_API void factor_sleep(long ms);
+VM_C_API void init_globals();
+VM_C_API void start_standalone_factor(int argc, vm_char **argv);
+VM_C_API THREADHANDLE start_standalone_factor_in_new_thread(int argc, vm_char **argv);
}
return array_size<T>(array_capacity(array));
}
-template <typename T> T *allot_array_internal(cell capacity)
-{
- T *array = allot<T>(array_size<T>(capacity));
- array->capacity = tag_fixnum(capacity);
- return array;
-}
-
-template <typename T> bool reallot_array_in_place_p(T *array, cell capacity)
-{
- return in_zone(&nursery,array) && capacity <= array_capacity(array);
-}
-
-template <typename T> T *reallot_array(T *array_, cell capacity)
-{
- gc_root<T> array(array_);
-
- if(reallot_array_in_place_p(array.untagged(),capacity))
- {
- array->capacity = tag_fixnum(capacity);
- return array.untagged();
- }
- else
- {
- cell to_copy = array_capacity(array.untagged());
- if(capacity < to_copy)
- to_copy = capacity;
-
- T *new_array = allot_array_internal<T>(capacity);
-
- memcpy(new_array + 1,array.untagged() + 1,to_copy * T::element_size);
- memset((char *)(new_array + 1) + to_copy * T::element_size,
- 0,(capacity - to_copy) * T::element_size);
-
- return new_array;
- }
-}
-
}
{
/* Certain special objects in the image are known to the runtime */
-static void init_objects(image_header *h)
+void factorvm::init_objects(image_header *h)
{
memcpy(userenv,h->userenv,sizeof(userenv));
bignum_neg_one = h->bignum_neg_one;
}
-cell data_relocation_base;
-static void load_data_heap(FILE *file, image_header *h, vm_parameters *p)
+
+void factorvm::load_data_heap(FILE *file, image_header *h, vm_parameters *p)
{
cell good_size = h->data_size + (1 << 20);
data_relocation_base = h->data_relocation_base;
}
-cell code_relocation_base;
-static void load_code_heap(FILE *file, image_header *h, vm_parameters *p)
+
+void factorvm::load_code_heap(FILE *file, image_header *h, vm_parameters *p)
{
if(h->code_size > p->code_size)
fatal_error("Code heap too small to fit image",h->code_size);
build_free_list(&code,h->code_size);
}
+
/* Save the current image to disk */
-bool save_image(const vm_char *filename)
+bool factorvm::save_image(const vm_char *filename)
{
FILE* file;
image_header h;
return ok;
}
-PRIMITIVE(save_image)
+
+inline void factorvm::vmprim_save_image()
{
/* do a full GC to push everything into tenured space */
gc();
- gc_root<byte_array> path(dpop());
- path.untag_check();
+ gc_root<byte_array> path(dpop(),this);
+ path.untag_check(this);
save_image((vm_char *)(path.untagged() + 1));
}
-PRIMITIVE(save_image_and_exit)
-{
+PRIMITIVE(save_image)
+{
+ PRIMITIVE_GETVM()->vmprim_save_image();
+}
+
+inline void factorvm::vmprim_save_image_and_exit()
+{
/* We unbox this before doing anything else. This is the only point
where we might throw an error, so we have to throw an error here since
later steps destroy the current image. */
- gc_root<byte_array> path(dpop());
- path.untag_check();
+ gc_root<byte_array> path(dpop(),this);
+ path.untag_check(this);
/* strip out userenv data which is set on startup anyway */
for(cell i = 0; i < USER_ENV; i++)
exit(1);
}
-static void data_fixup(cell *cell)
+PRIMITIVE(save_image_and_exit)
+{
+ PRIMITIVE_GETVM()->vmprim_save_image_and_exit();
+}
+
+void factorvm::data_fixup(cell *cell)
{
if(immediate_p(*cell))
return;
*cell += (tenured->start - data_relocation_base);
}
-template <typename T> void code_fixup(T **handle)
+void data_fixup(cell *cell, factorvm *myvm)
+{
+ return myvm->data_fixup(cell);
+}
+
+template <typename TYPE> void factorvm::code_fixup(TYPE **handle)
{
- T *ptr = *handle;
- T *new_ptr = (T *)(((cell)ptr) + (code.seg->start - code_relocation_base));
+ TYPE *ptr = *handle;
+ TYPE *new_ptr = (TYPE *)(((cell)ptr) + (code.seg->start - code_relocation_base));
*handle = new_ptr;
}
-static void fixup_word(word *word)
+
+void factorvm::fixup_word(word *word)
{
if(word->code)
code_fixup(&word->code);
code_fixup(&word->xt);
}
-static void fixup_quotation(quotation *quot)
+
+void factorvm::fixup_quotation(quotation *quot)
{
if(quot->code)
{
quot->xt = (void *)lazy_jit_compile;
}
-static void fixup_alien(alien *d)
+
+void factorvm::fixup_alien(alien *d)
{
d->expired = T;
}
-static void fixup_stack_frame(stack_frame *frame)
+
+void factorvm::fixup_stack_frame(stack_frame *frame)
{
code_fixup(&frame->xt);
code_fixup(&FRAME_RETURN_ADDRESS(frame));
}
-static void fixup_callstack_object(callstack *stack)
+void fixup_stack_frame(stack_frame *frame, factorvm *myvm)
+{
+ return myvm->fixup_stack_frame(frame);
+}
+
+void factorvm::fixup_callstack_object(callstack *stack)
{
- iterate_callstack_object(stack,fixup_stack_frame);
+ iterate_callstack_object(stack,factor::fixup_stack_frame);
}
+
/* Initialize an object in a newly-loaded image */
-static void relocate_object(object *object)
+void factorvm::relocate_object(object *object)
{
cell hi_tag = object->h.hi_tag();
}
else
{
- do_slots((cell)object,data_fixup);
+ do_slots((cell)object,factor::data_fixup);
switch(hi_tag)
{
}
}
+
/* Since the image might have been saved with a different base address than
where it is loaded, we need to fix up pointers in the image. */
-void relocate_data()
+void factorvm::relocate_data()
{
cell relocating;
}
}
-static void fixup_code_block(code_block *compiled)
+
+void factorvm::fixup_code_block(code_block *compiled)
{
/* relocate literal table data */
data_fixup(&compiled->relocation);
relocate_code_block(compiled);
}
-void relocate_code()
+void fixup_code_block(code_block *compiled,factorvm *myvm)
+{
+ return myvm->fixup_code_block(compiled);
+}
+
+void factorvm::relocate_code()
{
- iterate_code_heap(fixup_code_block);
+ iterate_code_heap(factor::fixup_code_block);
}
+
/* Read an image file from disk, only done once during startup */
/* This function also initializes the data and code heaps */
-void load_image(vm_parameters *p)
+void factorvm::load_image(vm_parameters *p)
{
FILE *file = OPEN_READ(p->image_path);
if(file == NULL)
userenv[IMAGE_ENV] = allot_alien(F,(cell)p->image_path);
}
+
}
cell max_pic_size;
};
-void load_image(vm_parameters *p);
-bool save_image(const vm_char *file);
-
PRIMITIVE(save_image);
PRIMITIVE(save_image_and_exit);
namespace factor
{
-cell max_pic_size;
-cell cold_call_to_ic_transitions;
-cell ic_to_pic_transitions;
-cell pic_to_mega_transitions;
-
-/* PIC_TAG, PIC_HI_TAG, PIC_TUPLE, PIC_HI_TAG_TUPLE */
-cell pic_counts[4];
-
-void init_inline_caching(int max_size)
+void factorvm::init_inline_caching(int max_size)
{
max_pic_size = max_size;
}
-void deallocate_inline_cache(cell return_address)
+void factorvm::deallocate_inline_cache(cell return_address)
{
/* Find the call target. */
void *old_xt = get_call_target(return_address);
/* Figure out what kind of type check the PIC needs based on the methods
it contains */
-static cell determine_inline_cache_type(array *cache_entries)
+cell factorvm::determine_inline_cache_type(array *cache_entries)
{
bool seen_hi_tag = false, seen_tuple = false;
return 0;
}
-static void update_pic_count(cell type)
+void factorvm::update_pic_count(cell type)
{
pic_counts[type - PIC_TAG]++;
}
struct inline_cache_jit : public jit {
fixnum index;
- inline_cache_jit(cell generic_word_) : jit(PIC_TYPE,generic_word_) {};
+ inline_cache_jit(cell generic_word_,factorvm *vm) : jit(PIC_TYPE,generic_word_,vm) {};
void emit_check(cell klass);
void compile_inline_cache(fixnum index,
{
cell code_template;
if(TAG(klass) == FIXNUM_TYPE && untag_fixnum(klass) < HEADER_TYPE)
- code_template = userenv[PIC_CHECK_TAG];
+ code_template = myvm->userenv[PIC_CHECK_TAG];
else
- code_template = userenv[PIC_CHECK];
+ code_template = myvm->userenv[PIC_CHECK];
emit_with(code_template,klass);
}
cell cache_entries_,
bool tail_call_p)
{
- gc_root<word> generic_word(generic_word_);
- gc_root<array> methods(methods_);
- gc_root<array> cache_entries(cache_entries_);
+ gc_root<word> generic_word(generic_word_,myvm);
+ gc_root<array> methods(methods_,myvm);
+ gc_root<array> cache_entries(cache_entries_,myvm);
- cell inline_cache_type = determine_inline_cache_type(cache_entries.untagged());
- update_pic_count(inline_cache_type);
+ cell inline_cache_type = myvm->determine_inline_cache_type(cache_entries.untagged());
+ myvm->update_pic_count(inline_cache_type);
/* Generate machine code to determine the object's class. */
emit_class_lookup(index,inline_cache_type);
/* Yes? Jump to method */
cell method = array_nth(cache_entries.untagged(),i + 1);
- emit_with(userenv[PIC_HIT],method);
+ emit_with(myvm->userenv[PIC_HIT],method);
}
/* Generate machine code to handle a cache miss, which ultimately results in
push(methods.value());
push(tag_fixnum(index));
push(cache_entries.value());
- word_special(userenv[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]);
+ word_special(myvm->userenv[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]);
}
-static code_block *compile_inline_cache(fixnum index,
- cell generic_word_,
- cell methods_,
- cell cache_entries_,
- bool tail_call_p)
+code_block *factorvm::compile_inline_cache(fixnum index,cell generic_word_,cell methods_,cell cache_entries_,bool tail_call_p)
{
- gc_root<word> generic_word(generic_word_);
- gc_root<array> methods(methods_);
- gc_root<array> cache_entries(cache_entries_);
+ gc_root<word> generic_word(generic_word_,this);
+ gc_root<array> methods(methods_,this);
+ gc_root<array> cache_entries(cache_entries_,this);
- inline_cache_jit jit(generic_word.value());
+ inline_cache_jit jit(generic_word.value(),this);
jit.compile_inline_cache(index,
generic_word.value(),
methods.value(),
}
/* A generic word's definition performs general method lookup. Allocates memory */
-static void *megamorphic_call_stub(cell generic_word)
+void *factorvm::megamorphic_call_stub(cell generic_word)
{
return untag<word>(generic_word)->xt;
}
-static cell inline_cache_size(cell cache_entries)
+cell factorvm::inline_cache_size(cell cache_entries)
{
return array_capacity(untag_check<array>(cache_entries)) / 2;
}
/* Allocates memory */
-static cell add_inline_cache_entry(cell cache_entries_, cell klass_, cell method_)
+cell factorvm::add_inline_cache_entry(cell cache_entries_, cell klass_, cell method_)
{
- gc_root<array> cache_entries(cache_entries_);
- gc_root<object> klass(klass_);
- gc_root<word> method(method_);
+ gc_root<array> cache_entries(cache_entries_,this);
+ gc_root<object> klass(klass_,this);
+ gc_root<word> method(method_,this);
cell pic_size = array_capacity(cache_entries.untagged());
- gc_root<array> new_cache_entries(reallot_array(cache_entries.untagged(),pic_size + 2));
+ gc_root<array> new_cache_entries(reallot_array(cache_entries.untagged(),pic_size + 2),this);
set_array_nth(new_cache_entries.untagged(),pic_size,klass.value());
set_array_nth(new_cache_entries.untagged(),pic_size + 1,method.value());
return new_cache_entries.value();
}
-static void update_pic_transitions(cell pic_size)
+void factorvm::update_pic_transitions(cell pic_size)
{
if(pic_size == max_pic_size)
pic_to_mega_transitions++;
/* The cache_entries parameter is either f (on cold call site) or an array (on cache miss).
Called from assembly with the actual return address */
-void *inline_cache_miss(cell return_address)
+void *factorvm::inline_cache_miss(cell return_address)
{
check_code_pointer(return_address);
instead of leaving dead PICs around until the next GC. */
deallocate_inline_cache(return_address);
- gc_root<array> cache_entries(dpop());
+ gc_root<array> cache_entries(dpop(),this);
fixnum index = untag_fixnum(dpop());
- gc_root<array> methods(dpop());
- gc_root<word> generic_word(dpop());
- gc_root<object> object(((cell *)ds)[-index]);
+ gc_root<array> methods(dpop(),this);
+ gc_root<word> generic_word(dpop(),this);
+ gc_root<object> object(((cell *)ds)[-index],this);
void *xt;
gc_root<array> new_cache_entries(add_inline_cache_entry(
cache_entries.value(),
klass,
- method));
+ method),this);
xt = compile_inline_cache(index,
generic_word.value(),
methods.value(),
return xt;
}
-PRIMITIVE(reset_inline_cache_stats)
+VM_C_API void *inline_cache_miss(cell return_address, factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->inline_cache_miss(return_address);
+}
+
+
+inline void factorvm::vmprim_reset_inline_cache_stats()
{
cold_call_to_ic_transitions = ic_to_pic_transitions = pic_to_mega_transitions = 0;
cell i;
for(i = 0; i < 4; i++) pic_counts[i] = 0;
}
-PRIMITIVE(inline_cache_stats)
+PRIMITIVE(reset_inline_cache_stats)
+{
+ PRIMITIVE_GETVM()->vmprim_reset_inline_cache_stats();
+}
+
+inline void factorvm::vmprim_inline_cache_stats()
{
- growable_array stats;
+ growable_array stats(this);
stats.add(allot_cell(cold_call_to_ic_transitions));
stats.add(allot_cell(ic_to_pic_transitions));
stats.add(allot_cell(pic_to_mega_transitions));
dpush(stats.elements.value());
}
+PRIMITIVE(inline_cache_stats)
+{
+ PRIMITIVE_GETVM()->vmprim_inline_cache_stats();
+}
+
}
namespace factor
{
-
-extern cell max_pic_size;
-
-void init_inline_caching(int max_size);
-
PRIMITIVE(reset_inline_cache_stats);
PRIMITIVE(inline_cache_stats);
PRIMITIVE(inline_cache_miss);
PRIMITIVE(inline_cache_miss_tail);
-VM_C_API void *inline_cache_miss(cell return_address);
+VM_C_API void *inline_cache_miss(cell return_address, factorvm *vm);
}
--- /dev/null
+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 factorvm::align_page(cell a)
+{
+ return align(a,getpagesize());
+}
+
+// write_barrier.hpp
+
+inline card *factorvm::addr_to_card(cell a)
+{
+ return (card*)(((cell)(a) >> card_bits) + cards_offset);
+}
+
+
+inline cell factorvm::card_to_addr(card *c)
+{
+ return ((cell)c - cards_offset) << card_bits;
+}
+
+
+inline cell factorvm::card_offset(card *c)
+{
+ return *(c - (cell)data->cards + (cell)data->allot_markers);
+}
+
+inline card_deck *factorvm::addr_to_deck(cell a)
+{
+ return (card_deck *)(((cell)a >> deck_bits) + decks_offset);
+}
+
+inline cell factorvm::deck_to_addr(card_deck *c)
+{
+ return ((cell)c - decks_offset) << deck_bits;
+}
+
+inline card *factorvm::deck_to_card(card_deck *d)
+{
+ return (card *)((((cell)d - decks_offset) << (deck_bits - card_bits)) + cards_offset);
+}
+
+inline card *factorvm::addr_to_allot_marker(object *a)
+{
+ return (card *)(((cell)a >> card_bits) + allot_markers_offset);
+}
+
+/* the write barrier must be called any time we are potentially storing a
+pointer from an older generation to a younger one */
+inline void factorvm::write_barrier(object *obj)
+{
+ *addr_to_card((cell)obj) = card_mark_mask;
+ *addr_to_deck((cell)obj) = card_mark_mask;
+}
+
+/* we need to remember the first object allocated in the card */
+inline void factorvm::allot_barrier(object *address)
+{
+ card *ptr = addr_to_allot_marker(address);
+ if(*ptr == invalid_allot_marker)
+ *ptr = ((cell)address & addr_card_mask);
+}
+
+
+//data_gc.hpp
+inline bool factorvm::collecting_accumulation_gen_p()
+{
+ return ((data->have_aging_p()
+ && collecting_gen == data->aging()
+ && !collecting_aging_again)
+ || collecting_gen == data->tenured());
+}
+
+inline object *factorvm::allot_zone(zone *z, cell a)
+{
+ cell h = z->here;
+ z->here = h + align8(a);
+ object *obj = (object *)h;
+ allot_barrier(obj);
+ return obj;
+}
+
+/*
+ * It is up to the caller to fill in the object's fields in a meaningful
+ * fashion!
+ */
+inline object *factorvm::allot_object(header header, cell size)
+{
+#ifdef GC_DEBUG
+ if(!gc_off)
+ gc();
+#endif
+
+ object *obj;
+
+ if(nursery.size - allot_buffer_zone > size)
+ {
+ /* If there is insufficient room, collect the nursery */
+ if(nursery.here + allot_buffer_zone + size > nursery.end)
+ garbage_collection(data->nursery(),false,0);
+
+ cell h = nursery.here;
+ nursery.here = h + align8(size);
+ obj = (object *)h;
+ }
+ /* If the object is bigger than the nursery, allocate it in
+ tenured space */
+ else
+ {
+ zone *tenured = &data->generations[data->tenured()];
+
+ /* If tenured space does not have enough room, collect */
+ if(tenured->here + size > tenured->end)
+ {
+ gc();
+ tenured = &data->generations[data->tenured()];
+ }
+
+ /* If it still won't fit, grow the heap */
+ if(tenured->here + size > tenured->end)
+ {
+ garbage_collection(data->tenured(),true,size);
+ tenured = &data->generations[data->tenured()];
+ }
+
+ obj = allot_zone(tenured,size);
+
+ /* Allows initialization code to store old->new pointers
+ without hitting the write barrier in the common case of
+ a nursery allocation */
+ write_barrier(obj);
+ }
+
+ obj->h = header;
+ return obj;
+}
+
+template<typename TYPE> TYPE *factorvm::allot(cell size)
+{
+ return (TYPE *)allot_object(header(TYPE::type_number),size);
+}
+
+inline void factorvm::check_data_pointer(object *pointer)
+{
+#ifdef FACTOR_DEBUG
+ if(!growing_data_heap)
+ {
+ assert((cell)pointer >= data->seg->start
+ && (cell)pointer < data->seg->end);
+ }
+#endif
+}
+
+inline void factorvm::check_tagged_pointer(cell tagged)
+{
+#ifdef FACTOR_DEBUG
+ if(!immediate_p(tagged))
+ {
+ object *obj = untag<object>(tagged);
+ check_data_pointer(obj);
+ obj->h.hi_tag();
+ }
+#endif
+}
+
+//local_roots.hpp
+template <typename TYPE>
+struct gc_root : public tagged<TYPE>
+{
+ factorvm *myvm;
+
+ void push() { myvm->check_tagged_pointer(tagged<TYPE>::value()); myvm->gc_locals.push_back((cell)this); }
+
+ explicit gc_root(cell value_,factorvm *vm) : tagged<TYPE>(value_),myvm(vm) { push(); }
+ explicit gc_root(TYPE *value_, factorvm *vm) : tagged<TYPE>(value_),myvm(vm) { push(); }
+
+ const gc_root<TYPE>& operator=(const TYPE *x) { tagged<TYPE>::operator=(x); return *this; }
+ const gc_root<TYPE>& operator=(const cell &x) { tagged<TYPE>::operator=(x); return *this; }
+
+ ~gc_root() {
+#ifdef FACTOR_DEBUG
+ assert(myvm->gc_locals.back() == (cell)this);
+#endif
+ myvm->gc_locals.pop_back();
+ }
+};
+
+/* A similar hack for the bignum implementation */
+struct gc_bignum
+{
+ bignum **addr;
+ factorvm *myvm;
+ gc_bignum(bignum **addr_, factorvm *vm) : addr(addr_), myvm(vm) {
+ if(*addr_)
+ myvm->check_data_pointer(*addr_);
+ myvm->gc_bignums.push_back((cell)addr);
+ }
+
+ ~gc_bignum() {
+#ifdef FACTOR_DEBUG
+ assert(myvm->gc_bignums.back() == (cell)addr);
+#endif
+ myvm->gc_bignums.pop_back();
+ }
+};
+
+#define GC_BIGNUM(x,vm) gc_bignum x##__gc_root(&x,vm)
+
+//generic_arrays.hpp
+template <typename TYPE> TYPE *factorvm::allot_array_internal(cell capacity)
+{
+ TYPE *array = allot<TYPE>(array_size<TYPE>(capacity));
+ array->capacity = tag_fixnum(capacity);
+ return array;
+}
+
+template <typename TYPE> bool factorvm::reallot_array_in_place_p(TYPE *array, cell capacity)
+{
+ return in_zone(&nursery,array) && capacity <= array_capacity(array);
+}
+
+template <typename TYPE> TYPE *factorvm::reallot_array(TYPE *array_, cell capacity)
+{
+ gc_root<TYPE> array(array_,this);
+
+ if(reallot_array_in_place_p(array.untagged(),capacity))
+ {
+ array->capacity = tag_fixnum(capacity);
+ return array.untagged();
+ }
+ else
+ {
+ cell to_copy = array_capacity(array.untagged());
+ if(capacity < to_copy)
+ to_copy = capacity;
+
+ TYPE *new_array = allot_array_internal<TYPE>(capacity);
+
+ memcpy(new_array + 1,array.untagged() + 1,to_copy * TYPE::element_size);
+ memset((char *)(new_array + 1) + to_copy * TYPE::element_size,
+ 0,(capacity - to_copy) * TYPE::element_size);
+
+ return new_array;
+ }
+}
+
+//arrays.hpp
+inline void factorvm::set_array_nth(array *array, cell slot, cell value)
+{
+#ifdef FACTOR_DEBUG
+ assert(slot < array_capacity(array));
+ assert(array->h.hi_tag() == ARRAY_TYPE);
+ check_tagged_pointer(value);
+#endif
+ array->data()[slot] = value;
+ write_barrier(array);
+}
+
+struct growable_array {
+ cell count;
+ gc_root<array> elements;
+
+ growable_array(factorvm *myvm, cell capacity = 10) : count(0), elements(myvm->allot_array(capacity,F),myvm) {}
+
+ void add(cell elt);
+ void trim();
+};
+
+//byte_arrays.hpp
+struct growable_byte_array {
+ cell count;
+ gc_root<byte_array> elements;
+
+ growable_byte_array(factorvm *myvm,cell capacity = 40) : count(0), elements(myvm->allot_byte_array(capacity),myvm) { }
+
+ void append_bytes(void *elts, cell len);
+ void append_byte_array(cell elts);
+
+ void trim();
+};
+
+//math.hpp
+inline cell factorvm::allot_integer(fixnum x)
+{
+ if(x < fixnum_min || x > fixnum_max)
+ return tag<bignum>(fixnum_to_bignum(x));
+ else
+ return tag_fixnum(x);
+}
+
+inline cell factorvm::allot_cell(cell x)
+{
+ if(x > (cell)fixnum_max)
+ return tag<bignum>(cell_to_bignum(x));
+ else
+ return tag_fixnum(x);
+}
+
+inline cell factorvm::allot_float(double n)
+{
+ boxed_float *flo = allot<boxed_float>(sizeof(boxed_float));
+ flo->n = n;
+ return tag(flo);
+}
+
+inline bignum *factorvm::float_to_bignum(cell tagged)
+{
+ return double_to_bignum(untag_float(tagged));
+}
+
+inline double factorvm::bignum_to_float(cell tagged)
+{
+ return bignum_to_double(untag<bignum>(tagged));
+}
+
+inline double factorvm::untag_float(cell tagged)
+{
+ return untag<boxed_float>(tagged)->n;
+}
+
+inline double factorvm::untag_float_check(cell tagged)
+{
+ return untag_check<boxed_float>(tagged)->n;
+}
+
+inline fixnum factorvm::float_to_fixnum(cell tagged)
+{
+ return (fixnum)untag_float(tagged);
+}
+
+inline double factorvm::fixnum_to_float(cell tagged)
+{
+ return (double)untag_fixnum(tagged);
+}
+
+//callstack.hpp
+/* This is a little tricky. The iterator may allocate memory, so we
+keep the callstack in a GC root and use relative offsets */
+template<typename TYPE> void factorvm::iterate_callstack_object(callstack *stack_, TYPE &iterator)
+{
+ gc_root<callstack> stack(stack_,this);
+ fixnum frame_offset = untag_fixnum(stack->length) - sizeof(stack_frame);
+
+ while(frame_offset >= 0)
+ {
+ stack_frame *frame = stack->frame_at(frame_offset);
+ frame_offset -= frame->size;
+ iterator(frame,this);
+ }
+}
+
+//booleans.hpp
+inline cell factorvm::tag_boolean(cell untagged)
+{
+ return (untagged ? T : F);
+}
+
+// callstack.hpp
+template<typename TYPE> void factorvm::iterate_callstack(cell top, cell bottom, TYPE &iterator)
+{
+ stack_frame *frame = (stack_frame *)bottom - 1;
+
+ while((cell)frame >= top)
+ {
+ iterator(frame,this);
+ frame = frame_successor(frame);
+ }
+}
+
+
+// data_heap.hpp
+/* Every object has a regular representation in the runtime, which makes GC
+much simpler. Every slot of the object until binary_payload_start is a pointer
+to some other object. */
+struct factorvm;
+inline void factorvm::do_slots(cell obj, void (* iter)(cell *,factorvm*))
+{
+ cell scan = obj;
+ cell payload_start = binary_payload_start((object *)obj);
+ cell end = obj + payload_start;
+
+ scan += sizeof(cell);
+
+ while(scan < end)
+ {
+ iter((cell *)scan,this);
+ scan += sizeof(cell);
+ }
+}
+
+// code_heap.hpp
+
+inline void factorvm::check_code_pointer(cell ptr)
+{
+#ifdef FACTOR_DEBUG
+ assert(in_code_heap_p(ptr));
+#endif
+}
+
+}
with many more capabilities so these words are not usually used in
normal operation. */
-void init_c_io()
+void factorvm::init_c_io()
{
userenv[STDIN_ENV] = allot_alien(F,(cell)stdin);
userenv[STDOUT_ENV] = allot_alien(F,(cell)stdout);
userenv[STDERR_ENV] = allot_alien(F,(cell)stderr);
}
-void io_error()
+
+void factorvm::io_error()
{
#ifndef WINCE
if(errno == EINTR)
general_error(ERROR_IO,tag_fixnum(errno),F,NULL);
}
-PRIMITIVE(fopen)
+
+inline void factorvm::vmprim_fopen()
{
- gc_root<byte_array> mode(dpop());
- gc_root<byte_array> path(dpop());
- mode.untag_check();
- path.untag_check();
+ gc_root<byte_array> mode(dpop(),this);
+ gc_root<byte_array> path(dpop(),this);
+ mode.untag_check(this);
+ path.untag_check(this);
for(;;)
{
}
}
-PRIMITIVE(fgetc)
+PRIMITIVE(fopen)
+{
+ PRIMITIVE_GETVM()->vmprim_fopen();
+}
+
+inline void factorvm::vmprim_fgetc()
{
FILE *file = (FILE *)unbox_alien();
}
}
-PRIMITIVE(fread)
+PRIMITIVE(fgetc)
+{
+ PRIMITIVE_GETVM()->vmprim_fgetc();
+}
+
+inline void factorvm::vmprim_fread()
{
FILE *file = (FILE *)unbox_alien();
fixnum size = unbox_array_size();
return;
}
- gc_root<byte_array> buf(allot_array_internal<byte_array>(size));
+ gc_root<byte_array> buf(allot_array_internal<byte_array>(size),this);
for(;;)
{
}
}
-PRIMITIVE(fputc)
+PRIMITIVE(fread)
+{
+ PRIMITIVE_GETVM()->vmprim_fread();
+}
+
+inline void factorvm::vmprim_fputc()
{
FILE *file = (FILE *)unbox_alien();
fixnum ch = to_fixnum(dpop());
}
}
-PRIMITIVE(fwrite)
+PRIMITIVE(fputc)
+{
+ PRIMITIVE_GETVM()->vmprim_fputc();
+}
+
+inline void factorvm::vmprim_fwrite()
{
FILE *file = (FILE *)unbox_alien();
byte_array *text = untag_check<byte_array>(dpop());
}
}
-PRIMITIVE(fseek)
+PRIMITIVE(fwrite)
+{
+ PRIMITIVE_GETVM()->vmprim_fwrite();
+}
+
+inline void factorvm::vmprim_fseek()
{
int whence = to_fixnum(dpop());
FILE *file = (FILE *)unbox_alien();
}
}
-PRIMITIVE(fflush)
+PRIMITIVE(fseek)
+{
+ PRIMITIVE_GETVM()->vmprim_fseek();
+}
+
+inline void factorvm::vmprim_fflush()
{
FILE *file = (FILE *)unbox_alien();
for(;;)
}
}
-PRIMITIVE(fclose)
+PRIMITIVE(fflush)
+{
+ PRIMITIVE_GETVM()->vmprim_fflush();
+}
+
+inline void factorvm::vmprim_fclose()
{
FILE *file = (FILE *)unbox_alien();
for(;;)
}
}
+PRIMITIVE(fclose)
+{
+ PRIMITIVE_GETVM()->vmprim_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
reads thread-local storage. */
{
errno = 0;
}
-
}
namespace factor
{
-void init_c_io();
-void io_error();
-
PRIMITIVE(fopen);
PRIMITIVE(fgetc);
PRIMITIVE(fread);
- polymorphic inline caches (inline_cache.cpp) */
/* Allocates memory */
-jit::jit(cell type_, cell owner_)
+jit::jit(cell type_, cell owner_, factorvm *vm)
: type(type_),
- owner(owner_),
- code(),
- relocation(),
- literals(),
+ owner(owner_,vm),
+ code(vm),
+ relocation(vm),
+ literals(vm),
computing_offset_p(false),
position(0),
- offset(0)
+ offset(0),
+ myvm(vm)
{
- if(stack_traces_p()) literal(owner.value());
+ if(myvm->stack_traces_p()) literal(owner.value());
}
void jit::emit_relocation(cell code_template_)
{
- gc_root<array> code_template(code_template_);
+ gc_root<array> code_template(code_template_,myvm);
cell capacity = array_capacity(code_template.untagged());
for(cell i = 1; i < capacity; i += 3)
{
/* Allocates memory */
void jit::emit(cell code_template_)
{
- gc_root<array> code_template(code_template_);
+ gc_root<array> code_template(code_template_,myvm);
emit_relocation(code_template.value());
- gc_root<byte_array> insns(array_nth(code_template.untagged(),0));
+ gc_root<byte_array> insns(array_nth(code_template.untagged(),0),myvm);
if(computing_offset_p)
{
}
void jit::emit_with(cell code_template_, cell argument_) {
- gc_root<array> code_template(code_template_);
- gc_root<object> argument(argument_);
+ gc_root<array> code_template(code_template_,myvm);
+ gc_root<object> argument(argument_,myvm);
literal(argument.value());
emit(code_template.value());
}
void jit::emit_class_lookup(fixnum index, cell type)
{
- emit_with(userenv[PIC_LOAD],tag_fixnum(-index * sizeof(cell)));
- emit(userenv[type]);
+ emit_with(myvm->userenv[PIC_LOAD],tag_fixnum(-index * sizeof(cell)));
+ emit(myvm->userenv[type]);
}
/* Facility to convert compiled code offsets to quotation offsets.
relocation.trim();
literals.trim();
- return add_code_block(
+ return myvm->add_code_block(
type,
code.elements.value(),
F, /* no labels */
bool computing_offset_p;
fixnum position;
cell offset;
+ factorvm *myvm;
- jit(cell jit_type, cell owner);
+ jit(cell jit_type, cell owner, factorvm *vm);
void compute_position(cell offset);
void emit_relocation(cell code_template);
void emit_with(cell code_template_, cell literal_);
void push(cell literal) {
- emit_with(userenv[JIT_PUSH_IMMEDIATE],literal);
+ emit_with(myvm->userenv[JIT_PUSH_IMMEDIATE],literal);
}
void word_jump(cell word) {
literal(tag_fixnum(xt_tail_pic_offset));
literal(word);
- emit(userenv[JIT_WORD_JUMP]);
+ emit(myvm->userenv[JIT_WORD_JUMP]);
}
void word_call(cell word) {
- emit_with(userenv[JIT_WORD_CALL],word);
+ emit_with(myvm->userenv[JIT_WORD_CALL],word);
}
void word_special(cell word) {
- emit_with(userenv[JIT_WORD_SPECIAL],word);
+ emit_with(myvm->userenv[JIT_WORD_SPECIAL],word);
}
void emit_subprimitive(cell word_) {
- gc_root<word> word(word_);
- gc_root<array> code_template(word->subprimitive);
- if(array_capacity(code_template.untagged()) > 1) literal(T);
+ gc_root<word> word(word_,myvm);
+ gc_root<array> code_template(word->subprimitive,myvm);
+ if(array_capacity(code_template.untagged()) > 1) literal(myvm->T);
emit(code_template.value());
}
namespace factor
{
-
-std::vector<cell> gc_locals;
-
-std::vector<cell> gc_bignums;
-
}
namespace factor
{
-
-/* If a runtime function needs to call another function which potentially
-allocates memory, it must wrap any local variable references to Factor
-objects in gc_root instances */
-extern std::vector<cell> gc_locals;
-
-template <typename T>
-struct gc_root : public tagged<T>
-{
- void push() { check_tagged_pointer(tagged<T>::value()); gc_locals.push_back((cell)this); }
-
- explicit gc_root(cell value_) : tagged<T>(value_) { push(); }
- explicit gc_root(T *value_) : tagged<T>(value_) { push(); }
-
- const gc_root<T>& operator=(const T *x) { tagged<T>::operator=(x); return *this; }
- const gc_root<T>& operator=(const cell &x) { tagged<T>::operator=(x); return *this; }
-
- ~gc_root() {
-#ifdef FACTOR_DEBUG
- assert(gc_locals.back() == (cell)this);
-#endif
- gc_locals.pop_back();
- }
-};
-
-/* A similar hack for the bignum implementation */
-extern std::vector<cell> gc_bignums;
-
-struct gc_bignum
-{
- bignum **addr;
-
- gc_bignum(bignum **addr_) : addr(addr_) {
- if(*addr_)
- check_data_pointer(*addr_);
- gc_bignums.push_back((cell)addr);
- }
-
- ~gc_bignum() {
-#ifdef FACTOR_DEBUG
- assert(gc_bignums.back() == (cell)addr);
-#endif
- gc_bignums.pop_back();
- }
-};
-
-#define GC_BIGNUM(x) gc_bignum x##__gc_root(&x)
-
}
/* Modify a suspended thread's thread_state so that when the thread resumes
executing, the call frame of the current C primitive (if any) is rewound, and
the appropriate Factor error is thrown from the top-most Factor frame. */
-static void call_fault_handler(
+void factorvm::call_fault_handler(
exception_type_t exception,
exception_data_type_t code,
MACH_EXC_STATE_TYPE *exc_state,
if(exception == EXC_BAD_ACCESS)
{
signal_fault_addr = MACH_EXC_STATE_FAULT(exc_state);
- MACH_PROGRAM_COUNTER(thread_state) = (cell)memory_signal_handler_impl;
+ MACH_PROGRAM_COUNTER(thread_state) = (cell)factor::memory_signal_handler_impl;
}
else if(exception == EXC_ARITHMETIC && code != MACH_EXC_INTEGER_DIV)
{
- signal_fpu_status = fpu_status(mach_fpu_status(float_state));
- mach_clear_fpu_status(float_state);
- MACH_PROGRAM_COUNTER(thread_state) = (cell)fp_signal_handler_impl;
+ signal_fpu_status = fpu_status(mach_fpu_status(float_state));
+ mach_clear_fpu_status(float_state);
+ MACH_PROGRAM_COUNTER(thread_state) = (cell)factor::fp_signal_handler_impl;
}
else
{
signal_number = (exception == EXC_ARITHMETIC ? SIGFPE : SIGABRT);
- MACH_PROGRAM_COUNTER(thread_state) = (cell)misc_signal_handler_impl;
+ MACH_PROGRAM_COUNTER(thread_state) = (cell)factor::misc_signal_handler_impl;
}
}
+static void call_fault_handler(exception_type_t exception,
+ exception_data_type_t code,
+ MACH_EXC_STATE_TYPE *exc_state,
+ MACH_THREAD_STATE_TYPE *thread_state,
+ MACH_FLOAT_STATE_TYPE *float_state)
+{
+ SIGNAL_VM_PTR()->call_fault_handler(exception,code,exc_state,thread_state,float_state);
+}
+
/* Handle an exception by invoking the user's fault handler and/or forwarding
the duty to the previously installed handlers. */
extern "C"
mask = EXC_MASK_BAD_ACCESS | EXC_MASK_ARITHMETIC;
/* Create the thread listening on the exception port. */
- start_thread(mach_exception_thread);
+ start_thread(mach_exception_thread,NULL);
/* Replace the exception port info for these exceptions with our own.
Note that we replace the exception port for the entire task, not only
int main(int argc, char **argv)
{
+ factor::init_globals();
factor::start_standalone_factor(argc,argv);
return 0;
}
return 1;
}
+ factor::init_globals();
+ #ifdef FACTOR_MULTITHREADED
+ factor::THREADHANDLE thread = factor::start_standalone_factor_in_new_thread(nArgs,szArglist);
+ WaitForSingleObject(thread, INFINITE);
+ #else
factor::start_standalone_factor(nArgs,szArglist);
+ #endif
LocalFree(szArglist);
#ifndef __FACTOR_MASTER_H__
#define __FACTOR_MASTER_H__
+#define _THREAD_SAFE
+#define _REENTRANT
+
#ifndef WINCE
#include <errno.h>
#endif
#include "segments.hpp"
#include "contexts.hpp"
#include "run.hpp"
-#include "tagged.hpp"
#include "profiler.hpp"
#include "errors.hpp"
#include "bignumint.hpp"
#include "bignum.hpp"
+#include "code_block.hpp"
#include "data_heap.hpp"
#include "write_barrier.hpp"
#include "data_gc.hpp"
#include "float_bits.hpp"
#include "io.hpp"
#include "code_gc.hpp"
-#include "code_block.hpp"
#include "code_heap.hpp"
#include "image.hpp"
#include "callstack.hpp"
#include "alien.hpp"
+#include "vm.hpp"
+#include "tagged.hpp"
+#include "inlineimpls.hpp"
#include "jit.hpp"
#include "quotations.hpp"
#include "dispatch.hpp"
#include "factor.hpp"
#include "utilities.hpp"
+
+
#endif /* __FACTOR_MASTER_H__ */
namespace factor
{
-cell bignum_zero;
-cell bignum_pos_one;
-cell bignum_neg_one;
+inline void factorvm::vmprim_bignum_to_fixnum()
+{
+ drepl(tag_fixnum(bignum_to_fixnum(untag<bignum>(dpeek()))));
+}
PRIMITIVE(bignum_to_fixnum)
{
- drepl(tag_fixnum(bignum_to_fixnum(untag<bignum>(dpeek()))));
+ PRIMITIVE_GETVM()->vmprim_bignum_to_fixnum();
}
-PRIMITIVE(float_to_fixnum)
+inline void factorvm::vmprim_float_to_fixnum()
{
drepl(tag_fixnum(float_to_fixnum(dpeek())));
}
+PRIMITIVE(float_to_fixnum)
+{
+ PRIMITIVE_GETVM()->vmprim_float_to_fixnum();
+}
+
/* Division can only overflow when we are dividing the most negative fixnum
by -1. */
-PRIMITIVE(fixnum_divint)
+inline void factorvm::vmprim_fixnum_divint()
{
fixnum y = untag_fixnum(dpop()); \
fixnum x = untag_fixnum(dpeek());
drepl(tag_fixnum(result));
}
-PRIMITIVE(fixnum_divmod)
+PRIMITIVE(fixnum_divint)
+{
+ PRIMITIVE_GETVM()->vmprim_fixnum_divint();
+}
+
+inline void factorvm::vmprim_fixnum_divmod()
{
cell y = ((cell *)ds)[0];
cell x = ((cell *)ds)[-1];
}
}
+PRIMITIVE(fixnum_divmod)
+{
+ PRIMITIVE_GETVM()->vmprim_fixnum_divmod();
+}
+
/*
* If we're shifting right by n bits, we won't overflow as long as none of the
* high WORD_SIZE-TAG_BITS-n bits are set.
*/
-static inline fixnum sign_mask(fixnum x)
+inline fixnum factorvm::sign_mask(fixnum x)
{
return x >> (WORD_SIZE - 1);
}
-static inline fixnum branchless_max(fixnum x, fixnum y)
+
+inline fixnum factorvm::branchless_max(fixnum x, fixnum y)
{
return (x - ((x - y) & sign_mask(x - y)));
}
-static inline fixnum branchless_abs(fixnum x)
+
+inline fixnum factorvm::branchless_abs(fixnum x)
{
return (x ^ sign_mask(x)) - sign_mask(x);
}
-PRIMITIVE(fixnum_shift)
+
+inline void factorvm::vmprim_fixnum_shift()
{
fixnum y = untag_fixnum(dpop());
fixnum x = untag_fixnum(dpeek());
fixnum_to_bignum(x),y)));
}
-PRIMITIVE(fixnum_to_bignum)
+PRIMITIVE(fixnum_shift)
+{
+ PRIMITIVE_GETVM()->vmprim_fixnum_shift();
+}
+
+inline void factorvm::vmprim_fixnum_to_bignum()
{
drepl(tag<bignum>(fixnum_to_bignum(untag_fixnum(dpeek()))));
}
-PRIMITIVE(float_to_bignum)
+PRIMITIVE(fixnum_to_bignum)
+{
+ PRIMITIVE_GETVM()->vmprim_fixnum_to_bignum();
+}
+
+inline void factorvm::vmprim_float_to_bignum()
{
drepl(tag<bignum>(float_to_bignum(dpeek())));
}
+PRIMITIVE(float_to_bignum)
+{
+ PRIMITIVE_GETVM()->vmprim_float_to_bignum();
+}
+
#define POP_BIGNUMS(x,y) \
bignum * y = untag<bignum>(dpop()); \
bignum * x = untag<bignum>(dpop());
-PRIMITIVE(bignum_eq)
+inline void factorvm::vmprim_bignum_eq()
{
POP_BIGNUMS(x,y);
box_boolean(bignum_equal_p(x,y));
}
-PRIMITIVE(bignum_add)
+PRIMITIVE(bignum_eq)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_eq();
+}
+
+inline void factorvm::vmprim_bignum_add()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_add(x,y)));
}
-PRIMITIVE(bignum_subtract)
+PRIMITIVE(bignum_add)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_add();
+}
+
+inline void factorvm::vmprim_bignum_subtract()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_subtract(x,y)));
}
-PRIMITIVE(bignum_multiply)
+PRIMITIVE(bignum_subtract)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_subtract();
+}
+
+inline void factorvm::vmprim_bignum_multiply()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_multiply(x,y)));
}
-PRIMITIVE(bignum_divint)
+PRIMITIVE(bignum_multiply)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_multiply();
+}
+
+inline void factorvm::vmprim_bignum_divint()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_quotient(x,y)));
}
-PRIMITIVE(bignum_divmod)
+PRIMITIVE(bignum_divint)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_divint();
+}
+
+inline void factorvm::vmprim_bignum_divmod()
{
bignum *q, *r;
POP_BIGNUMS(x,y);
dpush(tag<bignum>(r));
}
-PRIMITIVE(bignum_mod)
+PRIMITIVE(bignum_divmod)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_divmod();
+}
+
+inline void factorvm::vmprim_bignum_mod()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_remainder(x,y)));
}
-PRIMITIVE(bignum_and)
+PRIMITIVE(bignum_mod)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_mod();
+}
+
+inline void factorvm::vmprim_bignum_and()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_bitwise_and(x,y)));
}
-PRIMITIVE(bignum_or)
+PRIMITIVE(bignum_and)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_and();
+}
+
+inline void factorvm::vmprim_bignum_or()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_bitwise_ior(x,y)));
}
-PRIMITIVE(bignum_xor)
+PRIMITIVE(bignum_or)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_or();
+}
+
+inline void factorvm::vmprim_bignum_xor()
{
POP_BIGNUMS(x,y);
dpush(tag<bignum>(bignum_bitwise_xor(x,y)));
}
-PRIMITIVE(bignum_shift)
+PRIMITIVE(bignum_xor)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_xor();
+}
+
+inline void factorvm::vmprim_bignum_shift()
{
fixnum y = untag_fixnum(dpop());
bignum* x = untag<bignum>(dpop());
dpush(tag<bignum>(bignum_arithmetic_shift(x,y)));
}
-PRIMITIVE(bignum_less)
+PRIMITIVE(bignum_shift)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_shift();
+}
+
+inline void factorvm::vmprim_bignum_less()
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) == bignum_comparison_less);
}
-PRIMITIVE(bignum_lesseq)
+PRIMITIVE(bignum_less)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_less();
+}
+
+inline void factorvm::vmprim_bignum_lesseq()
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) != bignum_comparison_greater);
}
-PRIMITIVE(bignum_greater)
+PRIMITIVE(bignum_lesseq)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_lesseq();
+}
+
+inline void factorvm::vmprim_bignum_greater()
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) == bignum_comparison_greater);
}
-PRIMITIVE(bignum_greatereq)
+PRIMITIVE(bignum_greater)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_greater();
+}
+
+inline void factorvm::vmprim_bignum_greatereq()
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) != bignum_comparison_less);
}
-PRIMITIVE(bignum_not)
+PRIMITIVE(bignum_greatereq)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_greatereq();
+}
+
+inline void factorvm::vmprim_bignum_not()
{
drepl(tag<bignum>(bignum_bitwise_not(untag<bignum>(dpeek()))));
}
-PRIMITIVE(bignum_bitp)
+PRIMITIVE(bignum_not)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_not();
+}
+
+inline void factorvm::vmprim_bignum_bitp()
{
fixnum bit = to_fixnum(dpop());
bignum *x = untag<bignum>(dpop());
box_boolean(bignum_logbitp(bit,x));
}
-PRIMITIVE(bignum_log2)
+PRIMITIVE(bignum_bitp)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_bitp();
+}
+
+inline void factorvm::vmprim_bignum_log2()
{
drepl(tag<bignum>(bignum_integer_length(untag<bignum>(dpeek()))));
}
-unsigned int bignum_producer(unsigned int digit)
+PRIMITIVE(bignum_log2)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_log2();
+}
+
+unsigned int factorvm::bignum_producer(unsigned int digit)
{
unsigned char *ptr = (unsigned char *)alien_offset(dpeek());
return *(ptr + digit);
}
-PRIMITIVE(byte_array_to_bignum)
+unsigned int bignum_producer(unsigned int digit, factorvm *myvm)
+{
+ return myvm->bignum_producer(digit);
+}
+
+inline void factorvm::vmprim_byte_array_to_bignum()
{
cell n_digits = array_capacity(untag_check<byte_array>(dpeek()));
- bignum * result = digit_stream_to_bignum(n_digits,bignum_producer,0x100,0);
+ // bignum * result = factor::digit_stream_to_bignum(n_digits,factor::bignum_producer,0x100,0);
+ bignum * result = digit_stream_to_bignum(n_digits,factor::bignum_producer,0x100,0);
drepl(tag<bignum>(result));
}
-cell unbox_array_size()
+PRIMITIVE(byte_array_to_bignum)
+{
+ PRIMITIVE_GETVM()->vmprim_byte_array_to_bignum();
+}
+
+cell factorvm::unbox_array_size()
{
switch(tagged<object>(dpeek()).type())
{
return 0; /* can't happen */
}
-PRIMITIVE(fixnum_to_float)
+
+inline void factorvm::vmprim_fixnum_to_float()
{
drepl(allot_float(fixnum_to_float(dpeek())));
}
-PRIMITIVE(bignum_to_float)
+PRIMITIVE(fixnum_to_float)
+{
+ PRIMITIVE_GETVM()->vmprim_fixnum_to_float();
+}
+
+inline void factorvm::vmprim_bignum_to_float()
{
drepl(allot_float(bignum_to_float(dpeek())));
}
-PRIMITIVE(str_to_float)
+PRIMITIVE(bignum_to_float)
+{
+ PRIMITIVE_GETVM()->vmprim_bignum_to_float();
+}
+
+inline void factorvm::vmprim_str_to_float()
{
byte_array *bytes = untag_check<byte_array>(dpeek());
cell capacity = array_capacity(bytes);
drepl(F);
}
-PRIMITIVE(float_to_str)
+PRIMITIVE(str_to_float)
+{
+ PRIMITIVE_GETVM()->vmprim_str_to_float();
+}
+
+inline void factorvm::vmprim_float_to_str()
{
byte_array *array = allot_byte_array(33);
snprintf((char *)(array + 1),32,"%.16g",untag_float_check(dpop()));
dpush(tag<byte_array>(array));
}
+PRIMITIVE(float_to_str)
+{
+ PRIMITIVE_GETVM()->vmprim_float_to_str();
+}
+
#define POP_FLOATS(x,y) \
double y = untag_float(dpop()); \
double x = untag_float(dpop());
-PRIMITIVE(float_eq)
+inline void factorvm::vmprim_float_eq()
{
POP_FLOATS(x,y);
box_boolean(x == y);
}
-PRIMITIVE(float_add)
+PRIMITIVE(float_eq)
+{
+ PRIMITIVE_GETVM()->vmprim_float_eq();
+}
+
+inline void factorvm::vmprim_float_add()
{
POP_FLOATS(x,y);
box_double(x + y);
}
-PRIMITIVE(float_subtract)
+PRIMITIVE(float_add)
+{
+ PRIMITIVE_GETVM()->vmprim_float_add();
+}
+
+inline void factorvm::vmprim_float_subtract()
{
POP_FLOATS(x,y);
box_double(x - y);
}
-PRIMITIVE(float_multiply)
+PRIMITIVE(float_subtract)
+{
+ PRIMITIVE_GETVM()->vmprim_float_subtract();
+}
+
+inline void factorvm::vmprim_float_multiply()
{
POP_FLOATS(x,y);
box_double(x * y);
}
-PRIMITIVE(float_divfloat)
+PRIMITIVE(float_multiply)
+{
+ PRIMITIVE_GETVM()->vmprim_float_multiply();
+}
+
+inline void factorvm::vmprim_float_divfloat()
{
POP_FLOATS(x,y);
box_double(x / y);
}
-PRIMITIVE(float_mod)
+PRIMITIVE(float_divfloat)
+{
+ PRIMITIVE_GETVM()->vmprim_float_divfloat();
+}
+
+inline void factorvm::vmprim_float_mod()
{
POP_FLOATS(x,y);
box_double(fmod(x,y));
}
-PRIMITIVE(float_less)
+PRIMITIVE(float_mod)
+{
+ PRIMITIVE_GETVM()->vmprim_float_mod();
+}
+
+inline void factorvm::vmprim_float_less()
{
POP_FLOATS(x,y);
box_boolean(x < y);
}
-PRIMITIVE(float_lesseq)
+PRIMITIVE(float_less)
+{
+ PRIMITIVE_GETVM()->vmprim_float_less();
+}
+
+inline void factorvm::vmprim_float_lesseq()
{
POP_FLOATS(x,y);
box_boolean(x <= y);
}
-PRIMITIVE(float_greater)
+PRIMITIVE(float_lesseq)
+{
+ PRIMITIVE_GETVM()->vmprim_float_lesseq();
+}
+
+inline void factorvm::vmprim_float_greater()
{
POP_FLOATS(x,y);
box_boolean(x > y);
}
-PRIMITIVE(float_greatereq)
+PRIMITIVE(float_greater)
+{
+ PRIMITIVE_GETVM()->vmprim_float_greater();
+}
+
+inline void factorvm::vmprim_float_greatereq()
{
POP_FLOATS(x,y);
box_boolean(x >= y);
}
-PRIMITIVE(float_bits)
+PRIMITIVE(float_greatereq)
+{
+ PRIMITIVE_GETVM()->vmprim_float_greatereq();
+}
+
+inline void factorvm::vmprim_float_bits()
{
box_unsigned_4(float_bits(untag_float_check(dpop())));
}
-PRIMITIVE(bits_float)
+PRIMITIVE(float_bits)
+{
+ PRIMITIVE_GETVM()->vmprim_float_bits();
+}
+
+inline void factorvm::vmprim_bits_float()
{
box_float(bits_float(to_cell(dpop())));
}
-PRIMITIVE(double_bits)
+PRIMITIVE(bits_float)
+{
+ PRIMITIVE_GETVM()->vmprim_bits_float();
+}
+
+inline void factorvm::vmprim_double_bits()
{
box_unsigned_8(double_bits(untag_float_check(dpop())));
}
-PRIMITIVE(bits_double)
+PRIMITIVE(double_bits)
+{
+ PRIMITIVE_GETVM()->vmprim_double_bits();
+}
+
+inline void factorvm::vmprim_bits_double()
{
box_double(bits_double(to_unsigned_8(dpop())));
}
-VM_C_API fixnum to_fixnum(cell tagged)
+PRIMITIVE(bits_double)
+{
+ PRIMITIVE_GETVM()->vmprim_bits_double();
+}
+
+fixnum factorvm::to_fixnum(cell tagged)
{
switch(TAG(tagged))
{
}
}
-VM_C_API cell to_cell(cell tagged)
+VM_C_API fixnum to_fixnum(cell tagged,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->to_fixnum(tagged);
+}
+
+cell factorvm::to_cell(cell tagged)
{
return (cell)to_fixnum(tagged);
}
-VM_C_API void box_signed_1(s8 n)
+VM_C_API cell to_cell(cell tagged, factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->to_cell(tagged);
+}
+
+void factorvm::box_signed_1(s8 n)
{
dpush(tag_fixnum(n));
}
-VM_C_API void box_unsigned_1(u8 n)
+VM_C_API void box_signed_1(s8 n,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_signed_1(n);
+}
+
+void factorvm::box_unsigned_1(u8 n)
{
dpush(tag_fixnum(n));
}
-VM_C_API void box_signed_2(s16 n)
+VM_C_API void box_unsigned_1(u8 n,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_unsigned_1(n);
+}
+
+void factorvm::box_signed_2(s16 n)
{
dpush(tag_fixnum(n));
}
-VM_C_API void box_unsigned_2(u16 n)
+VM_C_API void box_signed_2(s16 n,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_signed_2(n);
+}
+
+void factorvm::box_unsigned_2(u16 n)
{
dpush(tag_fixnum(n));
}
-VM_C_API void box_signed_4(s32 n)
+VM_C_API void box_unsigned_2(u16 n,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_unsigned_2(n);
+}
+
+void factorvm::box_signed_4(s32 n)
{
dpush(allot_integer(n));
}
-VM_C_API void box_unsigned_4(u32 n)
+VM_C_API void box_signed_4(s32 n,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_signed_4(n);
+}
+
+void factorvm::box_unsigned_4(u32 n)
{
dpush(allot_cell(n));
}
-VM_C_API void box_signed_cell(fixnum integer)
+VM_C_API void box_unsigned_4(u32 n,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_unsigned_4(n);
+}
+
+void factorvm::box_signed_cell(fixnum integer)
{
dpush(allot_integer(integer));
}
-VM_C_API void box_unsigned_cell(cell cell)
+VM_C_API void box_signed_cell(fixnum integer,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_signed_cell(integer);
+}
+
+void factorvm::box_unsigned_cell(cell cell)
{
dpush(allot_cell(cell));
}
-VM_C_API void box_signed_8(s64 n)
+VM_C_API void box_unsigned_cell(cell cell,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_unsigned_cell(cell);
+}
+
+void factorvm::box_signed_8(s64 n)
{
if(n < fixnum_min || n > fixnum_max)
dpush(tag<bignum>(long_long_to_bignum(n)));
dpush(tag_fixnum(n));
}
-VM_C_API s64 to_signed_8(cell obj)
+VM_C_API void box_signed_8(s64 n,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_signed_8(n);
+}
+
+s64 factorvm::to_signed_8(cell obj)
{
switch(tagged<object>(obj).type())
{
}
}
-VM_C_API void box_unsigned_8(u64 n)
+VM_C_API s64 to_signed_8(cell obj,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->to_signed_8(obj);
+}
+
+void factorvm::box_unsigned_8(u64 n)
{
if(n > (u64)fixnum_max)
dpush(tag<bignum>(ulong_long_to_bignum(n)));
dpush(tag_fixnum(n));
}
-VM_C_API u64 to_unsigned_8(cell obj)
+VM_C_API void box_unsigned_8(u64 n,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_unsigned_8(n);
+}
+
+u64 factorvm::to_unsigned_8(cell obj)
{
switch(tagged<object>(obj).type())
{
}
}
-VM_C_API void box_float(float flo)
+VM_C_API u64 to_unsigned_8(cell obj,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->to_unsigned_8(obj);
+}
+
+void factorvm::box_float(float flo)
{
dpush(allot_float(flo));
}
-VM_C_API float to_float(cell value)
+VM_C_API void box_float(float flo,factorvm *myvm) // not sure if this is ever called
+{
+ ASSERTVM();
+ return VM_PTR->box_float(flo);
+}
+
+float factorvm::to_float(cell value)
{
return untag_float_check(value);
}
-VM_C_API void box_double(double flo)
+VM_C_API float to_float(cell value,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->to_float(value);
+}
+
+void factorvm::box_double(double flo)
{
dpush(allot_float(flo));
}
-VM_C_API double to_double(cell value)
+VM_C_API void box_double(double flo,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->box_double(flo);
+}
+
+double factorvm::to_double(cell value)
{
return untag_float_check(value);
}
+VM_C_API double to_double(cell value,factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->to_double(value);
+}
+
/* The fixnum+, fixnum- and fixnum* primitives are defined in cpu_*.S. On
overflow, they call these functions. */
-VM_ASM_API void overflow_fixnum_add(fixnum x, fixnum y)
+inline void factorvm::overflow_fixnum_add(fixnum x, fixnum y)
{
drepl(tag<bignum>(fixnum_to_bignum(
untag_fixnum(x) + untag_fixnum(y))));
}
-VM_ASM_API void overflow_fixnum_subtract(fixnum x, fixnum y)
+VM_ASM_API_OVERFLOW void overflow_fixnum_add(fixnum x, fixnum y, factorvm *myvm)
+{
+ PRIMITIVE_OVERFLOW_GETVM()->overflow_fixnum_add(x,y);
+}
+
+inline void factorvm::overflow_fixnum_subtract(fixnum x, fixnum y)
{
drepl(tag<bignum>(fixnum_to_bignum(
untag_fixnum(x) - untag_fixnum(y))));
}
-VM_ASM_API void overflow_fixnum_multiply(fixnum x, fixnum y)
+VM_ASM_API_OVERFLOW void overflow_fixnum_subtract(fixnum x, fixnum y, factorvm *myvm)
+{
+ PRIMITIVE_OVERFLOW_GETVM()->overflow_fixnum_subtract(x,y);
+}
+
+inline void factorvm::overflow_fixnum_multiply(fixnum x, fixnum y)
{
bignum *bx = fixnum_to_bignum(x);
- GC_BIGNUM(bx);
+ GC_BIGNUM(bx,this);
bignum *by = fixnum_to_bignum(y);
- GC_BIGNUM(by);
+ GC_BIGNUM(by,this);
drepl(tag<bignum>(bignum_multiply(bx,by)));
}
+VM_ASM_API_OVERFLOW void overflow_fixnum_multiply(fixnum x, fixnum y, factorvm *myvm)
+{
+ PRIMITIVE_OVERFLOW_GETVM()->overflow_fixnum_multiply(x,y);
+}
+
}
namespace factor
{
-extern cell bignum_zero;
-extern cell bignum_pos_one;
-extern cell bignum_neg_one;
-
static const fixnum fixnum_max = (((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)) - 1);
static const fixnum fixnum_min = (-((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)));
static const fixnum array_size_max = ((cell)1 << (WORD_SIZE - TAG_BITS - 2));
+// defined in assembler
PRIMITIVE(fixnum_add);
PRIMITIVE(fixnum_subtract);
PRIMITIVE(fixnum_multiply);
PRIMITIVE(bignum_log2);
PRIMITIVE(byte_array_to_bignum);
-inline static cell allot_integer(fixnum x)
-{
- if(x < fixnum_min || x > fixnum_max)
- return tag<bignum>(fixnum_to_bignum(x));
- else
- return tag_fixnum(x);
-}
-
-inline static cell allot_cell(cell x)
-{
- if(x > (cell)fixnum_max)
- return tag<bignum>(cell_to_bignum(x));
- else
- return tag_fixnum(x);
-}
-
-cell unbox_array_size();
-
-inline static double untag_float(cell tagged)
-{
- return untag<boxed_float>(tagged)->n;
-}
-
-inline static double untag_float_check(cell tagged)
-{
- return untag_check<boxed_float>(tagged)->n;
-}
-
-inline static cell allot_float(double n)
-{
- boxed_float *flo = allot<boxed_float>(sizeof(boxed_float));
- flo->n = n;
- return tag(flo);
-}
-
-inline static fixnum float_to_fixnum(cell tagged)
-{
- return (fixnum)untag_float(tagged);
-}
-
-inline static bignum *float_to_bignum(cell tagged)
-{
- return double_to_bignum(untag_float(tagged));
-}
-
-inline static double fixnum_to_float(cell tagged)
-{
- return (double)untag_fixnum(tagged);
-}
-
-inline static double bignum_to_float(cell tagged)
-{
- return bignum_to_double(untag<bignum>(tagged));
-}
-
PRIMITIVE(fixnum_to_float);
PRIMITIVE(bignum_to_float);
PRIMITIVE(str_to_float);
PRIMITIVE(double_bits);
PRIMITIVE(bits_double);
-VM_C_API void box_float(float flo);
-VM_C_API float to_float(cell value);
-VM_C_API void box_double(double flo);
-VM_C_API double to_double(cell value);
-
-VM_C_API void box_signed_1(s8 n);
-VM_C_API void box_unsigned_1(u8 n);
-VM_C_API void box_signed_2(s16 n);
-VM_C_API void box_unsigned_2(u16 n);
-VM_C_API void box_signed_4(s32 n);
-VM_C_API void box_unsigned_4(u32 n);
-VM_C_API void box_signed_cell(fixnum integer);
-VM_C_API void box_unsigned_cell(cell cell);
-VM_C_API void box_signed_8(s64 n);
-VM_C_API void box_unsigned_8(u64 n);
-
-VM_C_API s64 to_signed_8(cell obj);
-VM_C_API u64 to_unsigned_8(cell obj);
-
-VM_C_API fixnum to_fixnum(cell tagged);
-VM_C_API cell to_cell(cell tagged);
-
-VM_ASM_API void overflow_fixnum_add(fixnum x, fixnum y);
-VM_ASM_API void overflow_fixnum_subtract(fixnum x, fixnum y);
-VM_ASM_API void overflow_fixnum_multiply(fixnum x, fixnum y);
+VM_C_API void box_float(float flo, factorvm *vm);
+VM_C_API float to_float(cell value, factorvm *vm);
+VM_C_API void box_double(double flo, factorvm *vm);
+VM_C_API double to_double(cell value, factorvm *vm);
+
+VM_C_API void box_signed_1(s8 n, factorvm *vm);
+VM_C_API void box_unsigned_1(u8 n, factorvm *vm);
+VM_C_API void box_signed_2(s16 n, factorvm *vm);
+VM_C_API void box_unsigned_2(u16 n, factorvm *vm);
+VM_C_API void box_signed_4(s32 n, factorvm *vm);
+VM_C_API void box_unsigned_4(u32 n, factorvm *vm);
+VM_C_API void box_signed_cell(fixnum integer, factorvm *vm);
+VM_C_API void box_unsigned_cell(cell cell, factorvm *vm);
+VM_C_API void box_signed_8(s64 n, factorvm *vm);
+VM_C_API void box_unsigned_8(u64 n, factorvm *vm);
+
+VM_C_API s64 to_signed_8(cell obj, factorvm *vm);
+VM_C_API u64 to_unsigned_8(cell obj, factorvm *vm);
+
+VM_C_API fixnum to_fixnum(cell tagged, factorvm *vm);
+VM_C_API cell to_cell(cell tagged, factorvm *vm);
+
+VM_ASM_API_OVERFLOW void overflow_fixnum_add(fixnum x, fixnum y, factorvm *vm);
+VM_ASM_API_OVERFLOW void overflow_fixnum_subtract(fixnum x, fixnum y, factorvm *vm);
+VM_ASM_API_OVERFLOW void overflow_fixnum_multiply(fixnum x, fixnum y, factorvm *vm);
}
namespace factor
{
-void c_to_factor_toplevel(cell quot)
+void factorvm::c_to_factor_toplevel(cell quot)
{
- c_to_factor(quot);
+ c_to_factor(quot,this);
}
void init_signals()
: "r0","r1","r2");
if(result < 0)
- critical_error("flush_icache() failed",result);
+ SIGNAL_VM_PTR->critical_error("flush_icache() failed",result);
}
}
VM_C_API int inotify_init()
{
- not_implemented_error();
+ VM_PTR->not_implemented_error();
return -1;
}
VM_C_API int inotify_add_watch(int fd, const char *name, u32 mask)
{
- not_implemented_error();
+ VM_PTR->not_implemented_error();
return -1;
}
VM_C_API int inotify_rm_watch(int fd, u32 wd)
{
- not_implemented_error();
+ VM_PTR->not_implemented_error();
return -1;
}
namespace factor
{
-void c_to_factor_toplevel(cell quot)
+void factorvm::c_to_factor_toplevel(cell quot)
{
for(;;)
{
NS_DURING
- c_to_factor(quot);
+ c_to_factor(quot,this);
NS_VOIDRETURN;
NS_HANDLER
dpush(allot_alien(F,(cell)localException));
namespace factor
{
-void start_thread(void *(*start_routine)(void *))
+THREADHANDLE start_thread(void *(*start_routine)(void *),void *args)
{
pthread_attr_t attr;
pthread_t thread;
-
if (pthread_attr_init (&attr) != 0)
fatal_error("pthread_attr_init() failed",0);
- if (pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED) != 0)
+ if (pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_JOINABLE) != 0)
fatal_error("pthread_attr_setdetachstate() failed",0);
- if (pthread_create (&thread, &attr, start_routine, NULL) != 0)
+ if (pthread_create (&thread, &attr, start_routine, args) != 0)
fatal_error("pthread_create() failed",0);
pthread_attr_destroy (&attr);
+ return thread;
+}
+
+
+pthread_key_t tlsKey = 0;
+
+void init_platform_globals()
+{
+ if (pthread_key_create(&tlsKey, NULL) != 0){
+ fatal_error("pthread_key_create() failed",0);
+ }
+
+}
+
+void register_vm_with_thread(factorvm *vm)
+{
+ pthread_setspecific(tlsKey,vm);
+}
+
+factorvm *tls_vm()
+{
+ return (factorvm*)pthread_getspecific(tlsKey);
}
static void *null_dll;
usleep(usec);
}
-void init_ffi()
+void factorvm::init_ffi()
{
/* NULL_DLL is "libfactor.dylib" for OS X and NULL for generic unix */
null_dll = dlopen(NULL_DLL,RTLD_LAZY);
}
-void ffi_dlopen(dll *dll)
+void factorvm::ffi_dlopen(dll *dll)
{
dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY);
}
-void *ffi_dlsym(dll *dll, symbol_char *symbol)
+void *factorvm::ffi_dlsym(dll *dll, symbol_char *symbol)
{
void *handle = (dll == NULL ? null_dll : dll->dll);
return dlsym(handle,symbol);
}
-void ffi_dlclose(dll *dll)
+void factorvm::ffi_dlclose(dll *dll)
{
if(dlclose(dll->dll))
general_error(ERROR_FFI,F,F,NULL);
dll->dll = NULL;
}
-PRIMITIVE(existsp)
+
+
+
+inline void factorvm::vmprim_existsp()
{
struct stat sb;
char *path = (char *)(untag_check<byte_array>(dpop()) + 1);
box_boolean(stat(path,&sb) >= 0);
}
-segment *alloc_segment(cell size)
+PRIMITIVE(existsp)
+{
+ PRIMITIVE_GETVM()->vmprim_existsp();
+}
+
+segment *factorvm::alloc_segment(cell size)
{
int pagesize = getpagesize();
free(block);
}
-static stack_frame *uap_stack_pointer(void *uap)
+stack_frame *factorvm::uap_stack_pointer(void *uap)
{
/* There is a race condition here, but in practice a signal
delivered during stack frame setup/teardown or while transitioning
return NULL;
}
-void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+
+
+void factorvm::memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
signal_fault_addr = (cell)siginfo->si_addr;
signal_callstack_top = uap_stack_pointer(uap);
- UAP_PROGRAM_COUNTER(uap) = (cell)memory_signal_handler_impl;
+ UAP_PROGRAM_COUNTER(uap) = (cell)factor::memory_signal_handler_impl;
}
-void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+{
+ SIGNAL_VM_PTR()->memory_signal_handler(signal,siginfo,uap);
+}
+
+
+void factorvm::misc_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
signal_number = signal;
signal_callstack_top = uap_stack_pointer(uap);
- UAP_PROGRAM_COUNTER(uap) = (cell)misc_signal_handler_impl;
+ UAP_PROGRAM_COUNTER(uap) = (cell)factor::misc_signal_handler_impl;
}
-void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+{
+ SIGNAL_VM_PTR()->misc_signal_handler(signal,siginfo,uap);
+}
+
+void factorvm::fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
signal_number = signal;
signal_callstack_top = uap_stack_pointer(uap);
- signal_fpu_status = fpu_status(uap_fpu_status(uap));
- uap_clear_fpu_status(uap);
+ signal_fpu_status = fpu_status(uap_fpu_status(uap));
+ uap_clear_fpu_status(uap);
UAP_PROGRAM_COUNTER(uap) =
- (siginfo->si_code == FPE_INTDIV || siginfo->si_code == FPE_INTOVF)
- ? (cell)misc_signal_handler_impl
- : (cell)fp_signal_handler_impl;
+ (siginfo->si_code == FPE_INTDIV || siginfo->si_code == FPE_INTOVF)
+ ? (cell)factor::misc_signal_handler_impl
+ : (cell)factor::fp_signal_handler_impl;
+}
+
+void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+{
+ SIGNAL_VM_PTR()->fpe_signal_handler(signal, siginfo, uap);
}
static void sigaction_safe(int signum, const struct sigaction *act, struct sigaction *oldact)
stdin_read = filedes[0];
stdin_write = filedes[1];
- start_thread(stdin_loop);
+ start_thread(stdin_loop,NULL);
}
VM_C_API void wait_for_stdin()
#define print_native_string(string) print_string(string)
-void start_thread(void *(*start_routine)(void *));
+typedef pthread_t THREADHANDLE;
-void init_ffi();
-void ffi_dlopen(dll *dll);
-void *ffi_dlsym(dll *dll, symbol_char *symbol);
-void ffi_dlclose(dll *dll);
+THREADHANDLE start_thread(void *(*start_routine)(void *),void *args);
+pthread_t thread_id();
void unix_init_signals();
void signal_handler(int signal, siginfo_t* siginfo, void* uap);
s64 current_micros();
void sleep_micros(cell usec);
+void init_platform_globals();
+struct factorvm;
+void register_vm_with_thread(factorvm *vm);
+factorvm *tls_vm();
void open_console();
-
}
char *getenv(char *name)
{
- not_implemented_error();
+ vm->not_implemented_error();
return 0; /* unreachable */
}
PRIMITIVE(os_envs)
{
- not_implemented_error();
+ vm->not_implemented_error();
}
void c_to_factor_toplevel(cell quot)
{
- c_to_factor(quot);
+ c_to_factor(quot,vm);
}
void open_console() { }
namespace factor
{
+
+THREADHANDLE start_thread(void *(*start_routine)(void *),void *args){
+ return (void*) CreateThread(NULL, 0, (LPTHREAD_START_ROUTINE)start_routine, args, 0, 0);
+}
+
+
+DWORD dwTlsIndex;
+
+void init_platform_globals()
+{
+ if ((dwTlsIndex = TlsAlloc()) == TLS_OUT_OF_INDEXES) {
+ fatal_error("TlsAlloc failed - out of indexes",0);
+ }
+}
+
+void register_vm_with_thread(factorvm *vm)
+{
+ if (! TlsSetValue(dwTlsIndex, vm)) {
+ fatal_error("TlsSetValue failed",0);
+ }
+}
+
+factorvm *tls_vm()
+{
+ return (factorvm*)TlsGetValue(dwTlsIndex);
+}
+
+
s64 current_micros()
{
FILETIME t;
- EPOCH_OFFSET) / 10;
}
-FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe)
+LONG factorvm::exception_handler(PEXCEPTION_POINTERS pe)
{
PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord;
CONTEXT *c = (CONTEXT*)pe->ContextRecord;
else
signal_callstack_top = NULL;
- switch (e->ExceptionCode)
- {
- case EXCEPTION_ACCESS_VIOLATION:
+ switch (e->ExceptionCode) {
+ case EXCEPTION_ACCESS_VIOLATION:
signal_fault_addr = e->ExceptionInformation[1];
- c->EIP = (cell)memory_signal_handler_impl;
+ c->EIP = (cell)factor::memory_signal_handler_impl;
break;
case STATUS_FLOAT_DENORMAL_OPERAND:
signal_fpu_status = fpu_status(X87SW(c) | MXCSR(c));
X87SW(c) = 0;
MXCSR(c) &= 0xffffffc0;
- c->EIP = (cell)fp_signal_handler_impl;
+ c->EIP = (cell)factor::fp_signal_handler_impl;
break;
case 0x40010006:
/* If the Widcomm bluetooth stack is installed, the BTTray.exe
break;
default:
signal_number = e->ExceptionCode;
- c->EIP = (cell)misc_signal_handler_impl;
+ c->EIP = (cell)factor::misc_signal_handler_impl;
break;
}
return EXCEPTION_CONTINUE_EXECUTION;
}
-void c_to_factor_toplevel(cell quot)
+
+FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe)
+{
+ return SIGNAL_VM_PTR()->exception_handler(pe);
+}
+
+bool handler_added = 0;
+
+void factorvm::c_to_factor_toplevel(cell quot)
{
- if(!AddVectoredExceptionHandler(0, (PVECTORED_EXCEPTION_HANDLER)exception_handler))
- fatal_error("AddVectoredExceptionHandler failed", 0);
- c_to_factor(quot);
- RemoveVectoredExceptionHandler((void *)exception_handler);
+ if(!handler_added){
+ if(!AddVectoredExceptionHandler(0, (PVECTORED_EXCEPTION_HANDLER)factor::exception_handler))
+ fatal_error("AddVectoredExceptionHandler failed", 0);
+ handler_added = 1;
+ }
+ c_to_factor(quot,this);
+ RemoveVectoredExceptionHandler((void *)factor::exception_handler);
}
-void open_console()
+void factorvm::open_console()
{
}
#define FACTOR_STDCALL __attribute__((stdcall))
-void c_to_factor_toplevel(cell quot);
FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe);
-void open_console();
// SSE traps raise these exception codes, which are defined in internal NT headers
// but not winbase.h
#define STATUS_FLOAT_MULTIPLE_FAULTS 0xC00002B4
#define STATUS_FLOAT_MULTIPLE_TRAPS 0xC00002B5
+typedef HANDLE THREADHANDLE;
+
+THREADHANDLE start_thread(void *(*start_routine)(void *),void *args);
+
+void init_platform_globals();
+struct factorvm;
+void register_vm_with_thread(factorvm *vm);
+factorvm *tls_vm();
+
}
HMODULE hFactorDll;
-void init_ffi()
+void factorvm::init_ffi()
{
hFactorDll = GetModuleHandle(FACTOR_DLL);
if(!hFactorDll)
fatal_error("GetModuleHandle(\"" FACTOR_DLL_NAME "\") failed", 0);
}
-void ffi_dlopen(dll *dll)
+void factorvm::ffi_dlopen(dll *dll)
{
dll->dll = LoadLibraryEx((WCHAR *)alien_offset(dll->path), NULL, 0);
}
-void *ffi_dlsym(dll *dll, symbol_char *symbol)
+void *factorvm::ffi_dlsym(dll *dll, symbol_char *symbol)
{
return (void *)GetProcAddress(dll ? (HMODULE)dll->dll : hFactorDll, symbol);
}
-void ffi_dlclose(dll *dll)
+void factorvm::ffi_dlclose(dll *dll)
{
FreeLibrary((HMODULE)dll->dll);
dll->dll = NULL;
}
-bool windows_stat(vm_char *path)
+bool factorvm::windows_stat(vm_char *path)
{
BY_HANDLE_FILE_INFORMATION bhfi;
HANDLE h = CreateFileW(path,
return ret;
}
-void windows_image_path(vm_char *full_path, vm_char *temp_path, unsigned int length)
+
+void factorvm::windows_image_path(vm_char *full_path, vm_char *temp_path, unsigned int length)
{
snwprintf(temp_path, length-1, L"%s.image", full_path);
- temp_path[sizeof(temp_path) - 1] = 0;
+ temp_path[length - 1] = 0;
}
/* You must free() this yourself. */
-const vm_char *default_image_path()
+const vm_char *factorvm::default_image_path()
{
vm_char full_path[MAX_UNICODE_PATH];
vm_char *ptr;
if((ptr = wcsrchr(full_path, '.')))
*ptr = 0;
- snwprintf(temp_path, sizeof(temp_path)-1, L"%s.image", full_path);
- temp_path[sizeof(temp_path) - 1] = 0;
+ snwprintf(temp_path, MAX_UNICODE_PATH-1, L"%s.image", full_path);
+ temp_path[MAX_UNICODE_PATH - 1] = 0;
return safe_strdup(temp_path);
}
/* You must free() this yourself. */
-const vm_char *vm_executable_path()
+const vm_char *factorvm::vm_executable_path()
{
vm_char full_path[MAX_UNICODE_PATH];
if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH))
}
-PRIMITIVE(existsp)
+inline void factorvm::vmprim_existsp()
{
vm_char *path = untag_check<byte_array>(dpop())->data<vm_char>();
box_boolean(windows_stat(path));
}
-segment *alloc_segment(cell size)
+PRIMITIVE(existsp)
+{
+ PRIMITIVE_GETVM()->vmprim_existsp();
+}
+
+segment *factorvm::alloc_segment(cell size)
{
char *mem;
DWORD ignore;
return block;
}
-void dealloc_segment(segment *block)
+void factorvm::dealloc_segment(segment *block)
{
SYSTEM_INFO si;
GetSystemInfo(&si);
free(block);
}
-long getpagesize()
+long factorvm::getpagesize()
{
static long g_pagesize = 0;
if (! g_pagesize)
return g_pagesize;
}
-void sleep_micros(u64 usec)
+void factorvm::sleep_micros(u64 usec)
{
Sleep((DWORD)(usec / 1000));
}
/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
#define EPOCH_OFFSET 0x019db1ded53e8000LL
-void init_ffi();
-void ffi_dlopen(dll *dll);
-void *ffi_dlsym(dll *dll, symbol_char *symbol);
-void ffi_dlclose(dll *dll);
-
-void sleep_micros(u64 msec);
inline static void init_signals() {}
inline static void early_init() {}
-const vm_char *vm_executable_path();
-const vm_char *default_image_path();
-long getpagesize ();
s64 current_micros();
primitive_inline_cache_stats,
primitive_optimized_p,
primitive_quot_compiled_p,
+ primitive_vm_ptr,
};
}
namespace factor
{
-extern "C" typedef void (*primitive_type)();
-extern const primitive_type primitives[];
-
-#define PRIMITIVE(name) extern "C" void primitive_##name()
+#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)
+#else
+ extern "C" typedef void (*primitive_type)(void *myvm);
+ #define PRIMITIVE(name) extern "C" void primitive_##name(void *myvm)
+#endif
+extern const primitive_type primitives[];
}
namespace factor
{
-bool profiling_p;
-void init_profiler()
+void factorvm::init_profiler()
{
profiling_p = false;
}
+
/* Allocates memory */
-code_block *compile_profiling_stub(cell word_)
+code_block *factorvm::compile_profiling_stub(cell word_)
{
- gc_root<word> word(word_);
+ gc_root<word> word(word_,this);
- jit jit(WORD_TYPE,word.value());
+ jit jit(WORD_TYPE,word.value(),this);
jit.emit_with(userenv[JIT_PROFILING],word.value());
return jit.to_code_block();
}
+
/* Allocates memory */
-static void set_profiling(bool profiling)
+void factorvm::set_profiling(bool profiling)
{
if(profiling == profiling_p)
return;
and allocate profiling blocks if necessary */
gc();
- gc_root<array> words(find_all_words());
+ gc_root<array> words(find_all_words(),this);
cell i;
cell length = array_capacity(words.untagged());
}
/* Update XTs in code heap */
- iterate_code_heap(relocate_code_block);
+ iterate_code_heap(factor::relocate_code_block);
}
-PRIMITIVE(profiling)
+
+inline void factorvm::vmprim_profiling()
{
set_profiling(to_boolean(dpop()));
}
+PRIMITIVE(profiling)
+{
+ PRIMITIVE_GETVM()->vmprim_profiling();
+}
+
}
namespace factor
{
-extern bool profiling_p;
-void init_profiler();
-code_block *compile_profiling_stub(cell word);
PRIMITIVE(profiling);
}
{
return (i + 2) == array_capacity(elements.untagged())
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(FIXNUM_TYPE)
- && array_nth(elements.untagged(),i + 1) == userenv[JIT_PRIMITIVE_WORD];
+ && array_nth(elements.untagged(),i + 1) == myvm->userenv[JIT_PRIMITIVE_WORD];
}
bool quotation_jit::fast_if_p(cell i)
return (i + 3) == array_capacity(elements.untagged())
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
&& tagged<object>(array_nth(elements.untagged(),i + 1)).type_p(QUOTATION_TYPE)
- && array_nth(elements.untagged(),i + 2) == userenv[JIT_IF_WORD];
+ && array_nth(elements.untagged(),i + 2) == myvm->userenv[JIT_IF_WORD];
}
bool quotation_jit::fast_dip_p(cell i)
{
return (i + 2) <= array_capacity(elements.untagged())
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
- && array_nth(elements.untagged(),i + 1) == userenv[JIT_DIP_WORD];
+ && array_nth(elements.untagged(),i + 1) == myvm->userenv[JIT_DIP_WORD];
}
bool quotation_jit::fast_2dip_p(cell i)
{
return (i + 2) <= array_capacity(elements.untagged())
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
- && array_nth(elements.untagged(),i + 1) == userenv[JIT_2DIP_WORD];
+ && array_nth(elements.untagged(),i + 1) == myvm->userenv[JIT_2DIP_WORD];
}
bool quotation_jit::fast_3dip_p(cell i)
{
return (i + 2) <= array_capacity(elements.untagged())
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
- && array_nth(elements.untagged(),i + 1) == userenv[JIT_3DIP_WORD];
+ && array_nth(elements.untagged(),i + 1) == myvm->userenv[JIT_3DIP_WORD];
}
bool quotation_jit::mega_lookup_p(cell i)
&& tagged<object>(array_nth(elements.untagged(),i)).type_p(ARRAY_TYPE)
&& tagged<object>(array_nth(elements.untagged(),i + 1)).type_p(FIXNUM_TYPE)
&& tagged<object>(array_nth(elements.untagged(),i + 2)).type_p(ARRAY_TYPE)
- && array_nth(elements.untagged(),i + 3) == userenv[MEGA_LOOKUP_WORD];
+ && array_nth(elements.untagged(),i + 3) == myvm->userenv[MEGA_LOOKUP_WORD];
}
bool quotation_jit::stack_frame_p()
switch(tagged<object>(obj).type())
{
case WORD_TYPE:
- if(untag<word>(obj)->subprimitive == F)
+ if(myvm->untag<word>(obj)->subprimitive == F)
return true;
break;
case QUOTATION_TYPE:
set_position(0);
if(stack_frame)
- emit(userenv[JIT_PROLOG]);
+ emit(myvm->userenv[JIT_PROLOG]);
cell i;
cell length = array_capacity(elements.untagged());
{
set_position(i);
- gc_root<object> obj(array_nth(elements.untagged(),i));
+ gc_root<object> obj(array_nth(elements.untagged(),i),myvm);
switch(obj.type())
{
if(obj.as<word>()->subprimitive != F)
emit_subprimitive(obj.value());
/* The (execute) primitive is special-cased */
- else if(obj.value() == userenv[JIT_EXECUTE_WORD])
+ else if(obj.value() == myvm->userenv[JIT_EXECUTE_WORD])
{
if(i == length - 1)
{
- if(stack_frame) emit(userenv[JIT_EPILOG]);
+ if(stack_frame) emit(myvm->userenv[JIT_EPILOG]);
tail_call = true;
- emit(userenv[JIT_EXECUTE_JUMP]);
+ emit(myvm->userenv[JIT_EXECUTE_JUMP]);
}
else
- emit(userenv[JIT_EXECUTE_CALL]);
+ emit(myvm->userenv[JIT_EXECUTE_CALL]);
}
/* Everything else */
else
{
if(i == length - 1)
{
- if(stack_frame) emit(userenv[JIT_EPILOG]);
+ if(stack_frame) emit(myvm->userenv[JIT_EPILOG]);
tail_call = true;
/* Inline cache misses are special-cased.
The calling convention for tail
the inline cache miss primitive, and
we don't want to clobber the saved
address. */
- if(obj.value() == userenv[PIC_MISS_WORD]
- || obj.value() == userenv[PIC_MISS_TAIL_WORD])
+ if(obj.value() == myvm->userenv[PIC_MISS_WORD]
+ || obj.value() == myvm->userenv[PIC_MISS_TAIL_WORD])
{
word_special(obj.value());
}
/* Primitive calls */
if(primitive_call_p(i))
{
- emit_with(userenv[JIT_PRIMITIVE],obj.value());
+ emit_with(myvm->userenv[JIT_PRIMITIVE],obj.value());
i++;
mutually recursive in the library, but both still work) */
if(fast_if_p(i))
{
- if(stack_frame) emit(userenv[JIT_EPILOG]);
+ if(stack_frame) emit(myvm->userenv[JIT_EPILOG]);
tail_call = true;
if(compiling)
{
- jit_compile(array_nth(elements.untagged(),i),relocate);
- jit_compile(array_nth(elements.untagged(),i + 1),relocate);
+ myvm->jit_compile(array_nth(elements.untagged(),i),relocate);
+ myvm->jit_compile(array_nth(elements.untagged(),i + 1),relocate);
}
literal(array_nth(elements.untagged(),i));
literal(array_nth(elements.untagged(),i + 1));
- emit(userenv[JIT_IF]);
+ emit(myvm->userenv[JIT_IF]);
i += 2;
else if(fast_dip_p(i))
{
if(compiling)
- jit_compile(obj.value(),relocate);
- emit_with(userenv[JIT_DIP],obj.value());
+ myvm->jit_compile(obj.value(),relocate);
+ emit_with(myvm->userenv[JIT_DIP],obj.value());
i++;
break;
}
else if(fast_2dip_p(i))
{
if(compiling)
- jit_compile(obj.value(),relocate);
- emit_with(userenv[JIT_2DIP],obj.value());
+ myvm->jit_compile(obj.value(),relocate);
+ emit_with(myvm->userenv[JIT_2DIP],obj.value());
i++;
break;
}
else if(fast_3dip_p(i))
{
if(compiling)
- jit_compile(obj.value(),relocate);
- emit_with(userenv[JIT_3DIP],obj.value());
+ myvm->jit_compile(obj.value(),relocate);
+ emit_with(myvm->userenv[JIT_3DIP],obj.value());
i++;
break;
}
set_position(length);
if(stack_frame)
- emit(userenv[JIT_EPILOG]);
- emit(userenv[JIT_RETURN]);
+ emit(myvm->userenv[JIT_EPILOG]);
+ emit(myvm->userenv[JIT_RETURN]);
}
}
-void set_quot_xt(quotation *quot, code_block *code)
+void factorvm::set_quot_xt(quotation *quot, code_block *code)
{
if(code->type != QUOTATION_TYPE)
critical_error("Bad param to set_quot_xt",(cell)code);
}
/* Allocates memory */
-void jit_compile(cell quot_, bool relocating)
+void factorvm::jit_compile(cell quot_, bool relocating)
{
- gc_root<quotation> quot(quot_);
+ gc_root<quotation> quot(quot_,this);
if(quot->code) return;
- quotation_jit compiler(quot.value(),true,relocating);
+ quotation_jit compiler(quot.value(),true,relocating,this);
compiler.iterate_quotation();
code_block *compiled = compiler.to_code_block();
if(relocating) relocate_code_block(compiled);
}
-PRIMITIVE(jit_compile)
+inline void factorvm::vmprim_jit_compile()
{
jit_compile(dpop(),true);
}
+PRIMITIVE(jit_compile)
+{
+ PRIMITIVE_GETVM()->vmprim_jit_compile();
+}
+
/* push a new quotation on the stack */
-PRIMITIVE(array_to_quotation)
+inline void factorvm::vmprim_array_to_quotation()
{
quotation *quot = allot<quotation>(sizeof(quotation));
quot->array = dpeek();
drepl(tag<quotation>(quot));
}
-PRIMITIVE(quotation_xt)
+PRIMITIVE(array_to_quotation)
+{
+ PRIMITIVE_GETVM()->vmprim_array_to_quotation();
+}
+
+inline void factorvm::vmprim_quotation_xt()
{
quotation *quot = untag_check<quotation>(dpeek());
drepl(allot_cell((cell)quot->xt));
}
-void compile_all_words()
+PRIMITIVE(quotation_xt)
{
- gc_root<array> words(find_all_words());
+ PRIMITIVE_GETVM()->vmprim_quotation_xt();
+}
+
+void factorvm::compile_all_words()
+{
+ gc_root<array> words(find_all_words(),this);
cell i;
cell length = array_capacity(words.untagged());
for(i = 0; i < length; i++)
{
- gc_root<word> word(array_nth(words.untagged(),i));
+ gc_root<word> word(array_nth(words.untagged(),i),this);
if(!word->code || !word_optimized_p(word.untagged()))
jit_compile_word(word.value(),word->def,false);
}
- iterate_code_heap(relocate_code_block);
+ iterate_code_heap(factor::relocate_code_block);
}
/* Allocates memory */
-fixnum quot_code_offset_to_scan(cell quot_, cell offset)
+fixnum factorvm::quot_code_offset_to_scan(cell quot_, cell offset)
{
- gc_root<quotation> quot(quot_);
- gc_root<array> array(quot->array);
+ gc_root<quotation> quot(quot_,this);
+ gc_root<array> array(quot->array,this);
- quotation_jit compiler(quot.value(),false,false);
+ quotation_jit compiler(quot.value(),false,false,this);
compiler.compute_position(offset);
compiler.iterate_quotation();
return compiler.get_position();
}
-VM_ASM_API cell lazy_jit_compile_impl(cell quot_, stack_frame *stack)
+cell factorvm::lazy_jit_compile_impl(cell quot_, stack_frame *stack)
{
- gc_root<quotation> quot(quot_);
+ gc_root<quotation> quot(quot_,this);
stack_chain->callstack_top = stack;
jit_compile(quot.value(),true);
return quot.value();
}
-PRIMITIVE(quot_compiled_p)
+VM_ASM_API cell lazy_jit_compile_impl(cell quot_, stack_frame *stack, factorvm *myvm)
+{
+ ASSERTVM();
+ return VM_PTR->lazy_jit_compile_impl(quot_,stack);
+}
+
+inline void factorvm::vmprim_quot_compiled_p()
{
tagged<quotation> quot(dpop());
- quot.untag_check();
+ quot.untag_check(this);
dpush(tag_boolean(quot->code != NULL));
}
+PRIMITIVE(quot_compiled_p)
+{
+ PRIMITIVE_GETVM()->vmprim_quot_compiled_p();
+}
+
}
gc_root<array> elements;
bool compiling, relocate;
- quotation_jit(cell quot, bool compiling_, bool relocate_)
- : jit(QUOTATION_TYPE,quot),
- elements(owner.as<quotation>().untagged()->array),
+ quotation_jit(cell quot, bool compiling_, bool relocate_, factorvm *vm)
+ : jit(QUOTATION_TYPE,quot,vm),
+ elements(owner.as<quotation>().untagged()->array,vm),
compiling(compiling_),
- relocate(relocate_) {};
+ relocate(relocate_){};
void emit_mega_cache_lookup(cell methods, fixnum index, cell cache);
bool primitive_call_p(cell i);
void iterate_quotation();
};
-void set_quot_xt(quotation *quot, code_block *code);
-void jit_compile(cell quot, bool relocate);
-fixnum quot_code_offset_to_scan(cell quot, cell offset);
-
PRIMITIVE(jit_compile);
-void compile_all_words();
-
PRIMITIVE(array_to_quotation);
PRIMITIVE(quotation_xt);
-VM_ASM_API cell lazy_jit_compile_impl(cell quot, stack_frame *stack);
+VM_ASM_API cell lazy_jit_compile_impl(cell quot, stack_frame *stack, factorvm *myvm);
PRIMITIVE(quot_compiled_p);
#include "master.hpp"
-factor::cell userenv[USER_ENV];
-
namespace factor
{
-cell T;
-PRIMITIVE(getenv)
+inline void factorvm::vmprim_getenv()
{
fixnum e = untag_fixnum(dpeek());
drepl(userenv[e]);
}
-PRIMITIVE(setenv)
+PRIMITIVE(getenv)
+{
+ PRIMITIVE_GETVM()->vmprim_getenv();
+}
+
+inline void factorvm::vmprim_setenv()
{
fixnum e = untag_fixnum(dpop());
cell value = dpop();
userenv[e] = value;
}
-PRIMITIVE(exit)
+PRIMITIVE(setenv)
+{
+ PRIMITIVE_GETVM()->vmprim_setenv();
+}
+
+inline void factorvm::vmprim_exit()
{
exit(to_fixnum(dpop()));
}
-PRIMITIVE(micros)
+PRIMITIVE(exit)
+{
+ PRIMITIVE_GETVM()->vmprim_exit();
+}
+
+inline void factorvm::vmprim_micros()
{
box_unsigned_8(current_micros());
}
-PRIMITIVE(sleep)
+PRIMITIVE(micros)
+{
+ PRIMITIVE_GETVM()->vmprim_micros();
+}
+
+inline void factorvm::vmprim_sleep()
{
sleep_micros(to_cell(dpop()));
}
-PRIMITIVE(set_slot)
+PRIMITIVE(sleep)
+{
+ PRIMITIVE_GETVM()->vmprim_sleep();
+}
+
+inline void factorvm::vmprim_set_slot()
{
fixnum slot = untag_fixnum(dpop());
object *obj = untag<object>(dpop());
write_barrier(obj);
}
-PRIMITIVE(load_locals)
+PRIMITIVE(set_slot)
+{
+ PRIMITIVE_GETVM()->vmprim_set_slot();
+}
+
+inline void factorvm::vmprim_load_locals()
{
fixnum count = untag_fixnum(dpop());
memcpy((cell *)(rs + sizeof(cell)),(cell *)(ds - sizeof(cell) * (count - 1)),sizeof(cell) * count);
rs += sizeof(cell) * count;
}
-static cell clone_object(cell obj_)
+PRIMITIVE(load_locals)
+{
+ PRIMITIVE_GETVM()->vmprim_load_locals();
+}
+
+cell factorvm::clone_object(cell obj_)
{
- gc_root<object> obj(obj_);
+ gc_root<object> obj(obj_,this);
if(immediate_p(obj.value()))
return obj.value();
}
}
-PRIMITIVE(clone)
+inline void factorvm::vmprim_clone()
{
drepl(clone_object(dpeek()));
}
+PRIMITIVE(clone)
+{
+ PRIMITIVE_GETVM()->vmprim_clone();
+}
+
}
return (i >= FIRST_SAVE_ENV && i <= LAST_SAVE_ENV) || i == STACK_TRACES_ENV;
}
-/* Canonical T object. It's just a word */
-extern cell T;
-
PRIMITIVE(getenv);
PRIMITIVE(setenv);
PRIMITIVE(exit);
}
-/* TAGGED user environment data; see getenv/setenv prims */
-VM_C_API factor::cell userenv[USER_ENV];
+
cell end;
};
-inline static cell align_page(cell a)
-{
- return align(a,getpagesize());
-}
-
}
{
#define DEFPUSHPOP(prefix,ptr) \
- inline static cell prefix##peek() { return *(cell *)ptr; } \
- inline static void prefix##repl(cell tagged) { *(cell *)ptr = tagged; } \
- inline static cell prefix##pop() \
+ inline cell prefix##peek() { return *(cell *)ptr; } \
+ inline void prefix##repl(cell tagged) { *(cell *)ptr = tagged; } \
+ inline cell prefix##pop() \
{ \
cell value = prefix##peek(); \
ptr -= sizeof(cell); \
return value; \
} \
- inline static void prefix##push(cell tagged) \
+ inline void prefix##push(cell tagged) \
{ \
ptr += sizeof(cell); \
prefix##repl(tagged); \
namespace factor
{
-cell string_nth(string* str, cell index)
+cell factorvm::string_nth(string* str, cell index)
{
/* If high bit is set, the most significant 16 bits of the char
come from the aux vector. The least significant bit of the
}
}
-void set_string_nth_fast(string *str, cell index, cell ch)
+
+void factorvm::set_string_nth_fast(string *str, cell index, cell ch)
{
str->data()[index] = ch;
}
-void set_string_nth_slow(string *str_, cell index, cell ch)
+
+void factorvm::set_string_nth_slow(string *str_, cell index, cell ch)
{
- gc_root<string> str(str_);
+ gc_root<string> str(str_,this);
byte_array *aux;
aux->data<u16>()[index] = ((ch >> 7) ^ 1);
}
+
/* allocates memory */
-void set_string_nth(string *str, cell index, cell ch)
+void factorvm::set_string_nth(string *str, cell index, cell ch)
{
if(ch <= 0x7f)
set_string_nth_fast(str,index,ch);
set_string_nth_slow(str,index,ch);
}
+
/* Allocates memory */
-string *allot_string_internal(cell capacity)
+string *factorvm::allot_string_internal(cell capacity)
{
string *str = allot<string>(string_size(capacity));
return str;
}
+
/* Allocates memory */
-void fill_string(string *str_, cell start, cell capacity, cell fill)
+void factorvm::fill_string(string *str_, cell start, cell capacity, cell fill)
{
- gc_root<string> str(str_);
+ gc_root<string> str(str_,this);
if(fill <= 0x7f)
memset(&str->data()[start],fill,capacity - start);
}
}
+
/* Allocates memory */
-string *allot_string(cell capacity, cell fill)
+string *factorvm::allot_string(cell capacity, cell fill)
{
- gc_root<string> str(allot_string_internal(capacity));
+ gc_root<string> str(allot_string_internal(capacity),this);
fill_string(str.untagged(),0,capacity,fill);
return str.untagged();
}
-PRIMITIVE(string)
+
+inline void factorvm::vmprim_string()
{
cell initial = to_cell(dpop());
cell length = unbox_array_size();
dpush(tag<string>(allot_string(length,initial)));
}
-static bool reallot_string_in_place_p(string *str, cell capacity)
+PRIMITIVE(string)
+{
+ PRIMITIVE_GETVM()->vmprim_string();
+}
+
+bool factorvm::reallot_string_in_place_p(string *str, cell capacity)
{
return in_zone(&nursery,str)
&& (str->aux == F || in_zone(&nursery,untag<byte_array>(str->aux)))
&& capacity <= string_capacity(str);
}
-string* reallot_string(string *str_, cell capacity)
+
+string* factorvm::reallot_string(string *str_, cell capacity)
{
- gc_root<string> str(str_);
+ gc_root<string> str(str_,this);
if(reallot_string_in_place_p(str.untagged(),capacity))
{
if(capacity < to_copy)
to_copy = capacity;
- gc_root<string> new_str(allot_string_internal(capacity));
+ gc_root<string> new_str(allot_string_internal(capacity),this);
memcpy(new_str->data(),str->data(),to_copy);
}
}
-PRIMITIVE(resize_string)
+
+inline void factorvm::vmprim_resize_string()
{
string* str = untag_check<string>(dpop());
cell capacity = unbox_array_size();
dpush(tag<string>(reallot_string(str,capacity)));
}
-PRIMITIVE(string_nth)
+PRIMITIVE(resize_string)
+{
+ PRIMITIVE_GETVM()->vmprim_resize_string();
+}
+
+inline void factorvm::vmprim_string_nth()
{
string *str = untag<string>(dpop());
cell index = untag_fixnum(dpop());
dpush(tag_fixnum(string_nth(str,index)));
}
-PRIMITIVE(set_string_nth_fast)
+PRIMITIVE(string_nth)
+{
+ PRIMITIVE_GETVM()->vmprim_string_nth();
+}
+
+inline void factorvm::vmprim_set_string_nth_fast()
{
string *str = untag<string>(dpop());
cell index = untag_fixnum(dpop());
set_string_nth_fast(str,index,value);
}
-PRIMITIVE(set_string_nth_slow)
+PRIMITIVE(set_string_nth_fast)
+{
+ PRIMITIVE_GETVM()->vmprim_set_string_nth_fast();
+}
+
+inline void factorvm::vmprim_set_string_nth_slow()
{
string *str = untag<string>(dpop());
cell index = untag_fixnum(dpop());
set_string_nth_slow(str,index,value);
}
+PRIMITIVE(set_string_nth_slow)
+{
+ PRIMITIVE_GETVM()->vmprim_set_string_nth_slow();
+}
+
}
return sizeof(string) + size;
}
-string* allot_string_internal(cell capacity);
-string* allot_string(cell capacity, cell fill);
PRIMITIVE(string);
-string *reallot_string(string *string, cell capacity);
PRIMITIVE(resize_string);
-/* String getters and setters */
-cell string_nth(string* string, cell index);
-void set_string_nth(string* string, cell index, cell value);
-
PRIMITIVE(string_nth);
PRIMITIVE(set_string_nth_slow);
PRIMITIVE(set_string_nth_fast);
namespace factor
{
-template <typename T> cell tag(T *value)
+template <typename TYPE> cell tag(TYPE *value)
{
- return RETAG(value,tag_for(T::type_number));
+ return RETAG(value,tag_for(TYPE::type_number));
}
inline static cell tag_dynamic(object *value)
return RETAG(value,tag_for(value->h.hi_tag()));
}
-template <typename T>
+template <typename TYPE>
struct tagged
{
cell value_;
cell value() const { return value_; }
- T *untagged() const { return (T *)(UNTAG(value_)); }
+ TYPE *untagged() const { return (TYPE *)(UNTAG(value_)); }
cell type() const {
cell tag = TAG(value_);
bool type_p(cell type_) const { return type() == type_; }
- T *untag_check() const {
- if(T::type_number != TYPE_COUNT && !type_p(T::type_number))
- type_error(T::type_number,value_);
+ TYPE *untag_check(factorvm *myvm) const {
+ if(TYPE::type_number != TYPE_COUNT && !type_p(TYPE::type_number))
+ myvm->type_error(TYPE::type_number,value_);
return untagged();
}
explicit tagged(cell tagged) : value_(tagged) {
#ifdef FACTOR_DEBUG
- untag_check();
+ untag_check(SIGNAL_VM_PTR());
#endif
}
- explicit tagged(T *untagged) : value_(factor::tag(untagged)) {
+ explicit tagged(TYPE *untagged) : value_(factor::tag(untagged)) {
#ifdef FACTOR_DEBUG
- untag_check();
+ untag_check(SIGNAL_VM_PTR());
#endif
}
- T *operator->() const { return untagged(); }
+ TYPE *operator->() const { return untagged(); }
cell *operator&() const { return &value_; }
- const tagged<T>& operator=(const T *x) { value_ = tag(x); return *this; }
- const tagged<T>& operator=(const cell &x) { value_ = x; return *this; }
+ const tagged<TYPE>& operator=(const TYPE *x) { value_ = tag(x); return *this; }
+ const tagged<TYPE>& operator=(const cell &x) { value_ = x; return *this; }
- bool operator==(const tagged<T> &x) { return value_ == x.value_; }
- bool operator!=(const tagged<T> &x) { return value_ != x.value_; }
+ bool operator==(const tagged<TYPE> &x) { return value_ == x.value_; }
+ bool operator!=(const tagged<TYPE> &x) { return value_ != x.value_; }
template<typename X> tagged<X> as() { return tagged<X>(value_); }
};
-template <typename T> T *untag_check(cell value)
+template <typename TYPE> TYPE *factorvm::untag_check(cell value)
{
- return tagged<T>(value).untag_check();
+ return tagged<TYPE>(value).untag_check(this);
}
-template <typename T> T *untag(cell value)
+template <typename TYPE> TYPE *factorvm::untag(cell value)
{
- return tagged<T>(value).untagged();
+ return tagged<TYPE>(value).untagged();
}
}
{
/* push a new tuple on the stack */
-tuple *allot_tuple(cell layout_)
+tuple *factorvm::allot_tuple(cell layout_)
{
- gc_root<tuple_layout> layout(layout_);
- gc_root<tuple> t(allot<tuple>(tuple_size(layout.untagged())));
+ gc_root<tuple_layout> layout(layout_,this);
+ gc_root<tuple> t(allot<tuple>(tuple_size(layout.untagged())),this);
t->layout = layout.value();
return t.untagged();
}
-PRIMITIVE(tuple)
+inline void factorvm::vmprim_tuple()
{
- gc_root<tuple_layout> layout(dpop());
+ gc_root<tuple_layout> layout(dpop(),this);
tuple *t = allot_tuple(layout.value());
fixnum i;
for(i = tuple_size(layout.untagged()) - 1; i >= 0; i--)
dpush(tag<tuple>(t));
}
+PRIMITIVE(tuple)
+{
+ PRIMITIVE_GETVM()->vmprim_tuple();
+}
+
/* push a new tuple on the stack, filling its slots from the stack */
-PRIMITIVE(tuple_boa)
+inline void factorvm::vmprim_tuple_boa()
{
- gc_root<tuple_layout> layout(dpop());
- gc_root<tuple> t(allot_tuple(layout.value()));
+ gc_root<tuple_layout> layout(dpop(),this);
+ gc_root<tuple> t(allot_tuple(layout.value()),this);
cell size = untag_fixnum(layout.untagged()->size) * sizeof(cell);
memcpy(t->data(),(cell *)(ds - (size - sizeof(cell))),size);
ds -= size;
dpush(t.value());
}
+PRIMITIVE(tuple_boa)
+{
+ PRIMITIVE_GETVM()->vmprim_tuple_boa();
+}
+
}
return ptr;
}
+
/* We don't use printf directly, because format directives are not portable.
Instead we define the common cases here. */
void nl()
fputs(str,stdout);
}
+
void print_cell(cell x)
{
printf(CELL_FORMAT,x);
cell cell;
if(scanf(CELL_HEX_FORMAT,&cell) < 0) exit(1);
return cell;
-};
+}
}
namespace factor
{
-
-void *safe_malloc(size_t size);
-vm_char *safe_strdup(const vm_char *str);
-
-void nl();
-void print_string(const char *str);
-void print_cell(cell x);
-void print_cell_hex(cell x);
-void print_cell_hex_pad(cell x);
-void print_fixnum(fixnum x);
-cell read_cell_hex();
-
+ void *safe_malloc(size_t size);
+ vm_char *safe_strdup(const vm_char *str);
+ void print_string(const char *str);
+ void nl();
+ void print_cell(cell x);
+ void print_cell_hex(cell x);
+ void print_cell_hex_pad(cell x);
+ void print_fixnum(fixnum x);
+ cell read_cell_hex();
}
--- /dev/null
+namespace factor
+{
+
+struct factorvmdata {
+ // if you change this struct, also change vm.factor k--------
+ context *stack_chain;
+ zone nursery; /* new objects are allocated here */
+ cell cards_offset;
+ cell decks_offset;
+ cell userenv[USER_ENV]; /* TAGGED user environment data; see getenv/setenv prims */
+
+ // -------------------------------
+
+ // contexts
+ cell ds_size, rs_size;
+ context *unused_contexts;
+
+ // run
+ cell T; /* Canonical T object. It's just a word */
+
+ // profiler
+ bool profiling_p;
+
+ // errors
+ /* Global variables used to pass fault handler state from signal handler to
+ user-space */
+ cell signal_number;
+ cell signal_fault_addr;
+ unsigned int signal_fpu_status;
+ stack_frame *signal_callstack_top;
+
+ //data_heap
+ bool secure_gc; /* Set by the -securegc command line argument */
+ bool gc_off; /* GC is off during heap walking */
+ data_heap *data;
+ /* A heap walk allows useful things to be done, like finding all
+ references to an object for debugging purposes. */
+ cell heap_scan_ptr;
+ //write barrier
+ cell allot_markers_offset;
+ //data_gc
+ /* used during garbage collection only */
+ zone *newspace;
+ bool performing_gc;
+ bool performing_compaction;
+ cell collecting_gen;
+ /* if true, we are collecting aging space for the second time, so if it is still
+ full, we go on to collect tenured */
+ bool collecting_aging_again;
+ /* in case a generation fills up in the middle of a gc, we jump back
+ up to try collecting the next generation. */
+ jmp_buf gc_jmp;
+ gc_stats stats[max_gen_count];
+ u64 cards_scanned;
+ u64 decks_scanned;
+ u64 card_scan_time;
+ cell code_heap_scans;
+ /* What generation was being collected when copy_code_heap_roots() was last
+ called? Until the next call to add_code_block(), future
+ collections of younger generations don't have to touch the code
+ heap. */
+ cell last_code_heap_scan;
+ /* sometimes we grow the heap */
+ bool growing_data_heap;
+ data_heap *old_data_heap;
+
+ // local roots
+ /* If a runtime function needs to call another function which potentially
+ allocates memory, it must wrap any local variable references to Factor
+ objects in gc_root instances */
+ std::vector<cell> gc_locals;
+ std::vector<cell> gc_bignums;
+
+ //debug
+ bool fep_disabled;
+ bool full_output;
+ cell look_for;
+ cell obj;
+
+ //math
+ cell bignum_zero;
+ cell bignum_pos_one;
+ cell bignum_neg_one;
+
+ //code_heap
+ heap code;
+ unordered_map<heap_block *,char *> forwarding;
+
+ //image
+ cell code_relocation_base;
+ cell data_relocation_base;
+
+ //dispatch
+ cell megamorphic_cache_hits;
+ cell megamorphic_cache_misses;
+
+ //inline cache
+ cell max_pic_size;
+ cell cold_call_to_ic_transitions;
+ cell ic_to_pic_transitions;
+ cell pic_to_mega_transitions;
+ cell pic_counts[4]; /* PIC_TAG, PIC_HI_TAG, PIC_TUPLE, PIC_HI_TAG_TUPLE */
+
+ factorvmdata()
+ : profiling_p(false),
+ secure_gc(false),
+ gc_off(false),
+ performing_gc(false),
+ performing_compaction(false),
+ collecting_aging_again(false),
+ growing_data_heap(false),
+ fep_disabled(false),
+ full_output(false),
+ max_pic_size(0)
+ {
+ memset(this,0,sizeof(this)); // just to make sure
+ }
+
+};
+
+}
--- /dev/null
+#include "vm-data.hpp"
+
+namespace factor
+{
+
+struct factorvm : factorvmdata {
+
+ // segments
+ inline cell align_page(cell a);
+
+ // contexts
+ void reset_datastack();
+ void reset_retainstack();
+ void fix_stacks();
+ void save_stacks();
+ context *alloc_context();
+ void dealloc_context(context *old_context);
+ void nest_stacks();
+ void unnest_stacks();
+ void init_stacks(cell ds_size_, cell rs_size_);
+ bool stack_to_array(cell bottom, cell top);
+ cell array_to_stack(array *array, cell bottom);
+ inline void vmprim_datastack();
+ inline void vmprim_retainstack();
+ inline void vmprim_set_datastack();
+ inline void vmprim_set_retainstack();
+ inline void vmprim_check_datastack();
+
+ // run
+ inline void vmprim_getenv();
+ inline void vmprim_setenv();
+ inline void vmprim_exit();
+ inline void vmprim_micros();
+ inline void vmprim_sleep();
+ inline void vmprim_set_slot();
+ inline void vmprim_load_locals();
+ cell clone_object(cell obj_);
+ inline void vmprim_clone();
+
+ // profiler
+ void init_profiler();
+ code_block *compile_profiling_stub(cell word_);
+ void set_profiling(bool profiling);
+ inline void vmprim_profiling();
+
+ // errors
+ void out_of_memory();
+ void critical_error(const char* msg, cell tagged);
+ void throw_error(cell error, stack_frame *callstack_top);
+ void not_implemented_error();
+ bool in_page(cell fault, cell area, cell area_size, int offset);
+ void memory_protection_error(cell addr, stack_frame *native_stack);
+ void signal_error(int signal, stack_frame *native_stack);
+ void divide_by_zero_error();
+ void fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top);
+ inline void vmprim_call_clear();
+ inline void vmprim_unimplemented();
+ void memory_signal_handler_impl();
+ void misc_signal_handler_impl();
+ void fp_signal_handler_impl();
+ void type_error(cell type, cell tagged);
+ void general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *native_stack);
+
+ //callstack
+
+ // bignum
+ int bignum_equal_p(bignum * x, bignum * y);
+ enum bignum_comparison bignum_compare(bignum * x, bignum * y);
+ bignum *bignum_add(bignum * x, bignum * y);
+ bignum *bignum_subtract(bignum * x, bignum * y);
+ bignum *bignum_multiply(bignum * x, bignum * y);
+ void bignum_divide(bignum * numerator, bignum * denominator, bignum * * quotient, bignum * * remainder);
+ bignum *bignum_quotient(bignum * numerator, bignum * denominator);
+ bignum *bignum_remainder(bignum * numerator, bignum * denominator);
+ cell bignum_to_cell(bignum * bignum);
+ fixnum bignum_to_fixnum(bignum * bignum);
+ s64 bignum_to_long_long(bignum * bignum);
+ u64 bignum_to_ulong_long(bignum * bignum);
+ double bignum_to_double(bignum * bignum);
+ bignum *double_to_bignum(double x);
+ int bignum_equal_p_unsigned(bignum * x, bignum * y);
+ enum bignum_comparison bignum_compare_unsigned(bignum * x, bignum * y);
+ bignum *bignum_add_unsigned(bignum * x, bignum * y, int negative_p);
+ bignum *bignum_subtract_unsigned(bignum * x, bignum * y);
+ bignum *bignum_multiply_unsigned(bignum * x, bignum * y, int negative_p);
+ bignum *bignum_multiply_unsigned_small_factor(bignum * x, bignum_digit_type y,int negative_p);
+ void bignum_destructive_add(bignum * bignum, bignum_digit_type n);
+ void bignum_destructive_scale_up(bignum * bignum, bignum_digit_type factor);
+ void bignum_divide_unsigned_large_denominator(bignum * numerator, bignum * denominator,
+ bignum * * quotient, bignum * * remainder, int q_negative_p, int r_negative_p);
+ void bignum_divide_unsigned_normalized(bignum * u, bignum * v, bignum * q);
+ bignum_digit_type bignum_divide_subtract(bignum_digit_type * v_start, bignum_digit_type * v_end,
+ bignum_digit_type guess, bignum_digit_type * u_start);
+ void bignum_divide_unsigned_medium_denominator(bignum * numerator,bignum_digit_type denominator,
+ bignum * * quotient, bignum * * remainder,int q_negative_p, int r_negative_p);
+ void bignum_destructive_normalization(bignum * source, bignum * target, int shift_left);
+ void bignum_destructive_unnormalization(bignum * bignum, int shift_right);
+ bignum_digit_type bignum_digit_divide(bignum_digit_type uh, bignum_digit_type ul,
+ bignum_digit_type v, bignum_digit_type * q) /* return value */;
+ bignum_digit_type bignum_digit_divide_subtract(bignum_digit_type v1, bignum_digit_type v2,
+ bignum_digit_type guess, bignum_digit_type * u);
+ void bignum_divide_unsigned_small_denominator(bignum * numerator, bignum_digit_type denominator,
+ bignum * * quotient, bignum * * remainder,int q_negative_p, int r_negative_p);
+ bignum_digit_type bignum_destructive_scale_down(bignum * bignum, bignum_digit_type denominator);
+ bignum * bignum_remainder_unsigned_small_denominator(bignum * n, bignum_digit_type d, int negative_p);
+ bignum *bignum_digit_to_bignum(bignum_digit_type digit, int negative_p);
+ bignum *allot_bignum(bignum_length_type length, int negative_p);
+ bignum * allot_bignum_zeroed(bignum_length_type length, int negative_p);
+ bignum *bignum_shorten_length(bignum * bignum, bignum_length_type length);
+ bignum *bignum_trim(bignum * bignum);
+ bignum *bignum_new_sign(bignum * x, int negative_p);
+ bignum *bignum_maybe_new_sign(bignum * x, int negative_p);
+ void bignum_destructive_copy(bignum * source, bignum * target);
+ bignum *bignum_bitwise_not(bignum * x);
+ bignum *bignum_arithmetic_shift(bignum * arg1, fixnum n);
+ bignum *bignum_bitwise_and(bignum * arg1, bignum * arg2);
+ bignum *bignum_bitwise_ior(bignum * arg1, bignum * arg2);
+ bignum *bignum_bitwise_xor(bignum * arg1, bignum * arg2);
+ bignum *bignum_magnitude_ash(bignum * arg1, fixnum n);
+ bignum *bignum_pospos_bitwise_op(int op, bignum * arg1, bignum * arg2);
+ bignum *bignum_posneg_bitwise_op(int op, bignum * arg1, bignum * arg2);
+ bignum *bignum_negneg_bitwise_op(int op, bignum * arg1, bignum * arg2);
+ void bignum_negate_magnitude(bignum * arg);
+ bignum *bignum_integer_length(bignum * x);
+ int bignum_logbitp(int shift, bignum * arg);
+ int bignum_unsigned_logbitp(int shift, bignum * bignum);
+ bignum *digit_stream_to_bignum(unsigned int n_digits, unsigned int (*producer)(unsigned int, factorvm *), 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);
+ void reset_generation(cell i);
+ void reset_generations(cell from, cell to);
+ void set_data_heap(data_heap *data_);
+ void init_data_heap(cell gens,cell young_size,cell aging_size,cell tenured_size,bool secure_gc_);
+ cell untagged_object_size(object *pointer);
+ cell unaligned_object_size(object *pointer);
+ inline void vmprim_size();
+ cell binary_payload_start(object *pointer);
+ inline void vmprim_data_room();
+ void begin_scan();
+ void end_scan();
+ inline void vmprim_begin_scan();
+ cell next_object();
+ inline void vmprim_next_object();
+ inline void vmprim_end_scan();
+ template<typename T> void each_object(T &functor);
+ cell find_all_words();
+ cell object_size(cell tagged);
+
+
+ //write barrier
+ inline card *addr_to_card(cell a);
+ inline cell card_to_addr(card *c);
+ inline cell card_offset(card *c);
+ inline card_deck *addr_to_deck(cell a);
+ inline cell deck_to_addr(card_deck *c);
+ inline card *deck_to_card(card_deck *d);
+ inline card *addr_to_allot_marker(object *a);
+ inline void write_barrier(object *obj);
+ inline void allot_barrier(object *address);
+
+
+ //data_gc
+ void init_data_gc();
+ object *copy_untagged_object_impl(object *pointer, cell size);
+ object *copy_object_impl(object *untagged);
+ bool should_copy_p(object *untagged);
+ object *resolve_forwarding(object *untagged);
+ template <typename T> T *copy_untagged_object(T *untagged);
+ cell copy_object(cell pointer);
+ void copy_handle(cell *handle);
+ void copy_card(card *ptr, cell gen, cell here);
+ void copy_card_deck(card_deck *deck, cell gen, card mask, card unmask);
+ void copy_gen_cards(cell gen);
+ void copy_cards();
+ void copy_stack_elements(segment *region, cell top);
+ void copy_registered_locals();
+ void copy_registered_bignums();
+ void copy_roots();
+ cell copy_next_from_nursery(cell scan);
+ cell copy_next_from_aging(cell scan);
+ cell copy_next_from_tenured(cell scan);
+ void copy_reachable_objects(cell scan, cell *end);
+ void begin_gc(cell requested_bytes);
+ void end_gc(cell gc_elapsed);
+ void garbage_collection(cell gen,bool growing_data_heap_,cell requested_bytes);
+ void gc();
+ inline void vmprim_gc();
+ inline void vmprim_gc_stats();
+ void clear_gc_stats();
+ inline void vmprim_become();
+ void inline_gc(cell *gc_roots_base, cell gc_roots_size);
+ inline bool collecting_accumulation_gen_p();
+ inline object *allot_zone(zone *z, cell a);
+ inline object *allot_object(header header, cell size);
+ template <typename TYPE> TYPE *allot(cell size);
+ inline void check_data_pointer(object *pointer);
+ inline void check_tagged_pointer(cell tagged);
+ inline void vmprim_clear_gc_stats();
+
+ // generic arrays
+ template <typename T> T *allot_array_internal(cell capacity);
+ template <typename T> bool reallot_array_in_place_p(T *array, cell capacity);
+ template <typename TYPE> TYPE *reallot_array(TYPE *array_, cell capacity);
+
+ //debug
+ void print_chars(string* str);
+ void print_word(word* word, cell nesting);
+ void print_factor_string(string* str);
+ void print_array(array* array, cell nesting);
+ void print_tuple(tuple *tuple, cell nesting);
+ void print_nested_obj(cell obj, fixnum nesting);
+ void print_obj(cell obj);
+ void print_objects(cell *start, cell *end);
+ void print_datastack();
+ void print_retainstack();
+ void print_stack_frame(stack_frame *frame);
+ void print_callstack();
+ void dump_cell(cell x);
+ void dump_memory(cell from, cell to);
+ void dump_zone(zone *z);
+ void dump_generations();
+ void dump_objects(cell type);
+ void find_data_references_step(cell *scan);
+ void find_data_references(cell look_for_);
+ void dump_code_heap();
+ void factorbug();
+ inline void vmprim_die();
+
+ //arrays
+ array *allot_array(cell capacity, cell fill_);
+ inline void vmprim_array();
+ cell allot_array_1(cell obj_);
+ cell allot_array_2(cell v1_, cell v2_);
+ cell allot_array_4(cell v1_, cell v2_, cell v3_, cell v4_);
+ inline void vmprim_resize_array();
+ inline void set_array_nth(array *array, cell slot, cell value);
+
+ //strings
+ cell string_nth(string* str, cell index);
+ void set_string_nth_fast(string *str, cell index, cell ch);
+ void set_string_nth_slow(string *str_, cell index, cell ch);
+ void set_string_nth(string *str, cell index, cell ch);
+ string *allot_string_internal(cell capacity);
+ void fill_string(string *str_, cell start, cell capacity, cell fill);
+ string *allot_string(cell capacity, cell fill);
+ inline void vmprim_string();
+ bool reallot_string_in_place_p(string *str, cell capacity);
+ string* reallot_string(string *str_, cell capacity);
+ inline void vmprim_resize_string();
+ inline void vmprim_string_nth();
+ inline void vmprim_set_string_nth_fast();
+ inline void vmprim_set_string_nth_slow();
+
+ //booleans
+ void box_boolean(bool value);
+ bool to_boolean(cell value);
+ inline cell tag_boolean(cell untagged);
+
+ //byte arrays
+ byte_array *allot_byte_array(cell size);
+ inline void vmprim_byte_array();
+ inline void vmprim_uninitialized_byte_array();
+ inline void vmprim_resize_byte_array();
+
+ //tuples
+ tuple *allot_tuple(cell layout_);
+ inline void vmprim_tuple();
+ inline void vmprim_tuple_boa();
+
+ //words
+ word *allot_word(cell vocab_, cell name_);
+ inline void vmprim_word();
+ inline void vmprim_word_xt();
+ void update_word_xt(cell w_);
+ inline void vmprim_optimized_p();
+ inline void vmprim_wrapper();
+
+ //math
+ inline void vmprim_bignum_to_fixnum();
+ inline void vmprim_float_to_fixnum();
+ inline void vmprim_fixnum_divint();
+ inline void vmprim_fixnum_divmod();
+ bignum *fixnum_to_bignum(fixnum);
+ bignum *cell_to_bignum(cell);
+ bignum *long_long_to_bignum(s64 n);
+ bignum *ulong_long_to_bignum(u64 n);
+ inline fixnum sign_mask(fixnum x);
+ inline fixnum branchless_max(fixnum x, fixnum y);
+ inline fixnum branchless_abs(fixnum x);
+ inline void vmprim_fixnum_shift();
+ inline void vmprim_fixnum_to_bignum();
+ inline void vmprim_float_to_bignum();
+ inline void vmprim_bignum_eq();
+ inline void vmprim_bignum_add();
+ inline void vmprim_bignum_subtract();
+ inline void vmprim_bignum_multiply();
+ inline void vmprim_bignum_divint();
+ inline void vmprim_bignum_divmod();
+ inline void vmprim_bignum_mod();
+ inline void vmprim_bignum_and();
+ inline void vmprim_bignum_or();
+ inline void vmprim_bignum_xor();
+ inline void vmprim_bignum_shift();
+ inline void vmprim_bignum_less();
+ inline void vmprim_bignum_lesseq();
+ inline void vmprim_bignum_greater();
+ inline void vmprim_bignum_greatereq();
+ inline void vmprim_bignum_not();
+ inline void vmprim_bignum_bitp();
+ inline void vmprim_bignum_log2();
+ unsigned int bignum_producer(unsigned int digit);
+ inline void vmprim_byte_array_to_bignum();
+ cell unbox_array_size();
+ inline void vmprim_fixnum_to_float();
+ inline void vmprim_bignum_to_float();
+ inline void vmprim_str_to_float();
+ inline void vmprim_float_to_str();
+ inline void vmprim_float_eq();
+ inline void vmprim_float_add();
+ inline void vmprim_float_subtract();
+ inline void vmprim_float_multiply();
+ inline void vmprim_float_divfloat();
+ inline void vmprim_float_mod();
+ inline void vmprim_float_less();
+ inline void vmprim_float_lesseq();
+ inline void vmprim_float_greater();
+ inline void vmprim_float_greatereq();
+ inline void vmprim_float_bits();
+ inline void vmprim_bits_float();
+ inline void vmprim_double_bits();
+ inline void vmprim_bits_double();
+ fixnum to_fixnum(cell tagged);
+ cell to_cell(cell tagged);
+ void box_signed_1(s8 n);
+ void box_unsigned_1(u8 n);
+ void box_signed_2(s16 n);
+ void box_unsigned_2(u16 n);
+ void box_signed_4(s32 n);
+ void box_unsigned_4(u32 n);
+ void box_signed_cell(fixnum integer);
+ void box_unsigned_cell(cell cell);
+ void box_signed_8(s64 n);
+ s64 to_signed_8(cell obj);
+ void box_unsigned_8(u64 n);
+ u64 to_unsigned_8(cell obj);
+ void box_float(float flo);
+ float to_float(cell value);
+ void box_double(double flo);
+ double to_double(cell value);
+ inline void overflow_fixnum_add(fixnum x, fixnum y);
+ inline void overflow_fixnum_subtract(fixnum x, fixnum y);
+ inline void overflow_fixnum_multiply(fixnum x, fixnum y);
+ inline cell allot_integer(fixnum x);
+ inline cell allot_cell(cell x);
+ inline cell allot_float(double n);
+ inline bignum *float_to_bignum(cell tagged);
+ inline double bignum_to_float(cell tagged);
+ inline double untag_float(cell tagged);
+ inline double untag_float_check(cell tagged);
+ inline fixnum float_to_fixnum(cell tagged);
+ inline double fixnum_to_float(cell tagged);
+ template <typename T> T *untag_check(cell value);
+ template <typename T> T *untag(cell value);
+
+ //io
+ void init_c_io();
+ void io_error();
+ inline void vmprim_fopen();
+ inline void vmprim_fgetc();
+ inline void vmprim_fread();
+ inline void vmprim_fputc();
+ inline void vmprim_fwrite();
+ inline void vmprim_fseek();
+ inline void vmprim_fflush();
+ inline void vmprim_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);
+ cell relocation_offset_of(relocation_entry r);
+ void flush_icache_for(code_block *block);
+ int number_of_parameters(relocation_type type);
+ void *object_xt(cell obj);
+ void *xt_pic(word *w, cell tagged_quot);
+ void *word_xt_pic(word *w);
+ void *word_xt_pic_tail(word *w);
+ void undefined_symbol();
+ void *get_rel_symbol(array *literals, cell index);
+ cell compute_relocation(relocation_entry rel, cell index, code_block *compiled);
+ void iterate_relocations(code_block *compiled, relocation_iterator iter);
+ void store_address_2_2(cell *ptr, cell value);
+ void store_address_masked(cell *ptr, fixnum value, cell mask, fixnum shift);
+ void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value);
+ void update_literal_references_step(relocation_entry rel, cell index, code_block *compiled);
+ void update_literal_references(code_block *compiled);
+ void copy_literal_references(code_block *compiled);
+ void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled);
+ void update_word_references_step(relocation_entry rel, cell index, code_block *compiled);
+ void update_word_references(code_block *compiled);
+ void update_literal_and_word_references(code_block *compiled);
+ void check_code_address(cell address);
+ void mark_code_block(code_block *compiled);
+ void mark_stack_frame_step(stack_frame *frame);
+ void mark_active_blocks(context *stacks);
+ void mark_object_code_block(object *object);
+ void relocate_code_block(code_block *compiled);
+ void fixup_labels(array *labels, code_block *compiled);
+ code_block *allot_code_block(cell size);
+ code_block *add_code_block(cell type,cell code_,cell labels_,cell relocation_,cell literals_);
+ inline bool stack_traces_p()
+ {
+ return userenv[STACK_TRACES_ENV] != F;
+ }
+
+ //code_heap
+ void init_code_heap(cell size);
+ bool in_code_heap_p(cell ptr);
+ void jit_compile_word(cell word_, cell def_, bool relocate);
+ void iterate_code_heap(code_heap_iterator iter);
+ void copy_code_heap_roots();
+ void update_code_heap_words();
+ inline void vmprim_modify_code_heap();
+ inline void vmprim_code_room();
+ code_block *forward_xt(code_block *compiled);
+ void forward_frame_xt(stack_frame *frame);
+ void forward_object_xts();
+ void fixup_object_xts();
+ void compact_code_heap();
+ inline void check_code_pointer(cell ptr);
+
+
+ //image
+ void init_objects(image_header *h);
+ void load_data_heap(FILE *file, image_header *h, vm_parameters *p);
+ void load_code_heap(FILE *file, image_header *h, vm_parameters *p);
+ bool save_image(const vm_char *filename);
+ inline void vmprim_save_image();
+ inline void vmprim_save_image_and_exit();
+ void data_fixup(cell *cell);
+ template <typename T> void code_fixup(T **handle);
+ void fixup_word(word *word);
+ void fixup_quotation(quotation *quot);
+ void fixup_alien(alien *d);
+ void fixup_stack_frame(stack_frame *frame);
+ void fixup_callstack_object(callstack *stack);
+ void relocate_object(object *object);
+ void relocate_data();
+ void fixup_code_block(code_block *compiled);
+ void relocate_code();
+ void load_image(vm_parameters *p);
+
+ //callstack
+ template<typename T> void iterate_callstack_object(callstack *stack_, T &iterator);
+ void check_frame(stack_frame *frame);
+ callstack *allot_callstack(cell size);
+ stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom);
+ stack_frame *capture_start();
+ inline void vmprim_callstack();
+ inline void vmprim_set_callstack();
+ code_block *frame_code(stack_frame *frame);
+ cell frame_type(stack_frame *frame);
+ cell frame_executing(stack_frame *frame);
+ stack_frame *frame_successor(stack_frame *frame);
+ cell frame_scan(stack_frame *frame);
+ inline void vmprim_callstack_to_array();
+ stack_frame *innermost_stack_frame(callstack *stack);
+ stack_frame *innermost_stack_frame_quot(callstack *callstack);
+ inline void vmprim_innermost_stack_frame_executing();
+ inline void vmprim_innermost_stack_frame_scan();
+ inline void vmprim_set_innermost_stack_frame_quot();
+ void save_callstack_bottom(stack_frame *callstack_bottom);
+ template<typename T> void iterate_callstack(cell top, cell bottom, T &iterator);
+ inline void do_slots(cell obj, void (* iter)(cell *,factorvm*));
+
+
+ //alien
+ char *pinned_alien_offset(cell obj);
+ cell allot_alien(cell delegate_, cell displacement);
+ inline void vmprim_displaced_alien();
+ inline void vmprim_alien_address();
+ void *alien_pointer();
+ inline void vmprim_dlopen();
+ inline void vmprim_dlsym();
+ inline void vmprim_dlclose();
+ inline void vmprim_dll_validp();
+ inline void vmprim_vm_ptr();
+ char *alien_offset(cell obj);
+ char *unbox_alien();
+ void box_alien(void *ptr);
+ void to_value_struct(cell src, void *dest, cell size);
+ void box_value_struct(void *src, cell size);
+ void box_small_struct(cell x, cell y, cell size);
+ void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size);
+
+ //quotations
+ inline void vmprim_jit_compile();
+ inline void vmprim_array_to_quotation();
+ inline void vmprim_quotation_xt();
+ void set_quot_xt(quotation *quot, code_block *code);
+ void jit_compile(cell quot_, bool relocating);
+ void compile_all_words();
+ fixnum quot_code_offset_to_scan(cell quot_, cell offset);
+ cell lazy_jit_compile_impl(cell quot_, stack_frame *stack);
+ inline void vmprim_quot_compiled_p();
+
+ //dispatch
+ cell search_lookup_alist(cell table, cell klass);
+ cell search_lookup_hash(cell table, cell klass, cell hashcode);
+ cell nth_superclass(tuple_layout *layout, fixnum echelon);
+ cell nth_hashcode(tuple_layout *layout, fixnum echelon);
+ cell lookup_tuple_method(cell obj, cell methods);
+ cell lookup_hi_tag_method(cell obj, cell methods);
+ cell lookup_hairy_method(cell obj, cell methods);
+ cell lookup_method(cell obj, cell methods);
+ inline void vmprim_lookup_method();
+ cell object_class(cell obj);
+ cell method_cache_hashcode(cell klass, array *array);
+ void update_method_cache(cell cache, cell klass, cell method);
+ inline void vmprim_mega_cache_miss();
+ inline void vmprim_reset_dispatch_stats();
+ inline void vmprim_dispatch_stats();
+
+ //inline cache
+ void init_inline_caching(int max_size);
+ void deallocate_inline_cache(cell return_address);
+ cell determine_inline_cache_type(array *cache_entries);
+ void update_pic_count(cell type);
+ code_block *compile_inline_cache(fixnum index,cell generic_word_,cell methods_,cell cache_entries_,bool tail_call_p);
+ void *megamorphic_call_stub(cell generic_word);
+ cell inline_cache_size(cell cache_entries);
+ cell add_inline_cache_entry(cell cache_entries_, cell klass_, cell method_);
+ void update_pic_transitions(cell pic_size);
+ void *inline_cache_miss(cell return_address);
+ inline void vmprim_reset_inline_cache_stats();
+ inline void vmprim_inline_cache_stats();
+
+ //factor
+ void default_parameters(vm_parameters *p);
+ bool factor_arg(const vm_char* str, const vm_char* arg, cell* value);
+ void init_parameters_from_args(vm_parameters *p, int argc, vm_char **argv);
+ void do_stage1_init();
+ void init_factor(vm_parameters *p);
+ void pass_args_to_factor(int argc, vm_char **argv);
+ void start_factor(vm_parameters *p);
+ void start_embedded_factor(vm_parameters *p);
+ void start_standalone_factor(int argc, vm_char **argv);
+ char *factor_eval_string(char *string);
+ void factor_eval_free(char *result);
+ void factor_yield();
+ void factor_sleep(long us);
+
+ // os-*
+ inline void vmprim_existsp();
+ void init_ffi();
+ 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);
+ bool windows_stat(vm_char *path);
+
+ #if defined(WINNT)
+ void open_console();
+ LONG exception_handler(PEXCEPTION_POINTERS pe);
+ // next method here:
+ #endif
+ #else // UNIX
+ void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap);
+ void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap);
+ void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap);
+ stack_frame *uap_stack_pointer(void *uap);
+
+ #endif
+
+ #ifdef __APPLE__
+ void call_fault_handler(exception_type_t exception, exception_data_type_t code, MACH_EXC_STATE_TYPE *exc_state, MACH_THREAD_STATE_TYPE *thread_state, MACH_FLOAT_STATE_TYPE *float_state);
+ #endif
+
+ void print_vm_data();
+};
+
+
+#ifndef FACTOR_REENTRANT
+ #define FACTOR_SINGLE_THREADED_SINGLETON
+#endif
+
+#ifdef FACTOR_SINGLE_THREADED_SINGLETON
+/* calls are dispatched using the singleton vm ptr */
+ extern factorvm *vm;
+ #define PRIMITIVE_GETVM() vm
+ #define PRIMITIVE_OVERFLOW_GETVM() vm
+ #define VM_PTR vm
+ #define ASSERTVM()
+ #define SIGNAL_VM_PTR() vm
+#endif
+
+#ifdef FACTOR_SINGLE_THREADED_TESTING
+/* calls are dispatched as per multithreaded, but checked against singleton */
+ extern factorvm *vm;
+ #define ASSERTVM() assert(vm==myvm)
+ #define PRIMITIVE_GETVM() ((factorvm*)myvm)
+ #define PRIMITIVE_OVERFLOW_GETVM() ASSERTVM(); myvm
+ #define VM_PTR myvm
+ #define SIGNAL_VM_PTR() tls_vm()
+#endif
+
+#ifdef FACTOR_REENTRANT_TLS
+/* uses thread local storage to obtain vm ptr */
+ #define PRIMITIVE_GETVM() tls_vm()
+ #define PRIMITIVE_OVERFLOW_GETVM() tls_vm()
+ #define VM_PTR tls_vm()
+ #define ASSERTVM()
+ #define SIGNAL_VM_PTR() tls_vm()
+#endif
+
+#ifdef FACTOR_REENTRANT
+ #define PRIMITIVE_GETVM() ((factorvm*)myvm)
+ #define PRIMITIVE_OVERFLOW_GETVM() ((factorvm*)myvm)
+ #define VM_PTR myvm
+ #define ASSERTVM()
+ #define SIGNAL_VM_PTR() tls_vm()
+#endif
+
+}
namespace factor
{
-word *allot_word(cell vocab_, cell name_)
+word *factorvm::allot_word(cell vocab_, cell name_)
{
- gc_root<object> vocab(vocab_);
- gc_root<object> name(name_);
+ gc_root<object> vocab(vocab_,this);
+ gc_root<object> name(name_,this);
- gc_root<word> new_word(allot<word>(sizeof(word)));
+ gc_root<word> new_word(allot<word>(sizeof(word)),this);
new_word->hashcode = tag_fixnum((rand() << 16) ^ rand());
new_word->vocabulary = vocab.value();
}
/* <word> ( name vocabulary -- word ) */
-PRIMITIVE(word)
+inline void factorvm::vmprim_word()
{
cell vocab = dpop();
cell name = dpop();
dpush(tag<word>(allot_word(vocab,name)));
}
+PRIMITIVE(word)
+{
+ PRIMITIVE_GETVM()->vmprim_word();
+}
+
/* word-xt ( word -- start end ) */
-PRIMITIVE(word_xt)
+inline void factorvm::vmprim_word_xt()
{
word *w = untag_check<word>(dpop());
code_block *code = (profiling_p ? w->profiling : w->code);
dpush(allot_cell((cell)code + code->size));
}
+PRIMITIVE(word_xt)
+{
+ PRIMITIVE_GETVM()->vmprim_word_xt();
+}
+
/* Allocates memory */
-void update_word_xt(cell w_)
+void factorvm::update_word_xt(cell w_)
{
- gc_root<word> w(w_);
+ gc_root<word> w(w_,this);
if(profiling_p)
{
w->xt = w->code->xt();
}
-PRIMITIVE(optimized_p)
+inline void factorvm::vmprim_optimized_p()
{
drepl(tag_boolean(word_optimized_p(untag_check<word>(dpeek()))));
}
-PRIMITIVE(wrapper)
+PRIMITIVE(optimized_p)
+{
+ PRIMITIVE_GETVM()->vmprim_optimized_p();
+}
+
+inline void factorvm::vmprim_wrapper()
{
wrapper *new_wrapper = allot<wrapper>(sizeof(wrapper));
new_wrapper->object = dpeek();
drepl(tag<wrapper>(new_wrapper));
}
+PRIMITIVE(wrapper)
+{
+ PRIMITIVE_GETVM()->vmprim_wrapper();
+}
+
}
namespace factor
{
-word *allot_word(cell vocab, cell name);
-
PRIMITIVE(word);
PRIMITIVE(word_xt);
-void update_word_xt(cell word);
inline bool word_optimized_p(word *word)
{
}
PRIMITIVE(optimized_p);
-
PRIMITIVE(wrapper);
}
using namespace factor;
-cell cards_offset;
-cell decks_offset;
-namespace factor
-{
- cell allot_markers_offset;
-}
the offset of the first object is set by the allocator. */
-VM_C_API factor::cell cards_offset;
-VM_C_API factor::cell decks_offset;
-
namespace factor
{
static const cell card_size = (1<<card_bits);
static const cell addr_card_mask = (card_size-1);
-inline static card *addr_to_card(cell a)
-{
- return (card*)(((cell)(a) >> card_bits) + cards_offset);
-}
-
-inline static cell card_to_addr(card *c)
-{
- return ((cell)c - cards_offset) << card_bits;
-}
-
-inline static cell card_offset(card *c)
-{
- return *(c - (cell)data->cards + (cell)data->allot_markers);
-}
typedef u8 card_deck;
static const cell deck_bits = (card_bits + 10);
static const cell deck_size = (1<<deck_bits);
static const cell addr_deck_mask = (deck_size-1);
-
-inline static card_deck *addr_to_deck(cell a)
-{
- return (card_deck *)(((cell)a >> deck_bits) + decks_offset);
-}
-
-inline static cell deck_to_addr(card_deck *c)
-{
- return ((cell)c - decks_offset) << deck_bits;
-}
-
-inline static card *deck_to_card(card_deck *d)
-{
- return (card *)((((cell)d - decks_offset) << (deck_bits - card_bits)) + cards_offset);
-}
-
static const cell invalid_allot_marker = 0xff;
-extern cell allot_markers_offset;
-
-inline static card *addr_to_allot_marker(object *a)
-{
- return (card *)(((cell)a >> card_bits) + allot_markers_offset);
-}
-
-/* the write barrier must be called any time we are potentially storing a
-pointer from an older generation to a younger one */
-inline static void write_barrier(object *obj)
-{
- *addr_to_card((cell)obj) = card_mark_mask;
- *addr_to_deck((cell)obj) = card_mark_mask;
-}
-
-/* we need to remember the first object allocated in the card */
-inline static void allot_barrier(object *address)
-{
- card *ptr = addr_to_allot_marker(address);
- if(*ptr == invalid_allot_marker)
- *ptr = ((cell)address & addr_card_mask);
-}
-
}
projects / factor.git / commitdiff