From: Slava Pestov Date: Sun, 20 Sep 2009 08:48:08 +0000 (-0500) Subject: Merge Phil Dawes' VM work X-Git-Tag: 0.97~5502^2~2 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=f8a91438cd5a18e209f8b2bc12ce8da817f3110f;hp=0968938917a719ef6a3f04e5eaac67849c54ef3e Merge Phil Dawes' VM work --- diff --git a/Makefile b/Makefile index 18cb7d15c7..10efe34d34 100755 --- a/Makefile +++ b/Makefile @@ -18,6 +18,10 @@ else CFLAGS += -O3 endif +ifdef REENTRANT + CFLAGS += -DFACTOR_REENTRANT +endif + CFLAGS += $(SITE_CFLAGS) ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION) @@ -164,17 +168,17 @@ macosx.app: factor 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 @@ -187,22 +191,22 @@ tags: 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 diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index fcfc89ea52..cb8b2de543 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -190,12 +190,14 @@ M: ##slot-imm insn-slot# slot>> ; 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 diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index 469ba37703..1b99b5d4dd 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -57,4 +57,4 @@ insn-classes get [ : ^^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 diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 32e5d46c61..7c28198f67 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -450,6 +450,10 @@ INSN: ##alien-global 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 ; diff --git a/basis/compiler/cfg/intrinsics/misc/misc.factor b/basis/compiler/cfg/intrinsics/misc/misc.factor index f9f2182a4e..f9f3488773 100644 --- a/basis/compiler/cfg/intrinsics/misc/misc.factor +++ b/basis/compiler/cfg/intrinsics/misc/misc.factor @@ -10,7 +10,7 @@ IN: compiler.cfg.intrinsics.misc 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 ; diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index ddf5aa0e02..e1551f54c0 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -270,6 +270,9 @@ M: ##alien-global generate-insn [ 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 -- ) @@ -434,7 +437,7 @@ M: ##alien-indirect generate-insn ! 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 ; @@ -472,7 +475,7 @@ TUPLE: callback-context ; [ 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. diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index b795862970..cc6003b89c 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -50,6 +50,7 @@ CONSTANT: rt-immediate 8 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? ; diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index d6611c3384..fbec9f697a 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -202,6 +202,7 @@ HOOK: %set-alien-double cpu ( ptr value -- ) 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 -- ) @@ -297,6 +298,9 @@ M: object %prepare-var-args ; HOOK: %alien-invoke cpu ( function library -- ) +HOOK: %vm-invoke-1st-arg cpu ( function -- ) +HOOK: %vm-invoke-3rd-arg cpu ( function -- ) + HOOK: %cleanup cpu ( params -- ) M: object %cleanup ( params -- ) drop ; diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 72ad543307..2a16a8b6df 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -7,7 +7,7 @@ cpu.ppc.assembler cpu.ppc.assembler.backend compiler.cfg.registers 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 @@ -30,6 +30,18 @@ enable-float-intrinsics \ ##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 ] } @@ -419,7 +431,7 @@ M: ppc %set-alien-float swap 0 STFS ; 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 ; @@ -442,10 +454,10 @@ M:: ppc %allot ( dst size class nursery-ptr -- ) 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 @@ -683,7 +695,7 @@ M:: ppc %save-context ( temp1 temp2 callback-allowed? -- ) #! 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? [ diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 9939154512..85db5fb09c 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -47,6 +47,18 @@ M: x86.32 reserved-area-size 0 ; M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ; +: push-vm-ptr ( -- ) + temp-reg 0 MOV rc-absolute-cell rt-vm rel-fixup ! push the vm ptr as an argument + temp-reg PUSH ; + +M: x86.32 %vm-invoke-1st-arg ( function -- ) + push-vm-ptr + f %alien-invoke + temp-reg POP ; + +M: x86.32 %vm-invoke-3rd-arg ( function -- ) + %vm-invoke-1st-arg ; ! first 2 args are regs, 3rd is stack so vm-invoke-1st-arg works here + M: x86.32 return-struct-in-registers? ( c-type -- ? ) c-type [ return-in-registers?>> ] @@ -103,9 +115,12 @@ M: x86.32 %save-param-reg 3drop ; #! 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 ; @@ -118,7 +133,8 @@ M:: x86.32 %box ( n rep func -- ) 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 @@ -126,12 +142,13 @@ M: x86.32 %box-long-long ( n func -- ) 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 ; @@ -144,7 +161,8 @@ M: x86.32 %prepare-box-struct ( -- ) 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 @@ -157,7 +175,9 @@ M: x86.32 %prepare-unbox ( -- ) 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 @@ -183,7 +203,8 @@ M: x86.32 %unbox-long-long ( n func -- ) : %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 @@ -192,7 +213,8 @@ M: x86.32 %unbox-long-long ( n func -- ) : %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 @@ -211,12 +233,13 @@ M: x86 %unbox-small-struct ( size -- ) 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 @@ -224,7 +247,8 @@ M:: x86.32 %unbox-large-struct ( n c-type -- ) ] 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 ( -- ) @@ -234,6 +258,7 @@ M: x86.32 %alien-callback ( quot -- ) 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 ; @@ -243,9 +268,11 @@ M: x86.32 %callback-value ( ctype -- ) ! 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 diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 674cc817d7..e2096987da 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -12,6 +12,7 @@ IN: bootstrap.x86 : div-arg ( -- reg ) EAX ; : mod-arg ( -- reg ) EDX ; : arg ( -- reg ) EAX ; +: arg2 ( -- reg ) EDX ; : temp0 ( -- reg ) EAX ; : temp1 ( -- reg ) EDX ; : temp2 ( -- reg ) ECX ; @@ -27,6 +28,8 @@ IN: bootstrap.x86 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 diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index f4018b1508..0528733af1 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -74,9 +74,26 @@ M: x86.64 %prepare-unbox ( -- ) param-reg-1 R14 [] MOV R14 cell SUB ; +M: x86.64 %vm-invoke-1st-arg ( function -- ) + param-reg-1 0 MOV rc-absolute-cell rt-vm rel-fixup + f %alien-invoke ; + +: %vm-invoke-2nd-arg ( function -- ) + param-reg-2 0 MOV rc-absolute-cell rt-vm rel-fixup + f %alien-invoke ; + +M: x86.64 %vm-invoke-3rd-arg ( function -- ) + param-reg-3 0 MOV rc-absolute-cell rt-vm rel-fixup + f %alien-invoke ; + +: %vm-invoke-4th-arg ( function -- ) + int-regs param-regs fourth 0 MOV rc-absolute-cell rt-vm rel-fixup + f %alien-invoke ; + + 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 @@ -92,9 +109,10 @@ M: x86.64 %unbox-long-long ( n func -- ) { float-regs [ float-regs get pop swap MOVSD ] } } case ; + M: x86.64 %unbox-small-struct ( c-type -- ) ! Alien must be in param-reg-1. - "alien_offset" 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 @@ -109,7 +127,7 @@ M:: x86.64 %unbox-large-struct ( n c-type -- ) ! 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 ] @@ -117,6 +135,8 @@ M:: x86.64 %unbox-large-struct ( n c-type -- ) [ ] tri copy-register ; + + M:: x86.64 %box ( n rep func -- ) n [ n @@ -125,7 +145,7 @@ M:: x86.64 %box ( n rep func -- ) ] [ 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 ; @@ -145,7 +165,7 @@ M: x86.64 %box-small-struct ( c-type -- ) [ param-reg-3 swap heap-size MOV ] bi param-reg-1 0 box-struct-field@ MOV param-reg-2 1 box-struct-field@ MOV - "box_small_struct" f %alien-invoke + "box_small_struct" %vm-invoke-4th-arg ] with-return-regs ; : struct-return@ ( n -- operand ) @@ -157,7 +177,7 @@ M: x86.64 %box-large-struct ( n c-type -- ) ! 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 @@ -172,8 +192,9 @@ M: x86.64 %alien-invoke 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 ( -- ) @@ -181,7 +202,7 @@ 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 @@ -190,7 +211,7 @@ M: x86.64 %callback-value ( ctype -- ) 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 diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index 8b0d53cda5..aa7a5dcd67 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -21,6 +21,7 @@ IN: bootstrap.x86 : rex-length ( -- n ) 1 ; [ + ! load stack_chain temp0 0 MOV rc-absolute-cell rt-stack-chain jit-rel temp0 temp0 [] MOV @@ -28,6 +29,8 @@ IN: bootstrap.x86 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 diff --git a/basis/cpu/x86/64/unix/bootstrap.factor b/basis/cpu/x86/64/unix/bootstrap.factor index b6d56840e2..199fe8daf4 100644 --- a/basis/cpu/x86/64/unix/bootstrap.factor +++ b/basis/cpu/x86/64/unix/bootstrap.factor @@ -6,6 +6,7 @@ IN: bootstrap.x86 : stack-frame-size ( -- n ) 4 bootstrap-cells ; : arg ( -- reg ) RDI ; +: arg2 ( -- reg ) RSI ; << "vocab:cpu/x86/64/bootstrap.factor" parse-file parsed >> call diff --git a/basis/cpu/x86/64/winnt/bootstrap.factor b/basis/cpu/x86/64/winnt/bootstrap.factor index 0228082956..72b9d27ca4 100644 --- a/basis/cpu/x86/64/winnt/bootstrap.factor +++ b/basis/cpu/x86/64/winnt/bootstrap.factor @@ -7,6 +7,7 @@ IN: bootstrap.x86 : stack-frame-size ( -- n ) 8 bootstrap-cells ; : arg ( -- reg ) RCX ; +: arg2 ( -- reg ) RDX ; << "vocab:cpu/x86/64/bootstrap.factor" parse-file parsed >> call diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 0dafc3d9c4..5bc5272ab4 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -251,6 +251,8 @@ big-endian off 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 diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 04b5308836..97bd2f78de 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -4,13 +4,12 @@ USING: accessors assocs alien alien.c-types arrays strings 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 @@ -556,9 +555,13 @@ M: x86 %shl [ SHL ] emit-shift ; 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 ; @@ -578,18 +581,19 @@ M:: x86 %allot ( dst size class nursery-ptr -- ) 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 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 MOV ; @@ -611,10 +615,10 @@ M:: x86 %call-gc ( gc-root-count -- ) ! 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 ; @@ -743,8 +747,8 @@ M:: x86 %save-context ( temp1 temp2 callback-allowed? -- ) #! 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? [ diff --git a/basis/vm/authors.txt b/basis/vm/authors.txt new file mode 100644 index 0000000000..b125620d17 --- /dev/null +++ b/basis/vm/authors.txt @@ -0,0 +1 @@ +Phil Dawes \ No newline at end of file diff --git a/basis/vm/summary.txt b/basis/vm/summary.txt new file mode 100644 index 0000000000..bfa1067bc7 --- /dev/null +++ b/basis/vm/summary.txt @@ -0,0 +1 @@ +Layout of the C vm structure diff --git a/basis/vm/vm.factor b/basis/vm/vm.factor new file mode 100644 index 0000000000..ab5a98ab3c --- /dev/null +++ b/basis/vm/vm.factor @@ -0,0 +1,23 @@ +! 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 diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 355fa8ed58..fc071cc566 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -103,6 +103,7 @@ bootstrapping? on "words" "vectors" "vectors.private" + "vm" } [ create-vocab drop ] each ! Builtin classes @@ -518,6 +519,7 @@ tuple { "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 diff --git a/extra/mttest/mttest.factor b/extra/mttest/mttest.factor new file mode 100644 index 0000000000..90a398c59a --- /dev/null +++ b/extra/mttest/mttest.factor @@ -0,0 +1,25 @@ +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 diff --git a/vm/alien.cpp b/vm/alien.cpp old mode 100644 new mode 100755 index 13764a8e50..ea8d0a6026 --- a/vm/alien.cpp +++ b/vm/alien.cpp @@ -5,7 +5,7 @@ namespace factor /* 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(obj).type()) { @@ -25,10 +25,10 @@ char *pinned_alien_offset(cell obj) } /* make an alien */ -cell allot_alien(cell delegate_, cell displacement) +cell factorvm::allot_alien(cell delegate_, cell displacement) { - gc_root delegate(delegate_); - gc_root new_alien(allot(sizeof(alien))); + gc_root delegate(delegate_,this); + gc_root new_alien(allot(sizeof(alien)),this); if(delegate.type_p(ALIEN_TYPE)) { @@ -46,7 +46,7 @@ cell allot_alien(cell delegate_, cell displacement) } /* 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()); @@ -69,15 +69,25 @@ PRIMITIVE(displaced_alien) } } +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; @@ -87,12 +97,12 @@ static void *alien_pointer() #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; \ } @@ -111,22 +121,27 @@ DEFINE_ALIEN_ACCESSOR(double,double,box_double,to_double) 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 path(dpop()); - path.untag_check(); - gc_root library(allot(sizeof(dll))); + gc_root path(dpop(),this); + path.untag_check(this); + gc_root library(allot(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 library(dpop()); - gc_root name(dpop()); - name.untag_check(); + gc_root library(dpop(),this); + gc_root name(dpop(),this); + name.untag_check(this); symbol_char *sym = name->data(); @@ -143,15 +158,25 @@ PRIMITIVE(dlsym) } } +PRIMITIVE(dlsym) +{ + PRIMITIVE_GETVM()->vmprim_dlsym(); +} + /* close a native library handle */ -PRIMITIVE(dlclose) +inline void factorvm::vmprim_dlclose() { dll *d = untag_check(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) @@ -160,8 +185,13 @@ PRIMITIVE(dll_validp) dpush(untag_check(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(obj).type()) { @@ -182,14 +212,26 @@ VM_C_API char *alien_offset(cell obj) } } +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); @@ -197,22 +239,40 @@ VM_C_API void box_alien(void *ptr) 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(),src,size); dpush(tag(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; @@ -220,8 +280,14 @@ VM_C_API void box_small_struct(cell x, cell y, cell size) 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; @@ -231,4 +297,20 @@ VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size) 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(); +} + } diff --git a/vm/alien.hpp b/vm/alien.hpp old mode 100644 new mode 100755 index 6235a2d6c7..ca3601f51e --- a/vm/alien.hpp +++ b/vm/alien.hpp @@ -1,8 +1,6 @@ namespace factor { -cell allot_alien(cell delegate, cell displacement); - PRIMITIVE(displaced_alien); PRIMITIVE(alien_address); @@ -38,12 +36,14 @@ PRIMITIVE(dlsym); 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); } diff --git a/vm/arrays.cpp b/vm/arrays.cpp index f9a3f211d0..3052563dea 100644 --- a/vm/arrays.cpp +++ b/vm/arrays.cpp @@ -4,10 +4,10 @@ namespace factor { /* 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 fill(fill_); - gc_root new_array(allot_array_internal(capacity)); + gc_root fill(fill_,this); + gc_root new_array(allot_array_internal(capacity),this); if(fill.value() == tag_fixnum(0)) memset(new_array->data(),'\0',capacity * sizeof(cell)); @@ -23,39 +23,47 @@ array *allot_array(cell capacity, cell fill_) 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(allot_array(size,initial))); } -cell allot_array_1(cell obj_) +PRIMITIVE(array) { - gc_root obj(obj_); - gc_root a(allot_array_internal(1)); + PRIMITIVE_GETVM()->vmprim_array(); +} + +cell factorvm::allot_array_1(cell obj_) +{ + gc_root obj(obj_,this); + gc_root a(allot_array_internal(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 v1(v1_); - gc_root v2(v2_); - gc_root a(allot_array_internal(2)); + gc_root v1(v1_,this); + gc_root v2(v2_,this); + gc_root a(allot_array_internal(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 v1(v1_); - gc_root v2(v2_); - gc_root v3(v3_); - gc_root v4(v4_); - gc_root a(allot_array_internal(4)); + gc_root v1(v1_,this); + gc_root v2(v2_,this); + gc_root v3(v3_,this); + gc_root v4(v4_,this); + gc_root a(allot_array_internal(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()); @@ -63,25 +71,33 @@ cell allot_array_4(cell v1_, cell v2_, cell v3_, cell v4_) return a.value(); } -PRIMITIVE(resize_array) + +inline void factorvm::vmprim_resize_array() { array* a = untag_check(dpop()); cell capacity = unbox_array_size(); dpush(tag(reallot_array(a,capacity))); } +PRIMITIVE(resize_array) +{ + PRIMITIVE_GETVM()->vmprim_resize_array(); +} + void growable_array::add(cell elt_) { - gc_root elt(elt_); + factorvm* myvm = elements.myvm; + gc_root 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); } } diff --git a/vm/arrays.hpp b/vm/arrays.hpp old mode 100644 new mode 100755 index 06e6ed6e4d..e3eaccfba3 --- a/vm/arrays.hpp +++ b/vm/arrays.hpp @@ -1,7 +1,7 @@ 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)); @@ -10,34 +10,8 @@ inline static cell array_nth(array *array, cell slot) 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 elements; - - growable_array(cell capacity = 10) : count(0), elements(allot_array(capacity,F)) {} - - void add(cell elt); - void trim(); -}; } diff --git a/vm/bignum.cpp b/vm/bignum.cpp old mode 100644 new mode 100755 index c487186da0..3e754c2ab5 --- a/vm/bignum.cpp +++ b/vm/bignum.cpp @@ -1,36 +1,36 @@ /* :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. @@ -61,313 +61,311 @@ namespace factor /* 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) @@ -375,20 +373,20 @@ FOO_TO_BIGNUM(fixnum,fixnum,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); @@ -396,404 +394,403 @@ BIGNUM_TO_FOO(fixnum,fixnum,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::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: @@ -802,1047 +799,1021 @@ bignum_destructive_scale_up(bignum * bignum, bignum_digit_type factor) 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(length + 1); - BIGNUM_SET_NEGATIVE_P (result, negative_p); - return (result); + BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX)); + bignum * result = allot_array_internal(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)); + } + } } + } diff --git a/vm/bignum.hpp b/vm/bignum.hpp index 296f0dce4c..efa050667b 100644 --- a/vm/bignum.hpp +++ b/vm/bignum.hpp @@ -44,87 +44,9 @@ enum bignum_comparison 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); diff --git a/vm/booleans.cpp b/vm/booleans.cpp index 8407e10099..aa3f392b3e 100644 --- a/vm/booleans.cpp +++ b/vm/booleans.cpp @@ -3,14 +3,26 @@ 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); +} + } diff --git a/vm/booleans.hpp b/vm/booleans.hpp index ea16e0536b..843cd7fd66 100644 --- a/vm/booleans.hpp +++ b/vm/booleans.hpp @@ -1,12 +1,8 @@ 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); } diff --git a/vm/byte_arrays.cpp b/vm/byte_arrays.cpp index 2eda3f33c4..4a197d8452 100644 --- a/vm/byte_arrays.cpp +++ b/vm/byte_arrays.cpp @@ -3,38 +3,54 @@ namespace factor { -byte_array *allot_byte_array(cell size) +byte_array *factorvm::allot_byte_array(cell size) { byte_array *array = allot_array_internal(size); memset(array + 1,0,size); return array; } -PRIMITIVE(byte_array) + +inline void factorvm::vmprim_byte_array() { cell size = unbox_array_size(); dpush(tag(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(allot_array_internal(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(dpop()); cell capacity = unbox_array_size(); dpush(tag(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()[count],elts,len); @@ -43,13 +59,13 @@ void growable_byte_array::append_bytes(void *elts, cell len) void growable_byte_array::append_byte_array(cell byte_array_) { - gc_root byte_array(byte_array_); + gc_root 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()[count],byte_array->data(),len); @@ -58,7 +74,8 @@ void growable_byte_array::append_byte_array(cell byte_array_) void growable_byte_array::trim() { - elements = reallot_array(elements.untagged(),count); + factorvm *myvm = elements.myvm; + elements = myvm->reallot_array(elements.untagged(),count); } } diff --git a/vm/byte_arrays.hpp b/vm/byte_arrays.hpp old mode 100644 new mode 100755 index 6de8ee4e9f..c1adcd95f0 --- a/vm/byte_arrays.hpp +++ b/vm/byte_arrays.hpp @@ -1,22 +1,9 @@ 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 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(); -}; } diff --git a/vm/callstack.cpp b/vm/callstack.cpp old mode 100644 new mode 100755 index 39988ae976..b89dd0cfef --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -3,7 +3,7 @@ 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); @@ -11,14 +11,14 @@ static void check_frame(stack_frame *frame) #endif } -callstack *allot_callstack(cell size) +callstack *factorvm::allot_callstack(cell size) { callstack *stack = allot(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; @@ -35,7 +35,7 @@ This means that if 'callstack' is called in tail position, we 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 @@ -46,7 +46,7 @@ stack_frame *capture_start() return frame + 1; } -PRIMITIVE(callstack) +inline void factorvm::vmprim_callstack() { stack_frame *top = capture_start(); stack_frame *bottom = stack_chain->callstack_bottom; @@ -60,7 +60,12 @@ PRIMITIVE(callstack) dpush(tag(stack)); } -PRIMITIVE(set_callstack) +PRIMITIVE(callstack) +{ + PRIMITIVE_GETVM()->vmprim_callstack(); +} + +inline void factorvm::vmprim_set_callstack() { callstack *stack = untag_check(dpop()); @@ -73,18 +78,24 @@ PRIMITIVE(set_callstack) 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()) @@ -98,14 +109,14 @@ cell frame_executing(stack_frame *frame) } } -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)) { @@ -137,10 +148,12 @@ namespace 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 executing(frame_executing(frame)); - gc_root scan(frame_scan(frame)); + gc_root executing(myvm->frame_executing(frame),myvm); + gc_root scan(myvm->frame_scan(frame),myvm); frames.add(executing.value()); frames.add(scan.value()); @@ -149,18 +162,23 @@ struct stack_frame_accumulator { } -PRIMITIVE(callstack_to_array) +inline void factorvm::vmprim_callstack_to_array() { - gc_root callstack(dpop()); + gc_root 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(); @@ -172,32 +190,42 @@ stack_frame *innermost_stack_frame(callstack *stack) 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(frame_executing(inner)).untag_check(); + tagged(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(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(dpop())))); } -PRIMITIVE(set_innermost_stack_frame_quot) +PRIMITIVE(innermost_stack_frame_scan) { - gc_root callstack(dpop()); - gc_root 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(dpop(),this); + gc_root quot(dpop(),this); + + callstack.untag_check(this); + quot.untag_check(this); jit_compile(quot.value(),true); @@ -207,10 +235,21 @@ PRIMITIVE(set_innermost_stack_frame_quot) 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); +} + } diff --git a/vm/callstack.hpp b/vm/callstack.hpp old mode 100644 new mode 100755 index a3cc058e2b..d34cd618e3 --- a/vm/callstack.hpp +++ b/vm/callstack.hpp @@ -6,13 +6,6 @@ inline static cell callstack_size(cell size) 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); @@ -20,32 +13,8 @@ PRIMITIVE(innermost_stack_frame_executing); PRIMITIVE(innermost_stack_frame_scan); PRIMITIVE(set_innermost_stack_frame_quot); -VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom); - -template 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 void iterate_callstack_object(callstack *stack_, T &iterator) -{ - gc_root 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); - } -} } diff --git a/vm/code_block.cpp b/vm/code_block.cpp old mode 100644 new mode 100755 index aaf8e25866..c2dfe1cac3 --- a/vm/code_block.cpp +++ b/vm/code_block.cpp @@ -3,27 +3,31 @@ 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) { @@ -40,6 +44,7 @@ static int number_of_parameters(relocation_type 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); @@ -47,7 +52,8 @@ static int number_of_parameters(relocation_type type) } } -void *object_xt(cell obj) + +void *factorvm::object_xt(cell obj) { switch(tagged(obj).type()) { @@ -61,7 +67,8 @@ void *object_xt(cell obj) } } -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; @@ -75,25 +82,33 @@ static void *xt_pic(word *w, cell tagged_quot) } } -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); @@ -101,7 +116,7 @@ void *get_rel_symbol(array *literals, cell index) dll *d = (library == F ? NULL : untag(library)); if(d != NULL && !d->dll) - return (void *)undefined_symbol; + return (void *)factor::undefined_symbol; switch(tagged(symbol).type()) { @@ -114,7 +129,7 @@ void *get_rel_symbol(array *literals, cell index) return sym; else { - return (void *)undefined_symbol; + return (void *)factor::undefined_symbol; } } case ARRAY_TYPE: @@ -129,15 +144,16 @@ void *get_rel_symbol(array *literals, cell index) 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(compiled->literals); cell offset = relocation_offset_of(rel) + (cell)compiled->xt(); @@ -171,6 +187,8 @@ cell compute_relocation(relocation_entry rel, cell index, code_block *compiled) 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 */ @@ -179,7 +197,8 @@ cell compute_relocation(relocation_entry rel, cell index, code_block *compiled) #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) { @@ -191,21 +210,23 @@ void iterate_relocations(code_block *compiled, relocation_iterator iter) for(cell i = 0; i < length; i++) { relocation_entry rel = relocation->data()[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; @@ -215,8 +236,9 @@ static void store_address_masked(cell *ptr, fixnum value, cell mask, fixnum shif *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; @@ -261,7 +283,8 @@ 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 factorvm::update_literal_references_step(relocation_entry rel, cell index, code_block *compiled) { if(relocation_type_of(rel) == RT_IMMEDIATE) { @@ -272,19 +295,25 @@ void update_literal_references_step(relocation_entry rel, cell index, code_block } } +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) { @@ -307,12 +336,17 @@ void copy_literal_references(code_block *compiled) } } +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(compiled->literals).untag_check(); - tagged(compiled->relocation).untag_check(); + tagged(compiled->literals).untag_check(this); + tagged(compiled->relocation).untag_check(this); #endif store_address_in_code_block(relocation_class_of(rel), @@ -320,18 +354,28 @@ void relocate_code_block_step(relocation_entry rel, cell index, code_block *comp 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); @@ -346,30 +390,41 @@ void update_word_references(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); @@ -379,24 +434,31 @@ void mark_code_block(code_block *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()) { @@ -419,23 +481,29 @@ void mark_object_code_block(object *object) 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); @@ -452,8 +520,9 @@ void fixup_labels(array *labels, code_block *compiled) } } + /* 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)); @@ -480,18 +549,14 @@ code_block *allot_code_block(cell size) return (code_block *)block; } + /* Might GC */ -code_block *add_code_block( - cell type, - cell code_, - cell labels_, - cell relocation_, - cell literals_) -{ - gc_root code(code_); - gc_root labels(labels_); - gc_root relocation(relocation_); - gc_root literals(literals_); +code_block *factorvm::add_code_block(cell type,cell code_,cell labels_,cell relocation_,cell literals_) +{ + gc_root code(code_,this); + gc_root labels(labels_,this); + gc_root relocation(relocation_,this); + gc_root literals(literals_,this); cell code_length = align8(array_capacity(code.untagged())); code_block *compiled = allot_code_block(code_length); @@ -522,4 +587,5 @@ code_block *add_code_block( return compiled; } + } diff --git a/vm/code_block.hpp b/vm/code_block.hpp index d46cd9e885..17ccdfe8ab 100644 --- a/vm/code_block.hpp +++ b/vm/code_block.hpp @@ -26,6 +26,8 @@ enum relocation_type { RT_UNTAGGED, /* address of megamorphic_cache_hits var */ RT_MEGAMORPHIC_CACHE_HITS, + /* address of vm object*/ + RT_VM, }; enum relocation_class { @@ -60,37 +62,14 @@ static const cell rel_relative_arm_3_mask = 0xffffff; /* 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); } diff --git a/vm/code_gc.cpp b/vm/code_gc.cpp old mode 100644 new mode 100755 index 4710a1baa0..4a86359f1f --- a/vm/code_gc.cpp +++ b/vm/code_gc.cpp @@ -3,15 +3,16 @@ 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) @@ -20,7 +21,8 @@ void new_heap(heap *heap, cell size) 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) { @@ -35,11 +37,12 @@ static void add_to_free_list(heap *heap, free_heap_block *block) } } + /* 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; @@ -91,13 +94,15 @@ void build_free_list(heap *heap, cell size) } -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; @@ -137,7 +142,8 @@ static free_heap_block *find_free_block(heap *heap, cell 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 ) { @@ -153,8 +159,9 @@ static free_heap_block *split_free_block(heap *heap, free_heap_block *block, cel 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); @@ -170,14 +177,16 @@ heap_block *heap_allot(heap *heap, cell size) 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) @@ -193,9 +202,10 @@ void mark_block(heap_block *block) } } + /* 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); @@ -208,9 +218,10 @@ void unmark_marked(heap *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); @@ -244,7 +255,7 @@ void free_unmarked(heap *heap, heap_iterator iter) 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); @@ -257,8 +268,9 @@ void free_unmarked(heap *heap, heap_iterator iter) 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; @@ -286,8 +298,9 @@ void heap_usage(heap *heap, cell *used, cell *total_free, cell *max_free) } } + /* 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); @@ -302,8 +315,9 @@ cell heap_size(heap *heap) return heap->seg->size; } + /* Compute where each block is going to go, after compaction */ -cell compute_heap_forwarding(heap *heap, unordered_map &forwarding) +cell factorvm::compute_heap_forwarding(heap *heap, unordered_map &forwarding) { heap_block *scan = first_block(heap); char *address = (char *)first_block(heap); @@ -324,7 +338,8 @@ cell compute_heap_forwarding(heap *heap, unordered_map &for return (cell)address - heap->seg->start; } -void compact_heap(heap *heap, unordered_map &forwarding) + +void factorvm::compact_heap(heap *heap, unordered_map &forwarding) { heap_block *scan = first_block(heap); diff --git a/vm/code_gc.hpp b/vm/code_gc.hpp old mode 100644 new mode 100755 index 1cfafb69c2..c59980dc30 --- a/vm/code_gc.hpp +++ b/vm/code_gc.hpp @@ -14,19 +14,7 @@ struct 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 &forwarding); -void compact_heap(heap *h, unordered_map &forwarding); +typedef void (*heap_iterator)(heap_block *compiled,factorvm *vm); inline static heap_block *next_block(heap *h, heap_block *block) { diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp old mode 100644 new mode 100755 index 2d2e975fb4..372e194cf6 --- a/vm/code_heap.cpp +++ b/vm/code_heap.cpp @@ -3,24 +3,22 @@ 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_); - gc_root def(def_); + gc_root word(word_,this); + gc_root def(def_,this); jit_compile(def.value(),relocate); @@ -30,36 +28,40 @@ void jit_compile_word(cell word_, cell def_, bool 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 alist(dpop()); + gc_root alist(dpop(),this); cell count = array_capacity(alist.untagged()); @@ -69,10 +71,10 @@ PRIMITIVE(modify_code_heap) cell i; for(i = 0; i < count; i++) { - gc_root pair(array_nth(alist.untagged(),i)); + gc_root pair(array_nth(alist.untagged(),i),this); - gc_root word(array_nth(pair.untagged(),0)); - gc_root data(array_nth(pair.untagged(),1)); + gc_root word(array_nth(pair.untagged(),0),this); + gc_root data(array_nth(pair.untagged(),1),this); switch(data.type()) { @@ -108,8 +110,13 @@ PRIMITIVE(modify_code_heap) 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); @@ -119,14 +126,19 @@ PRIMITIVE(code_room) dpush(tag_fixnum(max_free / 1024)); } -static unordered_map 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)); @@ -134,7 +146,12 @@ void forward_frame_xt(stack_frame *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(); @@ -165,7 +182,7 @@ void forward_object_xts() case CALLSTACK_TYPE: { callstack *stack = untag(obj); - iterate_callstack_object(stack,forward_frame_xt); + iterate_callstack_object(stack,factor::forward_frame_xt); } break; default: @@ -176,8 +193,9 @@ void forward_object_xts() end_scan(); } + /* Set the XT fields now that the heap has been compacted */ -void fixup_object_xts() +void factorvm::fixup_object_xts() { begin_scan(); @@ -205,11 +223,12 @@ void fixup_object_xts() 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(); diff --git a/vm/code_heap.hpp b/vm/code_heap.hpp old mode 100644 new mode 100755 index 6f139a4728..a357699591 --- a/vm/code_heap.hpp +++ b/vm/code_heap.hpp @@ -1,32 +1,9 @@ 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 -} - } diff --git a/vm/contexts.cpp b/vm/contexts.cpp index b0a27ef18f..5acb7d5090 100644 --- a/vm/contexts.cpp +++ b/vm/contexts.cpp @@ -1,26 +1,22 @@ #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(); @@ -28,7 +24,7 @@ void fix_stacks() /* 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) { @@ -37,7 +33,7 @@ void save_stacks() } } -context *alloc_context() +context *factorvm::alloc_context() { context *new_context; @@ -56,14 +52,14 @@ context *alloc_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(); @@ -94,8 +90,14 @@ void nest_stacks() 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; @@ -109,8 +111,14 @@ void unnest_stacks() 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_; @@ -118,7 +126,7 @@ void init_stacks(cell ds_size_, cell 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)); @@ -133,38 +141,58 @@ bool stack_to_array(cell bottom, cell top) } } -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(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(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()); @@ -189,4 +217,9 @@ PRIMITIVE(check_datastack) } } +PRIMITIVE(check_datastack) +{ + PRIMITIVE_GETVM()->vmprim_check_datastack(); +} + } diff --git a/vm/contexts.hpp b/vm/contexts.hpp index 4a6f401f0b..060b15fad7 100644 --- a/vm/contexts.hpp +++ b/vm/contexts.hpp @@ -36,8 +36,6 @@ struct context { 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) @@ -46,21 +44,15 @@ extern cell ds_size, rs_size; 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; diff --git a/vm/cpu-ppc.hpp b/vm/cpu-ppc.hpp index 2124e03350..d0036fb84f 100644 --- a/vm/cpu-ppc.hpp +++ b/vm/cpu-ppc.hpp @@ -3,6 +3,7 @@ namespace factor #define FACTOR_CPU_STRING "ppc" #define VM_ASM_API VM_C_API +#define VM_ASM_API_OVERFLOW VM_C_API register cell ds asm("r13"); register cell rs asm("r14"); @@ -81,9 +82,9 @@ inline static unsigned int fpu_status(unsigned int status) } /* 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, diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index 87a0e03f99..042924ca4f 100644 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -2,6 +2,7 @@ #define ARG0 %eax #define ARG1 %edx +#define ARG2 %ecx #define STACK_REG %esp #define DS_REG %esi #define RETURN_REG %eax @@ -48,13 +49,14 @@ DEF(long long,read_timestamp_counter,(void)): 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*)): @@ -79,6 +81,31 @@ DEF(void,set_x87_env,(const 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 diff --git a/vm/cpu-x86.32.hpp b/vm/cpu-x86.32.hpp index 902b33b0b4..a95179a49b 100644 --- a/vm/cpu-x86.32.hpp +++ b/vm/cpu-x86.32.hpp @@ -7,5 +7,5 @@ register cell ds asm("esi"); register cell rs asm("edi"); #define VM_ASM_API VM_C_API __attribute__ ((regparm (2))) - +#define VM_ASM_API_OVERFLOW VM_C_API __attribute__ ((regparm (3))) } diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S index 0da360e675..704cebe804 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -79,15 +79,17 @@ DEF(long long,read_timestamp_counter,(void)): 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 @@ -106,4 +108,25 @@ DEF(void,set_x87_env,(const void*)): 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" diff --git a/vm/cpu-x86.64.hpp b/vm/cpu-x86.64.hpp index 679c301548..841705c171 100644 --- a/vm/cpu-x86.64.hpp +++ b/vm/cpu-x86.64.hpp @@ -7,5 +7,5 @@ register cell ds asm("r14"); register cell rs asm("r15"); #define VM_ASM_API VM_C_API - +#define VM_ASM_API_OVERFLOW VM_C_API } diff --git a/vm/cpu-x86.S b/vm/cpu-x86.S index d229b2cb79..5360d6c227 100644 --- a/vm/cpu-x86.S +++ b/vm/cpu-x86.S @@ -1,4 +1,5 @@ -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 @@ -8,7 +9,8 @@ DEF(void,primitive_fixnum_add,(void)): 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 @@ -18,7 +20,8 @@ DEF(void,primitive_fixnum_subtract,(void)): 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 @@ -27,24 +30,28 @@ DEF(void,primitive_fixnum_multiply,(void)): 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) @@ -55,24 +62,6 @@ DEF(F_FASTCALL void,c_to_factor,(CELL quot)): 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 @@ -109,6 +98,7 @@ sse_2: sse_1: mov $10,RETURN_REG ret + #ifdef WINDOWS .section .drectve .ascii " -export:sse_version" diff --git a/vm/cpu-x86.hpp b/vm/cpu-x86.hpp index 4a37a17889..8fe0cc4b10 100644 --- a/vm/cpu-x86.hpp +++ b/vm/cpu-x86.hpp @@ -69,9 +69,9 @@ inline static unsigned int fpu_status(unsigned int status) } /* 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, diff --git a/vm/data_gc.cpp b/vm/data_gc.cpp old mode 100644 new mode 100755 index 458a437e37..c192d5714e --- a/vm/data_gc.cpp +++ b/vm/data_gc.cpp @@ -3,45 +3,16 @@ 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); @@ -55,14 +26,16 @@ static object *copy_untagged_object_impl(object *pointer, cell size) 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; @@ -79,8 +52,9 @@ static bool should_copy_p(object *untagged) } } + /* Follow a chain of forwarding pointers */ -static object *resolve_forwarding(object *untagged) +object *factorvm::resolve_forwarding(object *untagged) { check_data_pointer(untagged); @@ -98,27 +72,30 @@ static object *resolve_forwarding(object *untagged) } } -template static T *copy_untagged_object(T *untagged) + +template 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(pointer)),TAG(pointer)); } -void copy_handle(cell *handle) + +void factorvm::copy_handle(cell *handle) { cell pointer = *handle; @@ -131,8 +108,9 @@ void copy_handle(cell *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); @@ -145,7 +123,8 @@ static void copy_card(card *ptr, cell gen, cell here) 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); @@ -176,8 +155,9 @@ static void copy_card_deck(card_deck *deck, cell gen, card mask, card unmask) 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); @@ -242,9 +222,10 @@ static void copy_gen_cards(cell gen) } } + /* 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(); @@ -255,8 +236,9 @@ static void copy_cards() 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; @@ -264,7 +246,8 @@ static void copy_stack_elements(segment *region, cell top) copy_handle((cell*)ptr); } -static void copy_registered_locals() + +void factorvm::copy_registered_locals() { std::vector::const_iterator iter = gc_locals.begin(); std::vector::const_iterator end = gc_locals.end(); @@ -273,7 +256,8 @@ static void copy_registered_locals() copy_handle((cell *)(*iter)); } -static void copy_registered_bignums() + +void factorvm::copy_registered_bignums() { std::vector::const_iterator iter = gc_bignums.begin(); std::vector::const_iterator end = gc_bignums.end(); @@ -295,9 +279,10 @@ static void copy_registered_bignums() } } + /* 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); @@ -331,7 +316,8 @@ static void copy_roots() 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)); @@ -359,7 +345,8 @@ static cell copy_next_from_nursery(cell 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)); @@ -391,7 +378,8 @@ static cell copy_next_from_aging(cell 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)); @@ -421,7 +409,8 @@ static cell copy_next_from_tenured(cell 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()) { @@ -440,8 +429,9 @@ void copy_reachable_objects(cell scan, cell *end) } } + /* 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) { @@ -474,7 +464,8 @@ static void begin_gc(cell requested_bytes) } } -static void end_gc(cell gc_elapsed) + +void factorvm::end_gc(cell gc_elapsed) { gc_stats *s = &stats[collecting_gen]; @@ -512,12 +503,11 @@ static void end_gc(cell gc_elapsed) 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) { @@ -578,7 +568,7 @@ void garbage_collection(cell gen, 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(); @@ -595,19 +585,26 @@ void garbage_collection(cell gen, 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; @@ -635,7 +632,12 @@ PRIMITIVE(gc_stats) 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)); @@ -646,14 +648,19 @@ void clear_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(dpop()); array *old_objects = untag_check(dpop()); @@ -682,7 +689,12 @@ PRIMITIVE(become) 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]); @@ -693,4 +705,10 @@ VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size) 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); +} + } diff --git a/vm/data_gc.hpp b/vm/data_gc.hpp old mode 100644 new mode 100755 index 334ad5a2bb..84c824d779 --- a/vm/data_gc.hpp +++ b/vm/data_gc.hpp @@ -10,139 +10,16 @@ struct gc_stats { 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 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(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); } diff --git a/vm/data_heap.cpp b/vm/data_heap.cpp old mode 100644 new mode 100755 index 5c1c8079c7..de3d8d87be --- a/vm/data_heap.cpp +++ b/vm/data_heap.cpp @@ -1,22 +1,9 @@ #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; @@ -24,7 +11,8 @@ cell init_zone(zone *z, cell size, cell 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); @@ -32,10 +20,7 @@ void init_card_decks() 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); @@ -99,7 +84,8 @@ data_heap *alloc_data_heap(cell gens, 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; @@ -109,7 +95,8 @@ data_heap *grow_data_heap(data_heap *data, cell 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); @@ -120,7 +107,8 @@ void dealloc_data_heap(data_heap *data) 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); @@ -128,7 +116,8 @@ void clear_cards(cell from, cell to) 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); @@ -136,7 +125,8 @@ void clear_decks(cell from, cell to) 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); @@ -144,7 +134,8 @@ void clear_allot_markers(cell from, cell to) 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]); @@ -153,9 +144,10 @@ void reset_generation(cell 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++) @@ -166,7 +158,8 @@ void reset_generations(cell from, cell to) 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()]; @@ -176,19 +169,17 @@ void set_data_heap(data_heap *data_) 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; @@ -196,14 +187,16 @@ cell object_size(cell tagged) return untagged_object_size(untag(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()) { @@ -237,15 +230,21 @@ cell unaligned_object_size(object *pointer) } } -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()) { @@ -279,13 +278,14 @@ cell binary_payload_start(object *pointer) } } + /* 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++) @@ -299,28 +299,36 @@ PRIMITIVE(data_room) 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); @@ -333,19 +341,30 @@ cell next_object() 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 void each_object(T &functor) +PRIMITIVE(end_scan) +{ + PRIMITIVE_GETVM()->vmprim_end_scan(); +} + +template void factorvm::each_object(TYPE &functor) { begin_scan(); cell obj; @@ -354,6 +373,7 @@ template void each_object(T &functor) end_scan(); } + namespace { @@ -365,20 +385,21 @@ struct word_counter { struct word_accumulator { growable_array words; - word_accumulator(int count) : words(count) {} + word_accumulator(int count,factorvm *vm) : words(vm,count) {} void operator()(tagged 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(); } + } diff --git a/vm/data_heap.hpp b/vm/data_heap.hpp old mode 100644 new mode 100755 index 4ef72a6fcb..7e6ff81e70 --- a/vm/data_heap.hpp +++ b/vm/data_heap.hpp @@ -1,8 +1,6 @@ namespace factor { -/* Set by the -securegc command line argument */ -extern bool secure_gc; /* generational copying GC divides memory into zones */ struct zone { @@ -47,7 +45,6 @@ struct data_heap { bool have_aging_p() { return gen_count > 2; } }; -extern data_heap *data; static const cell max_gen_count = 3; @@ -56,42 +53,11 @@ inline static bool in_zone(zone *z, object *pointer) 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); @@ -99,30 +65,4 @@ PRIMITIVE(begin_scan); 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; diff --git a/vm/debug.cpp b/vm/debug.cpp old mode 100644 new mode 100755 index 5f78afb9db..6009e922f7 --- a/vm/debug.cpp +++ b/vm/debug.cpp @@ -3,17 +3,16 @@ 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(word->vocabulary).type_p(STRING_TYPE)) { @@ -31,14 +30,16 @@ void print_word(word* word, cell nesting) } } -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; @@ -62,7 +63,8 @@ void print_array(array* array, cell nesting) print_string("..."); } -void print_tuple(tuple *tuple, cell nesting) + +void factorvm::print_tuple(tuple *tuple, cell nesting) { tuple_layout *layout = untag(tuple->layout); cell length = to_fixnum(layout->size); @@ -91,7 +93,8 @@ void print_tuple(tuple *tuple, cell nesting) print_string("..."); } -void print_nested_obj(cell obj, fixnum nesting) + +void factorvm::print_nested_obj(cell obj, fixnum nesting) { if(nesting <= 0 && !full_output) { @@ -141,12 +144,14 @@ void print_nested_obj(cell obj, fixnum nesting) } } -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++) { @@ -155,19 +160,22 @@ void print_objects(cell *start, cell *end) } } -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"); @@ -184,15 +192,21 @@ void print_stack_frame(stack_frame *frame) 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; @@ -200,7 +214,8 @@ void dump_cell(cell x) nl(); } -void dump_memory(cell from, cell to) + +void factorvm::dump_memory(cell from, cell to) { from = UNTAG(from); @@ -208,14 +223,16 @@ void dump_memory(cell from, cell to) 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; @@ -241,7 +258,8 @@ void dump_generations() nl(); } -void dump_objects(cell type) + +void factorvm::dump_objects(cell type) { gc(); begin_scan(); @@ -261,10 +279,9 @@ void dump_objects(cell type) 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) { @@ -275,20 +292,26 @@ void find_data_references_step(cell *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; @@ -328,7 +351,8 @@ void dump_code_heap() print_cell(literal_size); print_string(" bytes of literal data\n"); } -void factorbug() + +void factorvm::factorbug() { if(fep_disabled) { @@ -472,11 +496,17 @@ void factorbug() } } -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(); +} + } diff --git a/vm/debug.hpp b/vm/debug.hpp old mode 100644 new mode 100755 index cb84c9256c..48566f1b2d --- a/vm/debug.hpp +++ b/vm/debug.hpp @@ -1,11 +1,6 @@ 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); diff --git a/vm/dispatch.cpp b/vm/dispatch.cpp old mode 100644 new mode 100755 index 4a1411733e..e87cdeac70 --- a/vm/dispatch.cpp +++ b/vm/dispatch.cpp @@ -3,10 +3,7 @@ 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(table); fixnum index = array_capacity(elements) - 2; @@ -21,7 +18,7 @@ static cell search_lookup_alist(cell table, cell klass) 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(table); cell bucket = array_nth(buckets,hashcode & (array_capacity(buckets) - 1)); @@ -31,19 +28,19 @@ static cell search_lookup_hash(cell table, cell klass, cell hashcode) 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(untag(obj)->layout); @@ -75,7 +72,7 @@ static cell lookup_tuple_method(cell obj, cell methods) 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(methods); cell tag = untag(obj)->h.hi_tag() - HEADER_TYPE; @@ -85,7 +82,7 @@ static cell lookup_hi_tag_method(cell obj, cell methods) 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(methods),TAG(obj)); if(tagged(method).type_p(WORD_TYPE)) @@ -107,7 +104,7 @@ static cell lookup_hairy_method(cell obj, cell methods) } } -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) @@ -116,14 +113,19 @@ cell lookup_method(cell obj, cell methods) return array_nth(untag(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)) { @@ -136,13 +138,13 @@ cell object_class(cell 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(cache); cell hashcode = method_cache_hashcode(klass,cache_elements); @@ -150,7 +152,7 @@ static void update_method_cache(cell cache, cell klass, cell method) set_array_nth(cache_elements,hashcode + 1,method); } -PRIMITIVE(mega_cache_miss) +inline void factorvm::vmprim_mega_cache_miss() { megamorphic_cache_misses++; @@ -167,44 +169,59 @@ PRIMITIVE(mega_cache_miss) 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 methods(methods_); - gc_root cache(cache_); + gc_root methods(methods_,myvm); + gc_root 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]); } } diff --git a/vm/dispatch.hpp b/vm/dispatch.hpp index 75368191a7..b9cbcbbd85 100644 --- a/vm/dispatch.hpp +++ b/vm/dispatch.hpp @@ -1,21 +1,9 @@ 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); - } diff --git a/vm/errors.cpp b/vm/errors.cpp old mode 100644 new mode 100755 index ebe6201f72..b3e9543b13 --- a/vm/errors.cpp +++ b/vm/errors.cpp @@ -3,14 +3,7 @@ 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(); @@ -24,7 +17,7 @@ void fatal_error(const char* msg, cell tagged) 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); @@ -32,7 +25,7 @@ void critical_error(const char* msg, cell tagged) 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. */ @@ -63,7 +56,7 @@ void throw_error(cell error, stack_frame *callstack_top) 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. */ @@ -77,26 +70,27 @@ void throw_error(cell error, stack_frame *callstack_top) } } -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; @@ -105,7 +99,7 @@ bool in_page(cell fault, cell area, cell area_size, int offset) 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); @@ -121,45 +115,70 @@ void memory_protection_error(cell addr, stack_frame *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(); +} + } diff --git a/vm/errors.hpp b/vm/errors.hpp old mode 100644 new mode 100755 index 7f3c4dcd4a..4f45c55c73 --- a/vm/errors.hpp +++ b/vm/errors.hpp @@ -23,31 +23,11 @@ enum vm_error_type 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(); diff --git a/vm/factor.cpp b/vm/factor.cpp old mode 100644 new mode 100755 index 33d8b73dfe..4ef4d11796 --- a/vm/factor.cpp +++ b/vm/factor.cpp @@ -3,7 +3,14 @@ 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; @@ -37,13 +44,17 @@ VM_C_API void default_parameters(vm_parameters *p) #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) @@ -55,7 +66,7 @@ static bool factor_arg(const vm_char* str, const vm_char* arg, cell* value) 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]; @@ -81,7 +92,7 @@ VM_C_API void init_parameters_from_args(vm_parameters *p, int argc, vm_char **ar } /* Do some initialization that we do once only */ -static void do_stage1_init() +void factorvm::do_stage1_init() { print_string("*** Stage 2 early init... "); fflush(stdout); @@ -93,7 +104,7 @@ static void do_stage1_init() 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); @@ -150,19 +161,20 @@ VM_C_API void init_factor(vm_parameters *p) } /* 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(); @@ -171,13 +183,31 @@ static void start_factor(vm_parameters *p) 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); @@ -187,27 +217,34 @@ VM_C_API void start_standalone_factor(int argc, vm_char **argv) 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); } } diff --git a/vm/factor.hpp b/vm/factor.hpp index 6e00bc012e..5f41c952e1 100644 --- a/vm/factor.hpp +++ b/vm/factor.hpp @@ -1,16 +1,8 @@ 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); } diff --git a/vm/generic_arrays.hpp b/vm/generic_arrays.hpp index 26c8149a10..0125cb7651 100644 --- a/vm/generic_arrays.hpp +++ b/vm/generic_arrays.hpp @@ -19,41 +19,4 @@ template cell array_size(T *array) return array_size(array_capacity(array)); } -template T *allot_array_internal(cell capacity) -{ - T *array = allot(array_size(capacity)); - array->capacity = tag_fixnum(capacity); - return array; -} - -template bool reallot_array_in_place_p(T *array, cell capacity) -{ - return in_zone(&nursery,array) && capacity <= array_capacity(array); -} - -template T *reallot_array(T *array_, cell capacity) -{ - gc_root 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(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; - } -} - } diff --git a/vm/image.cpp b/vm/image.cpp old mode 100644 new mode 100755 index de9de1acf1..747e0cc37e --- a/vm/image.cpp +++ b/vm/image.cpp @@ -4,7 +4,7 @@ namespace factor { /* 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)); @@ -14,9 +14,9 @@ static void init_objects(image_header *h) 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); @@ -49,9 +49,9 @@ static void load_data_heap(FILE *file, image_header *h, vm_parameters *p) 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); @@ -76,8 +76,9 @@ static void load_code_heap(FILE *file, image_header *h, vm_parameters *p) 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; @@ -122,23 +123,29 @@ bool save_image(const vm_char *filename) return ok; } -PRIMITIVE(save_image) + +inline void factorvm::vmprim_save_image() { /* do a full GC to push everything into tenured space */ gc(); - gc_root path(dpop()); - path.untag_check(); + gc_root 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 path(dpop()); - path.untag_check(); + gc_root 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++) @@ -158,7 +165,12 @@ PRIMITIVE(save_image_and_exit) 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; @@ -167,14 +179,20 @@ static void data_fixup(cell *cell) *cell += (tenured->start - data_relocation_base); } -template void code_fixup(T **handle) +void data_fixup(cell *cell, factorvm *myvm) +{ + return myvm->data_fixup(cell); +} + +template 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); @@ -183,7 +201,8 @@ static void fixup_word(word *word) code_fixup(&word->xt); } -static void fixup_quotation(quotation *quot) + +void factorvm::fixup_quotation(quotation *quot) { if(quot->code) { @@ -194,24 +213,32 @@ static void fixup_quotation(quotation *quot) 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(); @@ -231,7 +258,7 @@ static void relocate_object(object *object) } else { - do_slots((cell)object,data_fixup); + do_slots((cell)object,factor::data_fixup); switch(hi_tag) { @@ -254,9 +281,10 @@ static void relocate_object(object *object) } } + /* Since the image might have been saved with a different base address than where it is loaded, we need to fix up pointers in the image. */ -void relocate_data() +void factorvm::relocate_data() { cell relocating; @@ -281,7 +309,8 @@ void relocate_data() } } -static void fixup_code_block(code_block *compiled) + +void factorvm::fixup_code_block(code_block *compiled) { /* relocate literal table data */ data_fixup(&compiled->relocation); @@ -290,14 +319,20 @@ static void fixup_code_block(code_block *compiled) 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) @@ -331,4 +366,5 @@ void load_image(vm_parameters *p) userenv[IMAGE_ENV] = allot_alien(F,(cell)p->image_path); } + } diff --git a/vm/image.hpp b/vm/image.hpp old mode 100644 new mode 100755 index 807a7a6bcf..eab0343716 --- a/vm/image.hpp +++ b/vm/image.hpp @@ -41,9 +41,6 @@ struct vm_parameters { 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); diff --git a/vm/inline_cache.cpp b/vm/inline_cache.cpp old mode 100644 new mode 100755 index e9e098de70..4c77a83a93 --- a/vm/inline_cache.cpp +++ b/vm/inline_cache.cpp @@ -3,21 +3,13 @@ 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); @@ -38,7 +30,7 @@ void deallocate_inline_cache(cell 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; @@ -75,7 +67,7 @@ static cell determine_inline_cache_type(array *cache_entries) return 0; } -static void update_pic_count(cell type) +void factorvm::update_pic_count(cell type) { pic_counts[type - PIC_TAG]++; } @@ -83,7 +75,7 @@ static void update_pic_count(cell type) 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, @@ -97,9 +89,9 @@ void inline_cache_jit::emit_check(cell klass) { 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); } @@ -112,12 +104,12 @@ void inline_cache_jit::compile_inline_cache(fixnum index, cell cache_entries_, bool tail_call_p) { - gc_root generic_word(generic_word_); - gc_root methods(methods_); - gc_root cache_entries(cache_entries_); + gc_root generic_word(generic_word_,myvm); + gc_root methods(methods_,myvm); + gc_root 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); @@ -132,7 +124,7 @@ void inline_cache_jit::compile_inline_cache(fixnum index, /* 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 @@ -144,20 +136,16 @@ void inline_cache_jit::compile_inline_cache(fixnum index, 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 generic_word(generic_word_); - gc_root methods(methods_); - gc_root cache_entries(cache_entries_); + gc_root generic_word(generic_word_,this); + gc_root methods(methods_,this); + gc_root 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(), @@ -169,31 +157,31 @@ static code_block *compile_inline_cache(fixnum index, } /* 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(generic_word)->xt; } -static cell inline_cache_size(cell cache_entries) +cell factorvm::inline_cache_size(cell cache_entries) { return array_capacity(untag_check(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 cache_entries(cache_entries_); - gc_root klass(klass_); - gc_root method(method_); + gc_root cache_entries(cache_entries_,this); + gc_root klass(klass_,this); + gc_root method(method_,this); cell pic_size = array_capacity(cache_entries.untagged()); - gc_root new_cache_entries(reallot_array(cache_entries.untagged(),pic_size + 2)); + gc_root 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++; @@ -205,7 +193,7 @@ static void update_pic_transitions(cell pic_size) /* 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); @@ -214,11 +202,11 @@ void *inline_cache_miss(cell return_address) instead of leaving dead PICs around until the next GC. */ deallocate_inline_cache(return_address); - gc_root cache_entries(dpop()); + gc_root cache_entries(dpop(),this); fixnum index = untag_fixnum(dpop()); - gc_root methods(dpop()); - gc_root generic_word(dpop()); - gc_root object(((cell *)ds)[-index]); + gc_root methods(dpop(),this); + gc_root generic_word(dpop(),this); + gc_root object(((cell *)ds)[-index],this); void *xt; @@ -236,7 +224,7 @@ void *inline_cache_miss(cell return_address) gc_root new_cache_entries(add_inline_cache_entry( cache_entries.value(), klass, - method)); + method),this); xt = compile_inline_cache(index, generic_word.value(), methods.value(), @@ -257,16 +245,28 @@ void *inline_cache_miss(cell return_address) 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)); @@ -277,4 +277,9 @@ PRIMITIVE(inline_cache_stats) dpush(stats.elements.value()); } +PRIMITIVE(inline_cache_stats) +{ + PRIMITIVE_GETVM()->vmprim_inline_cache_stats(); +} + } diff --git a/vm/inline_cache.hpp b/vm/inline_cache.hpp index e2a6ae8cf9..02ac43dce8 100644 --- a/vm/inline_cache.hpp +++ b/vm/inline_cache.hpp @@ -1,15 +1,10 @@ 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); } diff --git a/vm/inlineimpls.hpp b/vm/inlineimpls.hpp new file mode 100644 index 0000000000..a247afa4d7 --- /dev/null +++ b/vm/inlineimpls.hpp @@ -0,0 +1,405 @@ +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 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(tagged); + check_data_pointer(obj); + obj->h.hi_tag(); + } +#endif +} + +//local_roots.hpp +template +struct gc_root : public tagged +{ + factorvm *myvm; + + void push() { myvm->check_tagged_pointer(tagged::value()); myvm->gc_locals.push_back((cell)this); } + + explicit gc_root(cell value_,factorvm *vm) : tagged(value_),myvm(vm) { push(); } + explicit gc_root(TYPE *value_, factorvm *vm) : tagged(value_),myvm(vm) { push(); } + + const gc_root& operator=(const TYPE *x) { tagged::operator=(x); return *this; } + const gc_root& operator=(const cell &x) { tagged::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 TYPE *factorvm::allot_array_internal(cell capacity) +{ + TYPE *array = allot(array_size(capacity)); + array->capacity = tag_fixnum(capacity); + return array; +} + +template bool factorvm::reallot_array_in_place_p(TYPE *array, cell capacity) +{ + return in_zone(&nursery,array) && capacity <= array_capacity(array); +} + +template TYPE *factorvm::reallot_array(TYPE *array_, cell capacity) +{ + gc_root 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(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 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 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(fixnum_to_bignum(x)); + else + return tag_fixnum(x); +} + +inline cell factorvm::allot_cell(cell x) +{ + if(x > (cell)fixnum_max) + return tag(cell_to_bignum(x)); + else + return tag_fixnum(x); +} + +inline cell factorvm::allot_float(double n) +{ + boxed_float *flo = allot(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(tagged)); +} + +inline double factorvm::untag_float(cell tagged) +{ + return untag(tagged)->n; +} + +inline double factorvm::untag_float_check(cell tagged) +{ + return untag_check(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 void factorvm::iterate_callstack_object(callstack *stack_, TYPE &iterator) +{ + gc_root 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 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 +} + +} diff --git a/vm/io.cpp b/vm/io.cpp old mode 100644 new mode 100755 index 5bb5834691..650afb8f8a --- a/vm/io.cpp +++ b/vm/io.cpp @@ -14,14 +14,15 @@ The Factor library provides platform-specific code for Unix and Windows 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) @@ -31,12 +32,13 @@ void io_error() general_error(ERROR_IO,tag_fixnum(errno),F,NULL); } -PRIMITIVE(fopen) + +inline void factorvm::vmprim_fopen() { - gc_root mode(dpop()); - gc_root path(dpop()); - mode.untag_check(); - path.untag_check(); + gc_root mode(dpop(),this); + gc_root path(dpop(),this); + mode.untag_check(this); + path.untag_check(this); for(;;) { @@ -52,7 +54,12 @@ PRIMITIVE(fopen) } } -PRIMITIVE(fgetc) +PRIMITIVE(fopen) +{ + PRIMITIVE_GETVM()->vmprim_fopen(); +} + +inline void factorvm::vmprim_fgetc() { FILE *file = (FILE *)unbox_alien(); @@ -77,7 +84,12 @@ PRIMITIVE(fgetc) } } -PRIMITIVE(fread) +PRIMITIVE(fgetc) +{ + PRIMITIVE_GETVM()->vmprim_fgetc(); +} + +inline void factorvm::vmprim_fread() { FILE *file = (FILE *)unbox_alien(); fixnum size = unbox_array_size(); @@ -88,7 +100,7 @@ PRIMITIVE(fread) return; } - gc_root buf(allot_array_internal(size)); + gc_root buf(allot_array_internal(size),this); for(;;) { @@ -117,7 +129,12 @@ PRIMITIVE(fread) } } -PRIMITIVE(fputc) +PRIMITIVE(fread) +{ + PRIMITIVE_GETVM()->vmprim_fread(); +} + +inline void factorvm::vmprim_fputc() { FILE *file = (FILE *)unbox_alien(); fixnum ch = to_fixnum(dpop()); @@ -135,7 +152,12 @@ PRIMITIVE(fputc) } } -PRIMITIVE(fwrite) +PRIMITIVE(fputc) +{ + PRIMITIVE_GETVM()->vmprim_fputc(); +} + +inline void factorvm::vmprim_fwrite() { FILE *file = (FILE *)unbox_alien(); byte_array *text = untag_check(dpop()); @@ -164,7 +186,12 @@ PRIMITIVE(fwrite) } } -PRIMITIVE(fseek) +PRIMITIVE(fwrite) +{ + PRIMITIVE_GETVM()->vmprim_fwrite(); +} + +inline void factorvm::vmprim_fseek() { int whence = to_fixnum(dpop()); FILE *file = (FILE *)unbox_alien(); @@ -189,7 +216,12 @@ PRIMITIVE(fseek) } } -PRIMITIVE(fflush) +PRIMITIVE(fseek) +{ + PRIMITIVE_GETVM()->vmprim_fseek(); +} + +inline void factorvm::vmprim_fflush() { FILE *file = (FILE *)unbox_alien(); for(;;) @@ -201,7 +233,12 @@ PRIMITIVE(fflush) } } -PRIMITIVE(fclose) +PRIMITIVE(fflush) +{ + PRIMITIVE_GETVM()->vmprim_fflush(); +} + +inline void factorvm::vmprim_fclose() { FILE *file = (FILE *)unbox_alien(); for(;;) @@ -213,6 +250,11 @@ PRIMITIVE(fclose) } } +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. */ @@ -225,5 +267,4 @@ VM_C_API void clear_err_no() { errno = 0; } - } diff --git a/vm/io.hpp b/vm/io.hpp old mode 100644 new mode 100755 index d94d6402d9..1b5e281b54 --- a/vm/io.hpp +++ b/vm/io.hpp @@ -1,9 +1,6 @@ namespace factor { -void init_c_io(); -void io_error(); - PRIMITIVE(fopen); PRIMITIVE(fgetc); PRIMITIVE(fread); diff --git a/vm/jit.cpp b/vm/jit.cpp index a3f222a953..cdb5acace3 100644 --- a/vm/jit.cpp +++ b/vm/jit.cpp @@ -10,22 +10,23 @@ namespace factor - 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 code_template(code_template_); + gc_root code_template(code_template_,myvm); cell capacity = array_capacity(code_template.untagged()); for(cell i = 1; i < capacity; i += 3) { @@ -44,11 +45,11 @@ void jit::emit_relocation(cell code_template_) /* Allocates memory */ void jit::emit(cell code_template_) { - gc_root code_template(code_template_); + gc_root code_template(code_template_,myvm); emit_relocation(code_template.value()); - gc_root insns(array_nth(code_template.untagged(),0)); + gc_root insns(array_nth(code_template.untagged(),0),myvm); if(computing_offset_p) { @@ -72,16 +73,16 @@ void jit::emit(cell code_template_) } void jit::emit_with(cell code_template_, cell argument_) { - gc_root code_template(code_template_); - gc_root argument(argument_); + gc_root code_template(code_template_,myvm); + gc_root 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. @@ -101,7 +102,7 @@ code_block *jit::to_code_block() relocation.trim(); literals.trim(); - return add_code_block( + return myvm->add_code_block( type, code.elements.value(), F, /* no labels */ diff --git a/vm/jit.hpp b/vm/jit.hpp index 50b40eca30..a44f359ffe 100644 --- a/vm/jit.hpp +++ b/vm/jit.hpp @@ -10,8 +10,9 @@ struct jit { 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); @@ -21,27 +22,27 @@ struct jit { 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_); - gc_root code_template(word->subprimitive); - if(array_capacity(code_template.untagged()) > 1) literal(T); + gc_root word(word_,myvm); + gc_root code_template(word->subprimitive,myvm); + if(array_capacity(code_template.untagged()) > 1) literal(myvm->T); emit(code_template.value()); } diff --git a/vm/local_roots.cpp b/vm/local_roots.cpp index 7e1b2da76a..71baee6deb 100644 --- a/vm/local_roots.cpp +++ b/vm/local_roots.cpp @@ -2,9 +2,4 @@ namespace factor { - -std::vector gc_locals; - -std::vector gc_bignums; - } diff --git a/vm/local_roots.hpp b/vm/local_roots.hpp index d67622fc0a..0d6a033f82 100644 --- a/vm/local_roots.hpp +++ b/vm/local_roots.hpp @@ -1,51 +1,3 @@ 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 gc_locals; - -template -struct gc_root : public tagged -{ - void push() { check_tagged_pointer(tagged::value()); gc_locals.push_back((cell)this); } - - explicit gc_root(cell value_) : tagged(value_) { push(); } - explicit gc_root(T *value_) : tagged(value_) { push(); } - - const gc_root& operator=(const T *x) { tagged::operator=(x); return *this; } - const gc_root& operator=(const cell &x) { tagged::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 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) - } diff --git a/vm/mach_signal.cpp b/vm/mach_signal.cpp index d8eea06f0b..08b0d00f1c 100644 --- a/vm/mach_signal.cpp +++ b/vm/mach_signal.cpp @@ -28,7 +28,7 @@ http://www.wodeveloper.com/omniLists/macosx-dev/2000/June/msg00137.html */ /* 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, @@ -53,21 +53,30 @@ static void call_fault_handler( 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" @@ -215,7 +224,7 @@ void mach_initialize () 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 diff --git a/vm/main-unix.cpp b/vm/main-unix.cpp index bc605e3cfd..b8914e2bd3 100644 --- a/vm/main-unix.cpp +++ b/vm/main-unix.cpp @@ -2,6 +2,7 @@ int main(int argc, char **argv) { + factor::init_globals(); factor::start_standalone_factor(argc,argv); return 0; } diff --git a/vm/main-windows-nt.cpp b/vm/main-windows-nt.cpp index eaaad0f55b..df4a1172f1 100644 --- a/vm/main-windows-nt.cpp +++ b/vm/main-windows-nt.cpp @@ -16,7 +16,13 @@ int WINAPI WinMain( 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); diff --git a/vm/master.hpp b/vm/master.hpp old mode 100644 new mode 100755 index 9d84c8b75c..00ee181b8f --- a/vm/master.hpp +++ b/vm/master.hpp @@ -1,6 +1,9 @@ #ifndef __FACTOR_MASTER_H__ #define __FACTOR_MASTER_H__ +#define _THREAD_SAFE +#define _REENTRANT + #ifndef WINCE #include #endif @@ -41,11 +44,11 @@ #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" @@ -62,11 +65,13 @@ #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" @@ -74,4 +79,6 @@ #include "factor.hpp" #include "utilities.hpp" + + #endif /* __FACTOR_MASTER_H__ */ diff --git a/vm/math.cpp b/vm/math.cpp old mode 100644 new mode 100755 index b16557b8b7..4b595f85a3 --- a/vm/math.cpp +++ b/vm/math.cpp @@ -3,23 +3,29 @@ 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(dpeek())))); +} PRIMITIVE(bignum_to_fixnum) { - drepl(tag_fixnum(bignum_to_fixnum(untag(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()); @@ -30,7 +36,12 @@ PRIMITIVE(fixnum_divint) 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]; @@ -46,26 +57,34 @@ PRIMITIVE(fixnum_divmod) } } +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()); @@ -92,51 +111,91 @@ PRIMITIVE(fixnum_shift) 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(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(float_to_bignum(dpeek()))); } +PRIMITIVE(float_to_bignum) +{ + PRIMITIVE_GETVM()->vmprim_float_to_bignum(); +} + #define POP_BIGNUMS(x,y) \ bignum * y = untag(dpop()); \ bignum * x = untag(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_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_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_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_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); @@ -145,92 +204,168 @@ PRIMITIVE(bignum_divmod) dpush(tag(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_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_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_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_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(dpop()); dpush(tag(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_bitwise_not(untag(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(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_integer_length(untag(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(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(result)); } -cell unbox_array_size() +PRIMITIVE(byte_array_to_bignum) +{ + PRIMITIVE_GETVM()->vmprim_byte_array_to_bignum(); +} + +cell factorvm::unbox_array_size() { switch(tagged(dpeek()).type()) { @@ -263,17 +398,28 @@ cell unbox_array_size() 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(dpeek()); cell capacity = array_capacity(bytes); @@ -287,98 +433,178 @@ PRIMITIVE(str_to_float) 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(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)) { @@ -392,52 +618,112 @@ VM_C_API fixnum to_fixnum(cell 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(long_long_to_bignum(n))); @@ -445,7 +731,13 @@ VM_C_API void box_signed_8(s64 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(obj).type()) { @@ -459,7 +751,13 @@ VM_C_API s64 to_signed_8(cell obj) } } -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(ulong_long_to_bignum(n))); @@ -467,7 +765,13 @@ VM_C_API void box_unsigned_8(u64 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(obj).type()) { @@ -481,47 +785,92 @@ VM_C_API u64 to_unsigned_8(cell obj) } } -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(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(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_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); +} + } diff --git a/vm/math.hpp b/vm/math.hpp index 7828aa3e6c..5e6121afb2 100644 --- a/vm/math.hpp +++ b/vm/math.hpp @@ -1,14 +1,11 @@ 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); @@ -42,61 +39,6 @@ PRIMITIVE(bignum_bitp); PRIMITIVE(bignum_log2); PRIMITIVE(byte_array_to_bignum); -inline static cell allot_integer(fixnum x) -{ - if(x < fixnum_min || x > fixnum_max) - return tag(fixnum_to_bignum(x)); - else - return tag_fixnum(x); -} - -inline static cell allot_cell(cell x) -{ - if(x > (cell)fixnum_max) - return tag(cell_to_bignum(x)); - else - return tag_fixnum(x); -} - -cell unbox_array_size(); - -inline static double untag_float(cell tagged) -{ - return untag(tagged)->n; -} - -inline static double untag_float_check(cell tagged) -{ - return untag_check(tagged)->n; -} - -inline static cell allot_float(double n) -{ - boxed_float *flo = allot(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(tagged)); -} - PRIMITIVE(fixnum_to_float); PRIMITIVE(bignum_to_float); PRIMITIVE(str_to_float); @@ -119,30 +61,30 @@ PRIMITIVE(bits_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); } diff --git a/vm/os-genunix.cpp b/vm/os-genunix.cpp index 6cca455eb7..6540d8d196 100644 --- a/vm/os-genunix.cpp +++ b/vm/os-genunix.cpp @@ -3,9 +3,9 @@ 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() diff --git a/vm/os-linux-arm.cpp b/vm/os-linux-arm.cpp index 8e131b9011..0f459d5ec5 100644 --- a/vm/os-linux-arm.cpp +++ b/vm/os-linux-arm.cpp @@ -25,7 +25,7 @@ void flush_icache(cell start, cell len) : "r0","r1","r2"); if(result < 0) - critical_error("flush_icache() failed",result); + SIGNAL_VM_PTR->critical_error("flush_icache() failed",result); } } diff --git a/vm/os-linux.cpp b/vm/os-linux.cpp index 2bc121ffc7..66b197e7c9 100644 --- a/vm/os-linux.cpp +++ b/vm/os-linux.cpp @@ -42,19 +42,19 @@ VM_C_API int inotify_rm_watch(int fd, u32 wd) 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; } diff --git a/vm/os-macosx.mm b/vm/os-macosx.mm index 792ba0d541..872e0b8b48 100644 --- a/vm/os-macosx.mm +++ b/vm/os-macosx.mm @@ -5,12 +5,12 @@ 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)); diff --git a/vm/os-unix.cpp b/vm/os-unix.cpp index 189fca0cf7..65b32066e5 100644 --- a/vm/os-unix.cpp +++ b/vm/os-unix.cpp @@ -3,18 +3,39 @@ 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; @@ -31,38 +52,46 @@ void sleep_micros(cell usec) 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(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(); @@ -101,7 +130,7 @@ void dealloc_segment(segment *block) 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 @@ -118,30 +147,48 @@ static stack_frame *uap_stack_pointer(void *uap) 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) @@ -320,7 +367,7 @@ void open_console() stdin_read = filedes[0]; stdin_write = filedes[1]; - start_thread(stdin_loop); + start_thread(stdin_loop,NULL); } VM_C_API void wait_for_stdin() diff --git a/vm/os-unix.hpp b/vm/os-unix.hpp index 8aff18364e..5f84106f97 100644 --- a/vm/os-unix.hpp +++ b/vm/os-unix.hpp @@ -42,12 +42,10 @@ typedef char symbol_char; #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); @@ -56,6 +54,9 @@ void dump_stack_signal(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(); - } diff --git a/vm/os-windows-ce.cpp b/vm/os-windows-ce.cpp index 2e69a1eb5b..6454535f43 100644 --- a/vm/os-windows-ce.cpp +++ b/vm/os-windows-ce.cpp @@ -26,18 +26,18 @@ void flush_icache(cell start, cell end) 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() { } diff --git a/vm/os-windows-nt.cpp b/vm/os-windows-nt.cpp index b50c9b7af8..988ce60a8a 100755 --- a/vm/os-windows-nt.cpp +++ b/vm/os-windows-nt.cpp @@ -3,6 +3,34 @@ 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; @@ -11,7 +39,7 @@ s64 current_micros() - 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; @@ -21,11 +49,10 @@ FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe) 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: @@ -40,7 +67,7 @@ FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe) 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 @@ -52,21 +79,32 @@ FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe) 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() { } diff --git a/vm/os-windows-nt.hpp b/vm/os-windows-nt.hpp index 088103bb5b..366348a898 100755 --- a/vm/os-windows-nt.hpp +++ b/vm/os-windows-nt.hpp @@ -19,13 +19,20 @@ typedef char symbol_char; #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(); + } diff --git a/vm/os-windows.cpp b/vm/os-windows.cpp index 7db19ff560..bd7e573dcc 100644 --- a/vm/os-windows.cpp +++ b/vm/os-windows.cpp @@ -5,30 +5,30 @@ namespace factor 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, @@ -56,14 +56,15 @@ bool windows_stat(vm_char *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; @@ -75,14 +76,14 @@ const vm_char *default_image_path() 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)) @@ -91,13 +92,18 @@ const vm_char *vm_executable_path() } -PRIMITIVE(existsp) +inline void factorvm::vmprim_existsp() { vm_char *path = untag_check(dpop())->data(); 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; @@ -122,7 +128,7 @@ segment *alloc_segment(cell size) return block; } -void dealloc_segment(segment *block) +void factorvm::dealloc_segment(segment *block) { SYSTEM_INFO si; GetSystemInfo(&si); @@ -131,7 +137,7 @@ void dealloc_segment(segment *block) free(block); } -long getpagesize() +long factorvm::getpagesize() { static long g_pagesize = 0; if (! g_pagesize) @@ -143,7 +149,7 @@ long getpagesize() return g_pagesize; } -void sleep_micros(u64 usec) +void factorvm::sleep_micros(u64 usec) { Sleep((DWORD)(usec / 1000)); } diff --git a/vm/os-windows.hpp b/vm/os-windows.hpp index 27e2775289..e5617213f4 100644 --- a/vm/os-windows.hpp +++ b/vm/os-windows.hpp @@ -41,18 +41,9 @@ typedef wchar_t vm_char; /* 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(); diff --git a/vm/primitives.cpp b/vm/primitives.cpp index 6dbe281d0c..1cbad03001 100644 --- a/vm/primitives.cpp +++ b/vm/primitives.cpp @@ -162,6 +162,7 @@ const primitive_type primitives[] = { primitive_inline_cache_stats, primitive_optimized_p, primitive_quot_compiled_p, + primitive_vm_ptr, }; } diff --git a/vm/primitives.hpp b/vm/primitives.hpp index c520a67cc5..4be190d4e6 100644 --- a/vm/primitives.hpp +++ b/vm/primitives.hpp @@ -1,9 +1,13 @@ 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[]; } diff --git a/vm/profiler.cpp b/vm/profiler.cpp old mode 100644 new mode 100755 index a3265e0ffa..1b7c7c1ac5 --- a/vm/profiler.cpp +++ b/vm/profiler.cpp @@ -3,26 +3,27 @@ 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_); + gc_root 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; @@ -33,7 +34,7 @@ static void set_profiling(bool profiling) and allocate profiling blocks if necessary */ gc(); - gc_root words(find_all_words()); + gc_root words(find_all_words(),this); cell i; cell length = array_capacity(words.untagged()); @@ -46,12 +47,18 @@ static void set_profiling(bool profiling) } /* 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(); +} + } diff --git a/vm/profiler.hpp b/vm/profiler.hpp old mode 100644 new mode 100755 index b83ef3d354..28bfbcc09f --- a/vm/profiler.hpp +++ b/vm/profiler.hpp @@ -1,9 +1,6 @@ namespace factor { -extern bool profiling_p; -void init_profiler(); -code_block *compile_profiling_stub(cell word); PRIMITIVE(profiling); } diff --git a/vm/quotations.cpp b/vm/quotations.cpp old mode 100644 new mode 100755 index e96af39766..9c771129fc --- a/vm/quotations.cpp +++ b/vm/quotations.cpp @@ -40,7 +40,7 @@ bool quotation_jit::primitive_call_p(cell i) { return (i + 2) == array_capacity(elements.untagged()) && tagged(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) @@ -48,28 +48,28 @@ bool quotation_jit::fast_if_p(cell i) return (i + 3) == array_capacity(elements.untagged()) && tagged(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE) && tagged(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(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(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(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) @@ -78,7 +78,7 @@ bool quotation_jit::mega_lookup_p(cell i) && tagged(array_nth(elements.untagged(),i)).type_p(ARRAY_TYPE) && tagged(array_nth(elements.untagged(),i + 1)).type_p(FIXNUM_TYPE) && tagged(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() @@ -92,7 +92,7 @@ bool quotation_jit::stack_frame_p() switch(tagged(obj).type()) { case WORD_TYPE: - if(untag(obj)->subprimitive == F) + if(myvm->untag(obj)->subprimitive == F) return true; break; case QUOTATION_TYPE: @@ -115,7 +115,7 @@ void quotation_jit::iterate_quotation() set_position(0); if(stack_frame) - emit(userenv[JIT_PROLOG]); + emit(myvm->userenv[JIT_PROLOG]); cell i; cell length = array_capacity(elements.untagged()); @@ -125,7 +125,7 @@ void quotation_jit::iterate_quotation() { set_position(i); - gc_root obj(array_nth(elements.untagged(),i)); + gc_root obj(array_nth(elements.untagged(),i),myvm); switch(obj.type()) { @@ -134,23 +134,23 @@ void quotation_jit::iterate_quotation() if(obj.as()->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 @@ -160,8 +160,8 @@ void quotation_jit::iterate_quotation() 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()); } @@ -181,7 +181,7 @@ void quotation_jit::iterate_quotation() /* Primitive calls */ if(primitive_call_p(i)) { - emit_with(userenv[JIT_PRIMITIVE],obj.value()); + emit_with(myvm->userenv[JIT_PRIMITIVE],obj.value()); i++; @@ -193,18 +193,18 @@ void quotation_jit::iterate_quotation() 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; @@ -214,8 +214,8 @@ void quotation_jit::iterate_quotation() 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; } @@ -223,8 +223,8 @@ void quotation_jit::iterate_quotation() 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; } @@ -232,8 +232,8 @@ void quotation_jit::iterate_quotation() 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; } @@ -260,12 +260,12 @@ void quotation_jit::iterate_quotation() 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); @@ -275,12 +275,12 @@ void set_quot_xt(quotation *quot, code_block *code) } /* Allocates memory */ -void jit_compile(cell quot_, bool relocating) +void factorvm::jit_compile(cell quot_, bool relocating) { - gc_root quot(quot_); + gc_root 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(); @@ -289,13 +289,18 @@ void jit_compile(cell quot_, bool relocating) 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(sizeof(quotation)); quot->array = dpeek(); @@ -306,21 +311,31 @@ PRIMITIVE(array_to_quotation) drepl(tag(quot)); } -PRIMITIVE(quotation_xt) +PRIMITIVE(array_to_quotation) +{ + PRIMITIVE_GETVM()->vmprim_array_to_quotation(); +} + +inline void factorvm::vmprim_quotation_xt() { quotation *quot = untag_check(dpeek()); drepl(allot_cell((cell)quot->xt)); } -void compile_all_words() +PRIMITIVE(quotation_xt) { - gc_root words(find_all_words()); + PRIMITIVE_GETVM()->vmprim_quotation_xt(); +} + +void factorvm::compile_all_words() +{ + gc_root words(find_all_words(),this); cell i; cell length = array_capacity(words.untagged()); for(i = 0; i < length; i++) { - gc_root word(array_nth(words.untagged(),i)); + gc_root word(array_nth(words.untagged(),i),this); if(!word->code || !word_optimized_p(word.untagged())) jit_compile_word(word.value(),word->def,false); @@ -329,35 +344,46 @@ void compile_all_words() } - 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 quot(quot_); - gc_root array(quot->array); + gc_root quot(quot_,this); + gc_root 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 quot(quot_); + gc_root 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 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(); +} + } diff --git a/vm/quotations.hpp b/vm/quotations.hpp old mode 100644 new mode 100755 index c1a2a92bd1..ae24a522f9 --- a/vm/quotations.hpp +++ b/vm/quotations.hpp @@ -5,11 +5,11 @@ struct quotation_jit : public jit { gc_root elements; bool compiling, relocate; - quotation_jit(cell quot, bool compiling_, bool relocate_) - : jit(QUOTATION_TYPE,quot), - elements(owner.as().untagged()->array), + quotation_jit(cell quot, bool compiling_, bool relocate_, factorvm *vm) + : jit(QUOTATION_TYPE,quot,vm), + elements(owner.as().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); @@ -22,18 +22,12 @@ struct quotation_jit : public jit { 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); diff --git a/vm/run.cpp b/vm/run.cpp old mode 100644 new mode 100755 index c6a4bad695..1d670e3625 --- a/vm/run.cpp +++ b/vm/run.cpp @@ -1,41 +1,63 @@ #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(dpop()); @@ -45,7 +67,12 @@ PRIMITIVE(set_slot) 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); @@ -53,9 +80,14 @@ PRIMITIVE(load_locals) 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 obj(obj_); + gc_root obj(obj_,this); if(immediate_p(obj.value())) return obj.value(); @@ -68,9 +100,14 @@ static cell clone_object(cell obj_) } } -PRIMITIVE(clone) +inline void factorvm::vmprim_clone() { drepl(clone_object(dpeek())); } +PRIMITIVE(clone) +{ + PRIMITIVE_GETVM()->vmprim_clone(); +} + } diff --git a/vm/run.hpp b/vm/run.hpp old mode 100644 new mode 100755 index 7527889efb..d10a6678b8 --- a/vm/run.hpp +++ b/vm/run.hpp @@ -98,9 +98,6 @@ inline static bool save_env_p(cell i) return (i >= FIRST_SAVE_ENV && i <= LAST_SAVE_ENV) || i == STACK_TRACES_ENV; } -/* Canonical T object. It's just a word */ -extern cell T; - PRIMITIVE(getenv); PRIMITIVE(setenv); PRIMITIVE(exit); @@ -112,5 +109,4 @@ PRIMITIVE(clone); } -/* TAGGED user environment data; see getenv/setenv prims */ -VM_C_API factor::cell userenv[USER_ENV]; + diff --git a/vm/segments.hpp b/vm/segments.hpp index 36b5bc747b..a715b4dabc 100644 --- a/vm/segments.hpp +++ b/vm/segments.hpp @@ -7,9 +7,4 @@ struct segment { cell end; }; -inline static cell align_page(cell a) -{ - return align(a,getpagesize()); -} - } diff --git a/vm/stacks.hpp b/vm/stacks.hpp index bc1aac8154..4906d107bc 100644 --- a/vm/stacks.hpp +++ b/vm/stacks.hpp @@ -2,15 +2,15 @@ namespace factor { #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); \ diff --git a/vm/strings.cpp b/vm/strings.cpp index c70d9dfb6d..82db8430eb 100644 --- a/vm/strings.cpp +++ b/vm/strings.cpp @@ -3,7 +3,7 @@ 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 @@ -22,14 +22,16 @@ cell string_nth(string* str, cell index) } } -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 str(str_); + gc_root str(str_,this); byte_array *aux; @@ -54,8 +56,9 @@ void set_string_nth_slow(string *str_, cell index, cell ch) aux->data()[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); @@ -63,8 +66,9 @@ void set_string_nth(string *str, cell index, cell 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_size(capacity)); @@ -75,10 +79,11 @@ string *allot_string_internal(cell 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 str(str_); + gc_root str(str_,this); if(fill <= 0x7f) memset(&str->data()[start],fill,capacity - start); @@ -91,31 +96,39 @@ void fill_string(string *str_, cell start, cell capacity, cell fill) } } + /* Allocates memory */ -string *allot_string(cell capacity, cell fill) +string *factorvm::allot_string(cell capacity, cell fill) { - gc_root str(allot_string_internal(capacity)); + gc_root 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(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(str->aux))) && capacity <= string_capacity(str); } -string* reallot_string(string *str_, cell capacity) + +string* factorvm::reallot_string(string *str_, cell capacity) { - gc_root str(str_); + gc_root str(str_,this); if(reallot_string_in_place_p(str.untagged(),capacity)) { @@ -135,7 +148,7 @@ string* reallot_string(string *str_, cell capacity) if(capacity < to_copy) to_copy = capacity; - gc_root new_str(allot_string_internal(capacity)); + gc_root new_str(allot_string_internal(capacity),this); memcpy(new_str->data(),str->data(),to_copy); @@ -155,21 +168,32 @@ string* reallot_string(string *str_, cell capacity) } } -PRIMITIVE(resize_string) + +inline void factorvm::vmprim_resize_string() { string* str = untag_check(dpop()); cell capacity = unbox_array_size(); dpush(tag(reallot_string(str,capacity))); } -PRIMITIVE(string_nth) +PRIMITIVE(resize_string) +{ + PRIMITIVE_GETVM()->vmprim_resize_string(); +} + +inline void factorvm::vmprim_string_nth() { string *str = untag(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(dpop()); cell index = untag_fixnum(dpop()); @@ -177,7 +201,12 @@ PRIMITIVE(set_string_nth_fast) 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(dpop()); cell index = untag_fixnum(dpop()); @@ -185,4 +214,9 @@ PRIMITIVE(set_string_nth_slow) set_string_nth_slow(str,index,value); } +PRIMITIVE(set_string_nth_slow) +{ + PRIMITIVE_GETVM()->vmprim_set_string_nth_slow(); +} + } diff --git a/vm/strings.hpp b/vm/strings.hpp index 9a082b0b83..87beb9a0a8 100644 --- a/vm/strings.hpp +++ b/vm/strings.hpp @@ -11,16 +11,9 @@ inline static cell string_size(cell size) 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); diff --git a/vm/tagged.hpp b/vm/tagged.hpp old mode 100644 new mode 100755 index ea1942e10c..8eb492a140 --- a/vm/tagged.hpp +++ b/vm/tagged.hpp @@ -1,9 +1,9 @@ namespace factor { -template cell tag(T *value) +template 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) @@ -11,13 +11,13 @@ inline static cell tag_dynamic(object *value) return RETAG(value,tag_for(value->h.hi_tag())); } -template +template 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_); @@ -29,44 +29,44 @@ struct tagged 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& operator=(const T *x) { value_ = tag(x); return *this; } - const tagged& operator=(const cell &x) { value_ = x; return *this; } + const tagged& operator=(const TYPE *x) { value_ = tag(x); return *this; } + const tagged& operator=(const cell &x) { value_ = x; return *this; } - bool operator==(const tagged &x) { return value_ == x.value_; } - bool operator!=(const tagged &x) { return value_ != x.value_; } + bool operator==(const tagged &x) { return value_ == x.value_; } + bool operator!=(const tagged &x) { return value_ != x.value_; } template tagged as() { return tagged(value_); } }; -template T *untag_check(cell value) +template TYPE *factorvm::untag_check(cell value) { - return tagged(value).untag_check(); + return tagged(value).untag_check(this); } -template T *untag(cell value) +template TYPE *factorvm::untag(cell value) { - return tagged(value).untagged(); + return tagged(value).untagged(); } } diff --git a/vm/tuples.cpp b/vm/tuples.cpp index d7e22bb807..520bc55d4d 100644 --- a/vm/tuples.cpp +++ b/vm/tuples.cpp @@ -4,17 +4,17 @@ namespace factor { /* push a new tuple on the stack */ -tuple *allot_tuple(cell layout_) +tuple *factorvm::allot_tuple(cell layout_) { - gc_root layout(layout_); - gc_root t(allot(tuple_size(layout.untagged()))); + gc_root layout(layout_,this); + gc_root t(allot(tuple_size(layout.untagged())),this); t->layout = layout.value(); return t.untagged(); } -PRIMITIVE(tuple) +inline void factorvm::vmprim_tuple() { - gc_root layout(dpop()); + gc_root layout(dpop(),this); tuple *t = allot_tuple(layout.value()); fixnum i; for(i = tuple_size(layout.untagged()) - 1; i >= 0; i--) @@ -23,15 +23,25 @@ PRIMITIVE(tuple) dpush(tag(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 layout(dpop()); - gc_root t(allot_tuple(layout.value())); + gc_root layout(dpop(),this); + gc_root 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(); +} + } diff --git a/vm/utilities.cpp b/vm/utilities.cpp old mode 100644 new mode 100755 index 37fe28948e..94f010d050 --- a/vm/utilities.cpp +++ b/vm/utilities.cpp @@ -18,6 +18,7 @@ vm_char *safe_strdup(const vm_char *str) return ptr; } + /* We don't use printf directly, because format directives are not portable. Instead we define the common cases here. */ void nl() @@ -30,6 +31,7 @@ void print_string(const char *str) fputs(str,stdout); } + void print_cell(cell x) { printf(CELL_FORMAT,x); @@ -55,6 +57,6 @@ cell read_cell_hex() cell cell; if(scanf(CELL_HEX_FORMAT,&cell) < 0) exit(1); return cell; -}; +} } diff --git a/vm/utilities.hpp b/vm/utilities.hpp old mode 100644 new mode 100755 index 7e7765170e..68e0c97b25 --- a/vm/utilities.hpp +++ b/vm/utilities.hpp @@ -1,15 +1,12 @@ 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(); } diff --git a/vm/vm-data.hpp b/vm/vm-data.hpp new file mode 100644 index 0000000000..f5ecdc5f62 --- /dev/null +++ b/vm/vm-data.hpp @@ -0,0 +1,121 @@ +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 gc_locals; + std::vector 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 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 + } + +}; + +} diff --git a/vm/vm.hpp b/vm/vm.hpp new file mode 100644 index 0000000000..76a2adb9c6 --- /dev/null +++ b/vm/vm.hpp @@ -0,0 +1,659 @@ +#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 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 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 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 T *allot_array_internal(cell capacity); + template bool reallot_array_in_place_p(T *array, cell capacity); + template 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 T *untag_check(cell value); + template 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 &forwarding); + void compact_heap(heap *heap, unordered_map &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 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 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 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 + +} diff --git a/vm/words.cpp b/vm/words.cpp index fa090c9cea..f3c511efe9 100644 --- a/vm/words.cpp +++ b/vm/words.cpp @@ -3,12 +3,12 @@ namespace factor { -word *allot_word(cell vocab_, cell name_) +word *factorvm::allot_word(cell vocab_, cell name_) { - gc_root vocab(vocab_); - gc_root name(name_); + gc_root vocab(vocab_,this); + gc_root name(name_,this); - gc_root new_word(allot(sizeof(word))); + gc_root new_word(allot(sizeof(word)),this); new_word->hashcode = tag_fixnum((rand() << 16) ^ rand()); new_word->vocabulary = vocab.value(); @@ -32,15 +32,20 @@ word *allot_word(cell vocab_, cell name_) } /* ( name vocabulary -- word ) */ -PRIMITIVE(word) +inline void factorvm::vmprim_word() { cell vocab = dpop(); cell name = dpop(); dpush(tag(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(dpop()); code_block *code = (profiling_p ? w->profiling : w->code); @@ -48,10 +53,15 @@ PRIMITIVE(word_xt) 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 w(w_); + gc_root w(w_,this); if(profiling_p) { @@ -64,16 +74,26 @@ void update_word_xt(cell w_) w->xt = w->code->xt(); } -PRIMITIVE(optimized_p) +inline void factorvm::vmprim_optimized_p() { drepl(tag_boolean(word_optimized_p(untag_check(dpeek())))); } -PRIMITIVE(wrapper) +PRIMITIVE(optimized_p) +{ + PRIMITIVE_GETVM()->vmprim_optimized_p(); +} + +inline void factorvm::vmprim_wrapper() { wrapper *new_wrapper = allot(sizeof(wrapper)); new_wrapper->object = dpeek(); drepl(tag(new_wrapper)); } +PRIMITIVE(wrapper) +{ + PRIMITIVE_GETVM()->vmprim_wrapper(); +} + } diff --git a/vm/words.hpp b/vm/words.hpp index f9d5a7aff4..d3be2bde07 100644 --- a/vm/words.hpp +++ b/vm/words.hpp @@ -1,11 +1,8 @@ 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) { @@ -13,7 +10,6 @@ inline bool word_optimized_p(word *word) } PRIMITIVE(optimized_p); - PRIMITIVE(wrapper); } diff --git a/vm/write_barrier.cpp b/vm/write_barrier.cpp index 0e87434b56..72879aab4b 100644 --- a/vm/write_barrier.cpp +++ b/vm/write_barrier.cpp @@ -2,10 +2,4 @@ using namespace factor; -cell cards_offset; -cell decks_offset; -namespace factor -{ - cell allot_markers_offset; -} diff --git a/vm/write_barrier.hpp b/vm/write_barrier.hpp old mode 100644 new mode 100755 index 0006581034..7c0241a31a --- a/vm/write_barrier.hpp +++ b/vm/write_barrier.hpp @@ -6,9 +6,6 @@ card has a slot written to. 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 { @@ -22,65 +19,12 @@ static const cell card_bits = 8; static const cell card_size = (1<> 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) + 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); -} - }