diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor
index 8b0051148f..c0fafdc0f5 100644
--- a/basis/bootstrap/image/image.factor
+++ b/basis/bootstrap/image/image.factor
@@ -134,6 +134,7 @@ SYMBOL: jit-epilog
SYMBOL: jit-return
SYMBOL: jit-profiling
SYMBOL: jit-declare-word
+SYMBOL: jit-save-stack
! Default definition for undefined words
SYMBOL: undefined-quot
@@ -158,6 +159,7 @@ SYMBOL: undefined-quot
{ jit-profiling 35 }
{ jit-push-immediate 36 }
{ jit-declare-word 42 }
+ { jit-save-stack 43 }
{ undefined-quot 60 }
} at header-size + ;
@@ -459,6 +461,7 @@ M: quotation '
jit-return
jit-profiling
jit-declare-word
+ jit-save-stack
undefined-quot
} [ emit-userenv ] each ;
diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 77ed04f4b3..7bad44f7a6 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -190,7 +190,7 @@ M: #if emit-node
: emit-dispatch ( node -- )
##epilogue
- ds-pop ^^offset>slot i ##dispatch
+ ds-pop ^^offset>slot i 0 ##dispatch
dispatch-branches ;
: <dispatch-block> ( -- word )
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index c39f517671..b2c752e612 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -62,7 +62,7 @@ INSN: ##jump word ;
INSN: ##return ;
! Jump tables
-INSN: ##dispatch src temp ;
+INSN: ##dispatch src temp offset ;
INSN: ##dispatch-label label ;
! Slot access
diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index d397c9d448..7433df9617 100644
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -43,8 +43,8 @@ M: ##branch linearize-insn
: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
[ (binary-conditional) ]
- [ drop dup successors>> first useless-branch? ] 2bi
- [ [ number>> ] 3dip negate-cc ] [ [ swap number>> ] 3dip ] if ;
+ [ drop dup successors>> second useless-branch? ] 2bi
+ [ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ;
M: ##compare-branch linearize-insn
binary-conditional _compare-branch emit-branch ;
diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor
index 7f4b09e68f..158903b4bf 100644
--- a/basis/compiler/cfg/rpo/rpo.factor
+++ b/basis/compiler/cfg/rpo/rpo.factor
@@ -9,7 +9,10 @@ SYMBOL: visited
: post-order-traversal ( bb -- )
dup id>> visited get key? [ drop ] [
dup id>> visited get conjoin
- [ successors>> [ post-order-traversal ] each ] [ , ] bi
+ [
+ successors>> <reversed>
+ [ post-order-traversal ] each
+ ] [ , ] bi
] if ;
: post-order ( bb -- blocks )
diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
index 94c3f0d6f9..5f67f8097e 100644
--- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences layouts accessors combinators namespaces
-math
+math fry
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.simplify
@@ -113,4 +113,18 @@ M: ##compare-imm rewrite
] when
] when ;
+: dispatch-offset ( expr -- n )
+ [ in2>> vn>constant tag-bits get neg shift ] [ op>> ] bi
+ \ ##sub-imm eq? [ neg ] when ;
+
+: add-dispatch-offset? ( insn -- expr ? )
+ src>> vreg>expr dup op>> { ##add-imm ##sub-imm } memq? ; inline
+
+M: ##dispatch rewrite
+ dup add-dispatch-offset? [
+ [ clone ] dip
+ [ in1>> vn>vreg >>src ]
+ [ dispatch-offset '[ _ + ] change-offset ] bi
+ ] [ drop ] if ;
+
M: insn rewrite ;
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index d3be68c3c9..b73736ed14 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -34,7 +34,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ;
[ t ] [
{
T{ ##peek f V int-regs 1 D 0 }
- T{ ##dispatch f V int-regs 1 V int-regs 2 }
+ T{ ##dispatch f V int-regs 1 V int-regs 2 0 }
} dup value-numbering =
] unit-test
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 35d4d59253..0d45b28126 100644
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -93,7 +93,7 @@ M: ##return generate-insn drop %return ;
M: ##dispatch-label generate-insn label>> %dispatch-label ;
M: ##dispatch generate-insn
- [ src>> register ] [ temp>> register ] bi %dispatch ;
+ [ src>> register ] [ temp>> register ] [ offset>> ] tri %dispatch ;
: >slot<
{
diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor
index fe270f4410..b25f1fa8fe 100755
--- a/basis/compiler/codegen/fixup/fixup.factor
+++ b/basis/compiler/codegen/fixup/fixup.factor
@@ -72,8 +72,8 @@ SYMBOL: literal-table
: rel-this ( class -- )
0 swap rt-label rel-fixup ;
-: rel-here ( class -- )
- 0 swap rt-here rel-fixup ;
+: rel-here ( offset class -- )
+ rt-here rel-fixup ;
: init-fixup ( -- )
BV{ } clone relocation-table set
diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor
index cd68602768..86c1f65049 100644
--- a/basis/compiler/constants/constants.factor
+++ b/basis/compiler/constants/constants.factor
@@ -37,14 +37,15 @@ IN: compiler.constants
: rc-indirect-arm-pc 8 ; inline
! Relocation types
-: rt-primitive 0 ; inline
-: rt-dlsym 1 ; inline
-: rt-literal 2 ; inline
-: rt-dispatch 3 ; inline
-: rt-xt 4 ; inline
-: rt-here 5 ; inline
-: rt-label 6 ; inline
-: rt-immediate 7 ; inline
+: rt-primitive 0 ; inline
+: rt-dlsym 1 ; inline
+: rt-literal 2 ; inline
+: rt-dispatch 3 ; inline
+: rt-xt 4 ; inline
+: rt-here 5 ; inline
+: rt-label 6 ; inline
+: rt-immediate 7 ; inline
+: rt-stack-chain 8 ; inline
: rc-absolute? ( n -- ? )
[ rc-absolute-ppc-2/2 = ]
diff --git a/basis/compiler/tests/templates.factor b/basis/compiler/tests/codegen.factor
similarity index 95%
rename from basis/compiler/tests/templates.factor
rename to basis/compiler/tests/codegen.factor
index 0a109a15eb..a56ee55c82 100644
--- a/basis/compiler/tests/templates.factor
+++ b/basis/compiler/tests/codegen.factor
@@ -230,3 +230,14 @@ TUPLE: id obj ;
10000000 [ "hi" 0 (gc-check-bug) drop ] times ;
[ ] [ gc-check-bug ] unit-test
+
+! New optimization
+: test-1 ( a -- b ) 8 fixnum-fast { [ "a" ] [ "b" ] } dispatch ;
+
+[ "a" ] [ 8 test-1 ] unit-test
+[ "b" ] [ 9 test-1 ] unit-test
+
+: test-2 ( a -- b ) 1 fixnum-fast { [ "a" ] [ "b" ] } dispatch ;
+
+[ "a" ] [ 1 test-2 ] unit-test
+[ "b" ] [ 2 test-2 ] unit-test
diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor
index 19d80ec14f..c2ec6552cd 100644
--- a/basis/compiler/tree/builder/builder.factor
+++ b/basis/compiler/tree/builder/builder.factor
@@ -1,9 +1,13 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors quotations kernel sequences namespaces
-assocs words arrays vectors hints combinators stack-checker
-stack-checker.state stack-checker.visitor stack-checker.errors
-stack-checker.backend compiler.tree ;
+assocs words arrays vectors hints combinators compiler.tree
+stack-checker
+stack-checker.state
+stack-checker.errors
+stack-checker.visitor
+stack-checker.backend
+stack-checker.recursive-state ;
IN: compiler.tree.builder
: with-tree-builder ( quot -- nodes )
@@ -12,12 +16,13 @@ IN: compiler.tree.builder
: build-tree ( quot -- nodes )
#! Not safe to call from inference transforms.
- [ f infer-quot ] with-tree-builder nip ;
+ [ f initial-recursive-state infer-quot ] with-tree-builder nip ;
: build-tree-with ( in-stack quot -- nodes out-stack )
#! Not safe to call from inference transforms.
[
- [ >vector meta-d set ] [ f infer-quot ] bi*
+ [ >vector meta-d set ]
+ [ f initial-recursive-state infer-quot ] bi*
] with-tree-builder nip
unclip-last in-d>> ;
@@ -32,10 +37,10 @@ IN: compiler.tree.builder
dup
[ "inline" word-prop ]
[ "recursive" word-prop ] bi and [
- 1quotation f infer-quot
+ 1quotation f initial-recursive-state infer-quot
] [
- [ specialized-def ]
- [ dup 2array 1array ] bi infer-quot
+ [ specialized-def ] [ initial-recursive-state ] bi
+ infer-quot
] if ;
: check-cannot-infer ( word -- )
diff --git a/basis/compiler/tree/escape-analysis/allocations/allocations.factor b/basis/compiler/tree/escape-analysis/allocations/allocations.factor
index 4c197d7fc0..5d34eaad15 100644
--- a/basis/compiler/tree/escape-analysis/allocations/allocations.factor
+++ b/basis/compiler/tree/escape-analysis/allocations/allocations.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs namespaces sequences kernel math
-combinators sets disjoint-sets fry stack-checker.state ;
+combinators sets disjoint-sets fry stack-checker.values ;
IN: compiler.tree.escape-analysis.allocations
! A map from values to one of the following:
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index b0b5b048d9..96dd577c10 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -50,7 +50,7 @@ HOOK: %call cpu ( word -- )
HOOK: %jump-label cpu ( label -- )
HOOK: %return cpu ( -- )
-HOOK: %dispatch cpu ( src temp -- )
+HOOK: %dispatch cpu ( src temp offset -- )
HOOK: %dispatch-label cpu ( word -- )
HOOK: %slot cpu ( dst obj slot tag temp -- )
diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor
index 9bf88185c5..aee0f3f4f3 100644
--- a/basis/cpu/ppc/bootstrap.factor
+++ b/basis/cpu/ppc/bootstrap.factor
@@ -57,7 +57,12 @@ big-endian on
[
0 6 LOAD32
- 4 1 MR
+ 7 6 0 LWZ
+ 1 7 0 STW
+] rc-absolute-ppc-2/2 rt-stack-chain 1 jit-save-stack jit-define
+
+[
+ 0 6 LOAD32
6 MTCTR
BCTR
] rc-absolute-ppc-2/2 rt-primitive 1 jit-primitive jit-define
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index 49caae4bb8..1bc8d6975d 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -111,10 +111,10 @@ M: ppc %call ( label -- ) BL ;
M: ppc %jump-label ( label -- ) B ;
M: ppc %return ( -- ) BLR ;
-M:: ppc %dispatch ( src temp -- )
+M:: ppc %dispatch ( src temp offset -- )
0 temp LOAD32 rc-absolute-ppc-2/2 rel-here
temp temp src ADD
- temp temp 5 cells LWZ
+ temp temp 5 offset + cells LWZ
temp MTCTR
BCTR ;
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index f26d76551a..f892271fd5 100644
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -6,7 +6,7 @@ accessors init combinators command-line cpu.x86.assembler
cpu.x86 cpu.architecture compiler compiler.units
compiler.constants compiler.alien compiler.codegen
compiler.codegen.fixup compiler.cfg.instructions
-compiler.cfg.builder compiler.cfg.intrinsics ;
+compiler.cfg.builder compiler.cfg.intrinsics make ;
IN: cpu.x86.32
! We implement the FFI for Linux, OS X and Windows all at once.
@@ -26,6 +26,18 @@ M: x86.32 stack-reg ESP ;
M: x86.32 temp-reg-1 EAX ;
M: x86.32 temp-reg-2 ECX ;
+M:: x86.32 %dispatch ( src temp offset -- )
+ ! Load jump table base.
+ src HEX: ffffffff ADD
+ offset cells rc-absolute-cell rel-here
+ ! Go
+ src HEX: 7f [+] JMP
+ ! Fix up the displacement above
+ cell code-alignment
+ [ 7 + building get dup pop* push ]
+ [ align-code ]
+ bi ;
+
M: x86.32 reserved-area-size 0 ;
M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor
index 44f840e66a..ba963ab477 100644
--- a/basis/cpu/x86/32/bootstrap.factor
+++ b/basis/cpu/x86/32/bootstrap.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
-cpu.x86.assembler layouts vocabs parser ;
+cpu.x86.assembler layouts vocabs parser compiler.constants ;
IN: bootstrap.x86
4 \ cell set
@@ -19,5 +19,14 @@ IN: bootstrap.x86
: fixnum>slot@ ( -- ) arg0 1 SAR ;
: rex-length ( -- n ) 0 ;
+[
+ arg0 0 [] MOV ! load stack_chain
+ arg0 [] stack-reg MOV ! save stack pointer
+] rc-absolute-cell rt-stack-chain 2 jit-save-stack jit-define
+
+[
+ (JMP) drop
+] rc-relative rt-primitive 1 jit-primitive jit-define
+
<< "resource:basis/cpu/x86/bootstrap.factor" parse-file parsed >>
call
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 0d20660021..75c808b50a 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math namespaces make sequences
system layouts alien alien.c-types alien.accessors alien.structs
-slots splitting assocs combinators cpu.x86.assembler
+slots splitting assocs combinators make locals cpu.x86.assembler
cpu.x86 cpu.architecture compiler.constants
compiler.codegen compiler.codegen.fixup
compiler.cfg.instructions compiler.cfg.builder
@@ -24,6 +24,19 @@ M: x86.64 stack-reg RSP ;
M: x86.64 temp-reg-1 RAX ;
M: x86.64 temp-reg-2 RCX ;
+M:: x86.64 %dispatch ( src temp offset -- )
+ ! Load jump table base.
+ temp HEX: ffffffff MOV
+ offset cells rc-absolute-cell rel-here
+ ! Add jump table base
+ src temp ADD
+ src HEX: 7f [+] JMP
+ ! Fix up the displacement above
+ cell code-alignment
+ [ 15 + building get dup pop* push ]
+ [ align-code ]
+ bi ;
+
: param-reg-1 int-regs param-regs first ; inline
: param-reg-2 int-regs param-regs second ; inline
: param-reg-3 int-regs param-regs third ; inline
diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor
index acac8b55bc..83a72d6dd3 100644
--- a/basis/cpu/x86/64/bootstrap.factor
+++ b/basis/cpu/x86/64/bootstrap.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
-cpu.x86.assembler layouts vocabs parser ;
+cpu.x86.assembler layouts vocabs parser compiler.constants math ;
IN: bootstrap.x86
8 \ cell set
@@ -16,5 +16,16 @@ IN: bootstrap.x86
: fixnum>slot@ ( -- ) ;
: rex-length ( -- n ) 1 ;
+[
+ arg0 0 MOV ! load stack_chain
+ arg0 arg0 [] MOV
+ arg0 [] stack-reg MOV ! save stack pointer
+] rc-absolute-cell rt-stack-chain 1 rex-length + jit-save-stack jit-define
+
+[
+ arg1 0 MOV ! load XT
+ arg1 JMP ! go
+] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define
+
<< "resource:basis/cpu/x86/bootstrap.factor" parse-file parsed >>
call
diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor
index 6dadbc096c..1ee74a434b 100644
--- a/basis/cpu/x86/bootstrap.factor
+++ b/basis/cpu/x86/bootstrap.factor
@@ -44,12 +44,6 @@ big-endian off
ds-reg [] arg0 MOV ! store literal on datastack
] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define
-[
- arg0 0 MOV ! load XT
- arg1 stack-reg MOV ! pass callstack pointer as arg 2
- arg0 JMP ! go
-] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define
-
[
(JMP) drop
] rc-relative rt-xt 1 jit-word-jump jit-define
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index 4f72fe45e1..dfe3d3e55e 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -60,19 +60,6 @@ M: x86 %return ( -- ) 0 RET ;
: align-code ( n -- )
0 <repetition> % ;
-M:: x86 %dispatch ( src temp -- )
- ! Load jump table base. We use a temporary register
- ! since on AMD64 we have to load a 64-bit immediate. On
- ! x86, this is redundant.
- ! Add jump table base
- temp HEX: ffffffff MOV rc-absolute-cell rel-here
- src temp ADD
- src HEX: 7f [+] JMP
- ! Fix up the displacement above
- cell code-alignment dup bootstrap-cell 8 = 15 9 ? +
- building get dup pop* push
- align-code ;
-
M: x86 %dispatch-label ( word -- )
0 cell, rc-absolute-cell rel-word ;
diff --git a/basis/macros/expander/expander.factor b/basis/macros/expander/expander.factor
index c2fceffae6..3666fa2423 100644
--- a/basis/macros/expander/expander.factor
+++ b/basis/macros/expander/expander.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private namespaces make
quotations accessors words continuations vectors effects math
-generalizations stack-checker.transforms fry ;
+generalizations fry ;
IN: macros.expander
GENERIC: expand-macros ( quot -- quot' )
diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor
index 0a6621f044..794d523d00 100644
--- a/basis/macros/macros.factor
+++ b/basis/macros/macros.factor
@@ -1,21 +1,18 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: parser kernel sequences words effects
-stack-checker.transforms combinators assocs definitions
-quotations namespaces memoize accessors ;
+USING: parser kernel sequences words effects combinators assocs
+definitions quotations namespaces memoize accessors ;
IN: macros
: real-macro-effect ( word -- effect' )
"declared-effect" word-prop in>> 1 <effect> ;
: define-macro ( word definition -- )
- over "declared-effect" word-prop in>> length >r
- 2dup "macro" set-word-prop
- 2dup over real-macro-effect memoize-quot [ call ] append define
- r> define-transform ;
+ [ "macro" set-word-prop ]
+ [ over real-macro-effect memoize-quot [ call ] append define ]
+ 2bi ;
-: MACRO:
- (:) define-macro ; parsing
+: MACRO: (:) define-macro ; parsing
PREDICATE: macro < word "macro" word-prop >boolean ;
diff --git a/basis/persistent/hashtables/hashtables.factor b/basis/persistent/hashtables/hashtables.factor
index a867dbb2e3..e50fd52c10 100644
--- a/basis/persistent/hashtables/hashtables.factor
+++ b/basis/persistent/hashtables/hashtables.factor
@@ -53,3 +53,6 @@ M: persistent-hash clone ;
M: persistent-hash pprint-delims drop \ PH{ \ } ;
M: persistent-hash >pprint-sequence >alist ;
M: persistent-hash pprint* pprint-object ;
+
+: passociate ( value key -- phash )
+ T{ persistent-hash } new-at ; inline
diff --git a/basis/persistent/sequences/sequences.factor b/basis/persistent/sequences/sequences.factor
index 961e8bfce7..5503e369b4 100644
--- a/basis/persistent/sequences/sequences.factor
+++ b/basis/persistent/sequences/sequences.factor
@@ -14,3 +14,6 @@ M: sequence ppop 1 head* ;
GENERIC: new-nth ( val i seq -- seq' )
M: sequence new-nth clone [ set-nth ] keep ;
+
+: changed-nth ( i seq quot -- seq' )
+ [ [ nth ] dip call ] [ drop new-nth ] 3bi ; inline
diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor
index aadd1adbd4..94e59950f7 100644
--- a/basis/stack-checker/backend/backend.factor
+++ b/basis/stack-checker/backend/backend.factor
@@ -5,7 +5,8 @@ namespaces parser prettyprint sequences strings vectors words
quotations effects classes continuations debugger assocs
combinators compiler.errors accessors math.order definitions
sets generic.standard.engines.tuple stack-checker.state
-stack-checker.visitor stack-checker.errors ;
+stack-checker.visitor stack-checker.errors
+stack-checker.values stack-checker.recursive-state ;
IN: stack-checker.backend
: push-d ( obj -- ) meta-d get push ;
@@ -82,9 +83,6 @@ M: object apply-object push-literal ;
infer-quot-here
] dip recursive-state set ;
-: infer-quot-recursive ( quot word label -- )
- 2array recursive-state get swap prefix infer-quot ;
-
: time-bomb ( error -- )
'[ _ throw ] infer-quot-here ;
@@ -97,7 +95,7 @@ M: object apply-object push-literal ;
] [
dup value>> callable? [
[ value>> ]
- [ [ recursion>> ] keep f 2array prefix ]
+ [ [ recursion>> ] keep add-local-quotation ]
bi infer-quot
] [
drop bad-call
@@ -126,6 +124,9 @@ M: object apply-object push-literal ;
terminated?>> [ terminate ] when
] 2bi ; inline
+: infer-word-def ( word -- )
+ [ def>> ] [ add-recursive-state ] bi infer-quot ;
+
: check->r ( -- )
meta-r get empty? terminated? get or
[ \ too-many->r inference-error ] unless ;
@@ -174,7 +175,7 @@ M: object apply-object push-literal ;
stack-visitor off
dependencies off
generic-dependencies off
- [ [ def>> ] [ ] [ ] tri infer-quot-recursive end-infer ]
+ [ infer-word-def end-infer ]
[ finish-word current-effect ]
bi
] with-scope
diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor
index d1417d035c..7b461d0028 100644
--- a/basis/stack-checker/branches/branches.factor
+++ b/basis/stack-checker/branches/branches.factor
@@ -3,7 +3,7 @@
USING: fry vectors sequences assocs math accessors kernel
combinators quotations namespaces stack-checker.state
stack-checker.backend stack-checker.errors stack-checker.visitor
-;
+stack-checker.values stack-checker.recursive-state ;
IN: stack-checker.branches
: balanced? ( pairs -- ? )
diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor
index bab6c17c85..efdc7e23b2 100644
--- a/basis/stack-checker/errors/errors.factor
+++ b/basis/stack-checker/errors/errors.factor
@@ -2,12 +2,11 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel generic sequences prettyprint io words arrays
summary effects debugger assocs accessors namespaces
-compiler.errors ;
+compiler.errors stack-checker.values
+stack-checker.recursive-state ;
IN: stack-checker.errors
-SYMBOL: recursive-state
-
-TUPLE: inference-error error type rstate ;
+TUPLE: inference-error error type word ;
M: inference-error compiler-error-type type>> ;
@@ -15,7 +14,7 @@ M: inference-error error-help error>> error-help ;
: (inference-error) ( ... class type -- * )
>r boa r>
- recursive-state get
+ recursive-state get word>>
\ inference-error boa throw ; inline
: inference-error ( ... class -- * )
@@ -25,16 +24,15 @@ M: inference-error error-help error>> error-help ;
+warning+ (inference-error) ; inline
M: inference-error error.
- [
- rstate>>
- [ "Nesting:" print stack. ] unless-empty
- ] [ error>> error. ] bi ;
+ [ "In word: " write word>> . ] [ error>> error. ] bi ;
TUPLE: literal-expected ;
M: literal-expected summary
drop "Literal value expected" ;
+M: object (literal) \ literal-expected inference-warning ;
+
TUPLE: unbalanced-branches-error branches quots ;
: unbalanced-branches-error ( branches quots -- * )
diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor
index 7847fdfdcf..b6a988652b 100644
--- a/basis/stack-checker/inlining/inlining.factor
+++ b/basis/stack-checker/inlining/inlining.factor
@@ -4,18 +4,20 @@ USING: fry namespaces assocs kernel sequences words accessors
definitions math math.order effects classes arrays combinators
vectors arrays
stack-checker.state
+stack-checker.errors
+stack-checker.values
stack-checker.visitor
stack-checker.backend
stack-checker.branches
-stack-checker.errors
-stack-checker.known-words ;
+stack-checker.known-words
+stack-checker.recursive-state ;
IN: stack-checker.inlining
! Code to handle inline words. Much of the complexity stems from
! having to handle recursive inline words.
-: (inline-word) ( word label -- )
- [ [ def>> ] keep ] dip infer-quot-recursive ;
+: infer-inline-word-def ( word label -- )
+ [ drop def>> ] [ add-inline-word ] 2bi infer-quot ;
TUPLE: inline-recursive < identity-tuple
id
@@ -88,7 +90,7 @@ SYMBOL: enter-out
nest-visitor
dup <inline-recursive>
- [ dup emit-enter-recursive (inline-word) ]
+ [ dup emit-enter-recursive infer-inline-word-def ]
[ end-recursive-word ]
[ nip ]
2tri
@@ -133,20 +135,23 @@ SYMBOL: enter-out
object <repetition> '[ _ prepend ] bi@
<effect> ;
-: call-recursive-inline-word ( word -- )
- dup "recursive" word-prop [
- [ required-stack-effect adjust-stack-effect ] [ ] [ recursive-label ] tri
- [ 2nip check-call ] [ nip '[ _ #call-recursive, ] consume/produce ] 3bi
- ] [ undeclared-recursion-error inference-error ] if ;
+: call-recursive-inline-word ( word label -- )
+ over "recursive" word-prop [
+ [ required-stack-effect adjust-stack-effect ] dip
+ [ check-call ] [ '[ _ #call-recursive, ] consume/produce ] bi
+ ] [ drop undeclared-recursion-error inference-error ] if ;
: inline-word ( word -- )
[ inlined-dependency depends-on ]
[
- {
- { [ dup inline-recursive-label ] [ call-recursive-inline-word ] }
- { [ dup "recursive" word-prop ] [ inline-recursive-word ] }
- [ dup (inline-word) ]
- } cond
+ dup inline-recursive-label [
+ call-recursive-inline-word
+ ] [
+ dup "recursive" word-prop
+ [ inline-recursive-word ]
+ [ dup infer-inline-word-def ]
+ if
+ ] if*
] bi ;
M: word apply-object
diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index 257181f6ad..4aea0f2d28 100644
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -11,14 +11,15 @@ strings.private system threads.private classes.tuple
classes.tuple.private vectors vectors.private words definitions
words.private assocs summary compiler.units system.private
combinators locals locals.backend locals.private words.private
-quotations.private
+quotations.private stack-checker.values
+stack-checker.alien
stack-checker.state
+stack-checker.errors
+stack-checker.visitor
stack-checker.backend
stack-checker.branches
-stack-checker.errors
stack-checker.transforms
-stack-checker.visitor
-stack-checker.alien ;
+stack-checker.recursive-state ;
IN: stack-checker.known-words
: infer-primitive ( word -- )
@@ -195,7 +196,7 @@ do-primitive alien-invoke alien-indirect alien-callback
{ [ dup local? ] [ infer-local-reader ] }
{ [ dup local-reader? ] [ infer-local-reader ] }
{ [ dup local-writer? ] [ infer-local-writer ] }
- { [ dup recursive-label ] [ call-recursive-word ] }
+ { [ dup recursive-word? ] [ call-recursive-word ] }
[ dup infer-word apply-word/effect ]
} cond ;
diff --git a/basis/stack-checker/recursive-state/recursive-state.factor b/basis/stack-checker/recursive-state/recursive-state.factor
new file mode 100644
index 0000000000..41d7331230
--- /dev/null
+++ b/basis/stack-checker/recursive-state/recursive-state.factor
@@ -0,0 +1,43 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays sequences kernel sequences assocs
+namespaces stack-checker.recursive-state.tree ;
+IN: stack-checker.recursive-state
+
+TUPLE: recursive-state words word quotations inline-words ;
+
+C: <recursive-state> recursive-state
+
+: prepare-recursive-state ( word rstate -- rstate )
+ swap >>word
+ f >>quotations
+ f >>inline-words ; inline
+
+: initial-recursive-state ( word -- state )
+ recursive-state new
+ f >>words
+ prepare-recursive-state ; inline
+
+f initial-recursive-state recursive-state set-global
+
+: add-recursive-state ( word -- rstate )
+ recursive-state get clone
+ [ word>> dup ] keep [ store ] change-words
+ prepare-recursive-state ;
+
+: add-local-quotation ( recursive-state quot -- rstate )
+ swap clone [ dupd store ] change-quotations ;
+
+: add-inline-word ( word label -- rstate )
+ swap recursive-state get clone
+ [ store ] change-inline-words ;
+
+: recursive-word? ( word -- ? )
+ recursive-state get 2dup word>> eq?
+ [ 2drop t ] [ words>> lookup ] if ;
+
+: inline-recursive-label ( word -- label/f )
+ recursive-state get inline-words>> lookup ;
+
+: recursive-quotation? ( quot -- ? )
+ recursive-state get quotations>> lookup ;
diff --git a/basis/stack-checker/recursive-state/tree/tree.factor b/basis/stack-checker/recursive-state/tree/tree.factor
new file mode 100644
index 0000000000..dd392af7c9
--- /dev/null
+++ b/basis/stack-checker/recursive-state/tree/tree.factor
@@ -0,0 +1,31 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences math math.order ;
+IN: stack-checker.recursive-state.tree
+
+! Persistent unbalanced hash tree using eq? comparison.
+! We use this to speed up stack-checker.recursive-state.
+! Perhaps this should go somewhere else
+
+TUPLE: node value key hashcode left right ;
+
+GENERIC: lookup ( key node -- value/f )
+
+M: f lookup nip ;
+
+: decide ( key node -- key node ? )
+ over hashcode over hashcode>> <= ; inline
+
+M: node lookup
+ 2dup key>> eq?
+ [ nip value>> ]
+ [ decide [ left>> ] [ right>> ] if lookup ] if ;
+
+GENERIC: store ( value key node -- node' )
+
+M: f store drop dup hashcode f f node boa ;
+
+M: node store
+ clone decide
+ [ [ store ] change-left ]
+ [ [ store ] change-right ] if ;
diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor
index 11dc6f9ef8..2706ec60ef 100644
--- a/basis/stack-checker/state/state.factor
+++ b/basis/stack-checker/state/state.factor
@@ -1,48 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs namespaces sequences kernel definitions math
-effects accessors words fry classes.algebra stack-checker.errors
+USING: assocs arrays namespaces sequences kernel definitions
+math effects accessors words fry classes.algebra
compiler.units ;
IN: stack-checker.state
-: <value> ( -- value ) \ <value> counter ;
-
-SYMBOL: known-values
-
-: known ( value -- known ) known-values get at ;
-
-: set-known ( known value -- )
- over [ known-values get set-at ] [ 2drop ] if ;
-
-: make-known ( known -- value )
- <value> [ set-known ] keep ;
-
-: copy-value ( value -- value' )
- known make-known ;
-
-: copy-values ( values -- values' )
- [ copy-value ] map ;
-
-! Literal value
-TUPLE: literal < identity-tuple value recursion ;
-
-: <literal> ( obj -- value )
- recursive-state get \ literal boa ;
-
-: literal ( value -- literal )
- known dup literal?
- [ \ literal-expected inference-warning ] unless ;
-
-! Result of curry
-TUPLE: curried obj quot ;
-
-C: <curried> curried
-
-! Result of compose
-TUPLE: composed quot1 quot2 ;
-
-C: <composed> composed
-
! Did the current control-flow path throw an error?
SYMBOL: terminated?
@@ -68,23 +30,6 @@ SYMBOL: meta-r
V{ } clone meta-r set
0 d-in set ;
-: init-known-values ( -- )
- H{ } clone known-values set ;
-
-: recursive-label ( word -- label/f )
- recursive-state get at ;
-
-: local-recursive-state ( -- assoc )
- recursive-state get dup
- [ first dup word? [ inline? ] when not ] find drop
- [ head-slice ] when* ;
-
-: inline-recursive-label ( word -- label/f )
- local-recursive-state at ;
-
-: recursive-quotation? ( quot -- ? )
- local-recursive-state [ first eq? ] with contains? ;
-
! Words that the current quotation depends on
SYMBOL: dependencies
@@ -98,9 +43,12 @@ SYMBOL: dependencies
! Generic words that the current quotation depends on
SYMBOL: generic-dependencies
+: ?class-or ( class/f class -- class' )
+ swap [ class-or ] when* ;
+
: depends-on-generic ( generic class -- )
generic-dependencies get dup
- [ swap '[ null or _ class-or ] change-at ] [ 3drop ] if ;
+ [ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ;
! Words we've inferred the stack effect of, for rollback
SYMBOL: recorded
diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor
index abc3ae1950..e4f8c50eeb 100644
--- a/basis/stack-checker/transforms/transforms.factor
+++ b/basis/stack-checker/transforms/transforms.factor
@@ -5,11 +5,12 @@ namespaces make quotations assocs combinators classes.tuple
classes.tuple.private effects summary hashtables classes generic
sets definitions generic.standard slots.private continuations
stack-checker.backend stack-checker.state stack-checker.visitor
-stack-checker.errors ;
+stack-checker.errors stack-checker.values
+stack-checker.recursive-state ;
IN: stack-checker.transforms
: give-up-transform ( word -- )
- dup recursive-label
+ dup recursive-word?
[ call-recursive-word ]
[ dup infer-word apply-word/effect ]
if ;
diff --git a/basis/stack-checker/values/values.factor b/basis/stack-checker/values/values.factor
new file mode 100644
index 0000000000..97aa774e55
--- /dev/null
+++ b/basis/stack-checker/values/values.factor
@@ -0,0 +1,52 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors namespaces kernel assocs sequences
+stack-checker.recursive-state ;
+IN: stack-checker.values
+
+! Values
+: <value> ( -- value ) \ <value> counter ;
+
+SYMBOL: known-values
+
+: init-known-values ( -- )
+ H{ } clone known-values set ;
+
+: known ( value -- known ) known-values get at ;
+
+: set-known ( known value -- )
+ over [ known-values get set-at ] [ 2drop ] if ;
+
+: make-known ( known -- value )
+ <value> [ set-known ] keep ;
+
+: copy-value ( value -- value' )
+ known make-known ;
+
+: copy-values ( values -- values' )
+ [ copy-value ] map ;
+
+! Literal value
+TUPLE: literal < identity-tuple value recursion hashcode ;
+
+M: literal hashcode* nip hashcode>> ;
+
+: <literal> ( obj -- value )
+ recursive-state get over hashcode \ literal boa ;
+
+GENERIC: (literal) ( value -- literal )
+
+M: literal (literal) ;
+
+: literal ( value -- literal )
+ known (literal) ;
+
+! Result of curry
+TUPLE: curried obj quot ;
+
+C: <curried> curried
+
+! Result of compose
+TUPLE: composed quot1 quot2 ;
+
+C: <composed> composed
diff --git a/basis/vlists/vlists-tests.factor b/basis/vlists/vlists-tests.factor
new file mode 100644
index 0000000000..3546051364
--- /dev/null
+++ b/basis/vlists/vlists-tests.factor
@@ -0,0 +1,41 @@
+USING: vlists kernel persistent.sequences arrays tools.test
+namespaces accessors sequences assocs ;
+IN: vlists.tests
+
+[ { "hi" "there" } ]
+[ VL{ } "hi" swap ppush "there" swap ppush >array ] unit-test
+
+[ VL{ "hi" "there" "foo" } VL{ "hi" "there" "bar" } t ]
+[
+ VL{ } "hi" swap ppush "there" swap ppush "v" set
+ "foo" "v" get ppush
+ "bar" "v" get ppush
+ dup "baz" over ppush [ vector>> ] bi@ eq?
+] unit-test
+
+[ "foo" VL{ "hi" "there" } t ]
+[
+ VL{ "hi" "there" "foo" } dup "v" set
+ [ peek ] [ ppop ] bi
+ dup "v" get [ vector>> ] bi@ eq?
+] unit-test
+
+[ VL{ } 3 over push ] must-fail
+
+[ 4 VL{ "hi" } set-first ] must-fail
+
+[ 5 t ] [
+ "rice" VA{ { "rice" 5 } { "beans" 10 } } at*
+] unit-test
+
+[ 6 t ] [
+ "rice" VA{ { "rice" 5 } { "beans" 10 } { "rice" 6 } } at*
+] unit-test
+
+[ 3 ] [
+ VA{ { "rice" 5 } { "beans" 10 } { "rice" 6 } } assoc-size
+] unit-test
+
+[ f f ] [
+ "meat" VA{ { "rice" 5 } { "beans" 10 } { "rice" 6 } } at*
+] unit-test
diff --git a/basis/vlists/vlists.factor b/basis/vlists/vlists.factor
new file mode 100644
index 0000000000..e0f7e55554
--- /dev/null
+++ b/basis/vlists/vlists.factor
@@ -0,0 +1,93 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays accessors sequences sequences.private
+persistent.sequences assocs persistent.assocs kernel math
+vectors parser prettyprint.backend ;
+IN: vlists
+
+TUPLE: vlist
+{ length array-capacity read-only }
+{ vector vector read-only } ;
+
+: <vlist> ( -- vlist ) 0 V{ } clone vlist boa ; inline
+
+M: vlist length length>> ;
+
+M: vlist nth-unsafe vector>> nth-unsafe ;
+
+<PRIVATE
+
+: >vlist< [ length>> ] [ vector>> ] bi ; inline
+
+: unshare ( len vec -- len vec' )
+ clone [ set-length ] 2keep ; inline
+
+PRIVATE>
+
+M: vlist ppush
+ >vlist<
+ 2dup length = [ unshare ] unless
+ [ [ 1+ swap ] dip push ] keep vlist boa ;
+
+ERROR: empty-vlist-error ;
+
+M: vlist ppop
+ [ empty-vlist-error ]
+ [ [ length>> 1- ] [ vector>> ] bi vlist boa ] if-empty ;
+
+M: vlist clone
+ [ length>> ] [ vector>> >vector ] bi vlist boa ;
+
+M: vlist equal?
+ over vlist? [ sequence= ] [ 2drop f ] if ;
+
+: >vlist ( seq -- vlist )
+ [ length ] [ >vector ] bi vlist boa ; inline
+
+M: vlist like
+ drop dup vlist? [ >vlist ] unless ;
+
+INSTANCE: vlist immutable-sequence
+
+: VL{ \ } [ >vlist ] parse-literal ; parsing
+
+M: vlist pprint-delims drop \ VL{ \ } ;
+M: vlist >pprint-sequence ;
+M: vlist pprint* pprint-object ;
+
+TUPLE: valist { vlist vlist read-only } ;
+
+: <valist> ( -- valist ) <vlist> valist boa ; inline
+
+M: valist assoc-size vlist>> length 2/ ;
+
+: valist-at ( key i array -- value ? )
+ over 0 >= [
+ 3dup nth-unsafe = [
+ [ 1+ ] dip nth-unsafe nip t
+ ] [
+ [ 2 - ] dip valist-at
+ ] if
+ ] [ 3drop f f ] if ; inline recursive
+
+M: valist at*
+ vlist>> >vlist< [ 2 - ] [ underlying>> ] bi* valist-at ;
+
+M: valist new-at
+ vlist>> ppush ppush valist boa ;
+
+M: valist >alist vlist>> ;
+
+: >valist ( assoc -- valist )
+ >alist concat >vlist valist boa ; inline
+
+M: valist assoc-like
+ drop dup valist? [ >valist ] unless ;
+
+INSTANCE: valist assoc
+
+: VA{ \ } [ >valist ] parse-literal ; parsing
+
+M: valist pprint-delims drop \ VA{ \ } ;
+M: valist >pprint-sequence >alist ;
+M: valist pprint* pprint-object ;
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index 077795c4b7..ebe1c08cb3 100644
--- a/core/generic/math/math.factor
+++ b/core/generic/math/math.factor
@@ -3,7 +3,7 @@
USING: arrays generic hashtables kernel kernel.private math
namespaces make sequences words quotations layouts combinators
sequences.private classes classes.builtin classes.algebra
-definitions math.order ;
+definitions math.order math.private ;
IN: generic.math
PREDICATE: math-class < class
@@ -62,13 +62,17 @@ ERROR: no-math-method left right generic ;
2drop object-method
] if ;
+SYMBOL: picker
+
: math-vtable ( picker quot -- quot )
[
- >r
- , \ tag ,
- num-tags get [ bootstrap-type>class ]
- r> compose map ,
- \ dispatch ,
+ swap picker set
+ picker get , [ tag 0 eq? ] %
+ num-tags get swap [ bootstrap-type>class ] prepose map
+ unclip ,
+ [
+ picker get , [ tag 1 fixnum-fast ] % , \ dispatch ,
+ ] [ ] make , \ if ,
] [ ] make ; inline
TUPLE: math-combination ;
@@ -85,8 +89,7 @@ M: math-combination perform-combination
] [
over object-method
] if nip
- ] math-vtable nip
- define ;
+ ] math-vtable nip define ;
PREDICATE: math-generic < generic ( word -- ? )
"combination" word-prop math-combination? ;
diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor
index 87e2f1c9b1..d1bc6d7417 100644
--- a/core/generic/standard/engines/tag/tag.factor
+++ b/core/generic/standard/engines/tag/tag.factor
@@ -22,13 +22,14 @@ C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
"type" word-prop
] if ;
+: sort-tags ( assoc -- alist ) >alist sort-keys reverse ;
+
M: lo-tag-dispatch-engine engine>quot
methods>> engines>quots*
[ >r lo-tag-number r> ] assoc-map
[
picker % [ tag ] % [
- >alist sort-keys reverse
- linear-dispatch-quot
+ sort-tags linear-dispatch-quot
] [
num-tags get direct-dispatch-quot
] if-small? %
@@ -51,10 +52,11 @@ C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
\ hi-tag def>> ;
M: hi-tag-dispatch-engine engine>quot
- methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map
+ methods>> engines>quots*
+ [ >r hi-tag-number r> ] assoc-map
[
picker % hi-tag-quot % [
- linear-dispatch-quot
+ sort-tags linear-dispatch-quot
] [
num-tags get , \ fixnum-fast ,
[ >r num-tags get - r> ] assoc-map
diff --git a/vm/alien.c b/vm/alien.c
index 5b4ff3b832..8b7df45e9a 100755
--- a/vm/alien.c
+++ b/vm/alien.c
@@ -82,7 +82,7 @@ void box_alien(void *ptr)
}
/* make an alien pointing at an offset of another alien */
-DEFINE_PRIMITIVE(displaced_alien)
+void primitive_displaced_alien(void)
{
CELL alien = dpop();
CELL displacement = to_cell(dpop());
@@ -107,7 +107,7 @@ DEFINE_PRIMITIVE(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. */
-DEFINE_PRIMITIVE(alien_address)
+void primitive_alien_address(void)
{
box_unsigned_cell((CELL)pinned_alien_offset(dpop()));
}
@@ -121,11 +121,11 @@ INLINE void *alien_pointer(void)
/* define words to read/write values at an alien address */
#define DEFINE_ALIEN_ACCESSOR(name,type,boxer,to) \
- DEFINE_PRIMITIVE(alien_##name) \
+ void primitive_alien_##name(void) \
{ \
boxer(*(type*)alien_pointer()); \
} \
- DEFINE_PRIMITIVE(set_alien_##name) \
+ void primitive_set_alien_##name(void) \
{ \
type* ptr = alien_pointer(); \
type value = to(dpop()); \
@@ -170,7 +170,7 @@ void box_small_struct(CELL x, CELL y, CELL size)
}
/* open a native library and push a handle */
-DEFINE_PRIMITIVE(dlopen)
+void primitive_dlopen(void)
{
CELL path = tag_object(string_to_native_alien(
untag_string(dpop())));
@@ -183,7 +183,7 @@ DEFINE_PRIMITIVE(dlopen)
}
/* look up a symbol in a native library */
-DEFINE_PRIMITIVE(dlsym)
+void primitive_dlsym(void)
{
CELL dll = dpop();
REGISTER_ROOT(dll);
@@ -205,12 +205,12 @@ DEFINE_PRIMITIVE(dlsym)
}
/* close a native library handle */
-DEFINE_PRIMITIVE(dlclose)
+void primitive_dlclose(void)
{
ffi_dlclose(untag_dll(dpop()));
}
-DEFINE_PRIMITIVE(dll_validp)
+void primitive_dll_validp(void)
{
CELL dll = dpop();
if(dll == F)
diff --git a/vm/alien.h b/vm/alien.h
index babfbc358d..ec1eb08acf 100755
--- a/vm/alien.h
+++ b/vm/alien.h
@@ -1,7 +1,7 @@
CELL allot_alien(CELL delegate, CELL displacement);
-DECLARE_PRIMITIVE(displaced_alien);
-DECLARE_PRIMITIVE(alien_address);
+void primitive_displaced_alien(void);
+void primitive_alien_address(void);
DLLEXPORT void *alien_offset(CELL object);
@@ -10,32 +10,32 @@ void fixup_alien(F_ALIEN* d);
DLLEXPORT void *unbox_alien(void);
DLLEXPORT void box_alien(void *ptr);
-DECLARE_PRIMITIVE(alien_signed_cell);
-DECLARE_PRIMITIVE(set_alien_signed_cell);
-DECLARE_PRIMITIVE(alien_unsigned_cell);
-DECLARE_PRIMITIVE(set_alien_unsigned_cell);
-DECLARE_PRIMITIVE(alien_signed_8);
-DECLARE_PRIMITIVE(set_alien_signed_8);
-DECLARE_PRIMITIVE(alien_unsigned_8);
-DECLARE_PRIMITIVE(set_alien_unsigned_8);
-DECLARE_PRIMITIVE(alien_signed_4);
-DECLARE_PRIMITIVE(set_alien_signed_4);
-DECLARE_PRIMITIVE(alien_unsigned_4);
-DECLARE_PRIMITIVE(set_alien_unsigned_4);
-DECLARE_PRIMITIVE(alien_signed_2);
-DECLARE_PRIMITIVE(set_alien_signed_2);
-DECLARE_PRIMITIVE(alien_unsigned_2);
-DECLARE_PRIMITIVE(set_alien_unsigned_2);
-DECLARE_PRIMITIVE(alien_signed_1);
-DECLARE_PRIMITIVE(set_alien_signed_1);
-DECLARE_PRIMITIVE(alien_unsigned_1);
-DECLARE_PRIMITIVE(set_alien_unsigned_1);
-DECLARE_PRIMITIVE(alien_float);
-DECLARE_PRIMITIVE(set_alien_float);
-DECLARE_PRIMITIVE(alien_double);
-DECLARE_PRIMITIVE(set_alien_double);
-DECLARE_PRIMITIVE(alien_cell);
-DECLARE_PRIMITIVE(set_alien_cell);
+void primitive_alien_signed_cell(void);
+void primitive_set_alien_signed_cell(void);
+void primitive_alien_unsigned_cell(void);
+void primitive_set_alien_unsigned_cell(void);
+void primitive_alien_signed_8(void);
+void primitive_set_alien_signed_8(void);
+void primitive_alien_unsigned_8(void);
+void primitive_set_alien_unsigned_8(void);
+void primitive_alien_signed_4(void);
+void primitive_set_alien_signed_4(void);
+void primitive_alien_unsigned_4(void);
+void primitive_set_alien_unsigned_4(void);
+void primitive_alien_signed_2(void);
+void primitive_set_alien_signed_2(void);
+void primitive_alien_unsigned_2(void);
+void primitive_set_alien_unsigned_2(void);
+void primitive_alien_signed_1(void);
+void primitive_set_alien_signed_1(void);
+void primitive_alien_unsigned_1(void);
+void primitive_set_alien_unsigned_1(void);
+void primitive_alien_float(void);
+void primitive_set_alien_float(void);
+void primitive_alien_double(void);
+void primitive_set_alien_double(void);
+void primitive_alien_cell(void);
+void primitive_set_alien_cell(void);
DLLEXPORT void to_value_struct(CELL src, void *dest, CELL size);
DLLEXPORT void box_value_struct(void *src, CELL size);
@@ -43,7 +43,7 @@ DLLEXPORT void box_small_struct(CELL x, CELL y, CELL size);
DEFINE_UNTAG(F_DLL,DLL_TYPE,dll)
-DECLARE_PRIMITIVE(dlopen);
-DECLARE_PRIMITIVE(dlsym);
-DECLARE_PRIMITIVE(dlclose);
-DECLARE_PRIMITIVE(dll_validp);
+void primitive_dlopen(void);
+void primitive_dlsym(void);
+void primitive_dlclose(void);
+void primitive_dll_validp(void);
diff --git a/vm/callstack.c b/vm/callstack.c
index b7e99b418c..dfa7dd5f4a 100755
--- a/vm/callstack.c
+++ b/vm/callstack.c
@@ -6,11 +6,6 @@ F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom)
stack_chain->callstack_bottom = callstack_bottom;
}
-F_FASTCALL __attribute__((noinline)) void save_callstack_top(F_STACK_FRAME *callstack_top)
-{
- stack_chain->callstack_top = callstack_top;
-}
-
void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator)
{
F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1;
@@ -68,7 +63,7 @@ F_STACK_FRAME *capture_start(void)
return frame + 1;
}
-DEFINE_PRIMITIVE(callstack)
+void primitive_callstack(void)
{
F_STACK_FRAME *top = capture_start();
F_STACK_FRAME *bottom = stack_chain->callstack_bottom;
@@ -82,7 +77,7 @@ DEFINE_PRIMITIVE(callstack)
dpush(tag_object(callstack));
}
-DEFINE_PRIMITIVE(set_callstack)
+void primitive_set_callstack(void)
{
F_CALLSTACK *stack = untag_callstack(dpop());
@@ -158,7 +153,7 @@ void stack_frame_to_array(F_STACK_FRAME *frame)
set_array_nth(array,frame_index++,frame_scan(frame));
}
-DEFINE_PRIMITIVE(callstack_to_array)
+void primitive_callstack_to_array(void)
{
F_CALLSTACK *stack = untag_callstack(dpop());
@@ -190,7 +185,7 @@ F_STACK_FRAME *innermost_stack_frame(F_CALLSTACK *callstack)
/* Some primitives implementing a limited form of callstack mutation.
Used by the single stepper. */
-DEFINE_PRIMITIVE(innermost_stack_frame_quot)
+void primitive_innermost_stack_frame_quot(void)
{
F_STACK_FRAME *inner = innermost_stack_frame(
untag_callstack(dpop()));
@@ -199,7 +194,7 @@ DEFINE_PRIMITIVE(innermost_stack_frame_quot)
dpush(frame_executing(inner));
}
-DEFINE_PRIMITIVE(innermost_stack_frame_scan)
+void primitive_innermost_stack_frame_scan(void)
{
F_STACK_FRAME *inner = innermost_stack_frame(
untag_callstack(dpop()));
@@ -208,7 +203,7 @@ DEFINE_PRIMITIVE(innermost_stack_frame_scan)
dpush(frame_scan(inner));
}
-DEFINE_PRIMITIVE(set_innermost_stack_frame_quot)
+void primitive_set_innermost_stack_frame_quot(void)
{
F_CALLSTACK *callstack = untag_callstack(dpop());
F_QUOTATION *quot = untag_quotation(dpop());
diff --git a/vm/callstack.h b/vm/callstack.h
index 6c38cd0117..da0748b071 100755
--- a/vm/callstack.h
+++ b/vm/callstack.h
@@ -1,5 +1,4 @@
F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom);
-F_FASTCALL __attribute__((noinline)) void save_callstack_top(F_STACK_FRAME *callstack_top);
#define FIRST_STACK_FRAME(stack) (F_STACK_FRAME *)((stack) + 1)
@@ -14,11 +13,11 @@ CELL frame_executing(F_STACK_FRAME *frame);
CELL frame_scan(F_STACK_FRAME *frame);
CELL frame_type(F_STACK_FRAME *frame);
-DECLARE_PRIMITIVE(callstack);
-DECLARE_PRIMITIVE(set_datastack);
-DECLARE_PRIMITIVE(set_retainstack);
-DECLARE_PRIMITIVE(set_callstack);
-DECLARE_PRIMITIVE(callstack_to_array);
-DECLARE_PRIMITIVE(innermost_stack_frame_quot);
-DECLARE_PRIMITIVE(innermost_stack_frame_scan);
-DECLARE_PRIMITIVE(set_innermost_stack_frame_quot);
+void primitive_callstack(void);
+void primitive_set_datastack(void);
+void primitive_set_retainstack(void);
+void primitive_set_callstack(void);
+void primitive_callstack_to_array(void);
+void primitive_innermost_stack_frame_quot(void);
+void primitive_innermost_stack_frame_scan(void);
+void primitive_set_innermost_stack_frame_quot(void);
diff --git a/vm/code_gc.c b/vm/code_gc.c
index 03661999c5..bd6384408b 100755
--- a/vm/code_gc.c
+++ b/vm/code_gc.c
@@ -295,7 +295,7 @@ void recursive_mark(F_BLOCK *block)
}
/* Push the free space and total size of the code heap */
-DEFINE_PRIMITIVE(code_room)
+void primitive_code_room(void)
{
CELL used, total_free, max_free;
heap_usage(&code_heap,&used,&total_free,&max_free);
diff --git a/vm/code_gc.h b/vm/code_gc.h
index f93cba9c7a..72ad8d451c 100644
--- a/vm/code_gc.h
+++ b/vm/code_gc.h
@@ -82,4 +82,4 @@ void recursive_mark(F_BLOCK *block);
void dump_heap(F_HEAP *heap);
void compact_code_heap(void);
-DECLARE_PRIMITIVE(code_room);
+void primitive_code_room(void);
diff --git a/vm/code_heap.c b/vm/code_heap.c
index 1435caa9d2..2268df27e3 100755
--- a/vm/code_heap.c
+++ b/vm/code_heap.c
@@ -68,9 +68,11 @@ INLINE CELL compute_code_rel(F_REL *rel,
case RT_XT:
return (CELL)untag_word(get(CREF(literals_start,REL_ARGUMENT(rel))))->xt;
case RT_HERE:
- return rel->offset + code_start;
+ return rel->offset + code_start + (short)REL_ARGUMENT(rel);
case RT_LABEL:
return code_start + REL_ARGUMENT(rel);
+ case RT_STACK_CHAIN:
+ return (CELL)&stack_chain;
default:
critical_error("Bad rel type",rel->type);
return -1; /* Can't happen */
@@ -322,7 +324,7 @@ void default_word_code(F_WORD *word, bool relocate)
word->compiledp = F;
}
-DEFINE_PRIMITIVE(modify_code_heap)
+void primitive_modify_code_heap(void)
{
bool rescan_code_heap = to_boolean(dpop());
F_ARRAY *alist = untag_array(dpop());
diff --git a/vm/code_heap.h b/vm/code_heap.h
index c3b476c4b5..7b1545ddf5 100755
--- a/vm/code_heap.h
+++ b/vm/code_heap.h
@@ -13,8 +13,10 @@ typedef enum {
RT_HERE,
/* a local label */
RT_LABEL,
- /* immeditae literal */
- RT_IMMEDIATE
+ /* immediate literal */
+ RT_IMMEDIATE,
+ /* address of stack_chain var */
+ RT_STACK_CHAIN
} F_RELTYPE;
typedef enum {
@@ -71,4 +73,4 @@ F_COMPILED *add_compiled_block(
CELL compiled_code_format(void);
bool stack_traces_p(void);
-DECLARE_PRIMITIVE(modify_code_heap);
+void primitive_modify_code_heap(void);
diff --git a/vm/data_gc.c b/vm/data_gc.c
index 5342ff04d9..cf1632811c 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -250,13 +250,13 @@ CELL unaligned_object_size(CELL pointer)
}
}
-DEFINE_PRIMITIVE(size)
+void primitive_size(void)
{
box_unsigned_cell(object_size(dpop()));
}
/* Push memory usage statistics in data heap */
-DEFINE_PRIMITIVE(data_room)
+void primitive_data_room(void)
{
F_ARRAY *a = allot_array(ARRAY_TYPE,data_heap->gen_count * 2,F);
int gen;
@@ -281,7 +281,7 @@ void begin_scan(void)
gc_off = true;
}
-DEFINE_PRIMITIVE(begin_scan)
+void primitive_begin_scan(void)
{
gc();
begin_scan();
@@ -306,13 +306,13 @@ CELL next_object(void)
}
/* Push object at heap scan cursor and advance; pushes f when done */
-DEFINE_PRIMITIVE(next_object)
+void primitive_next_object(void)
{
dpush(next_object());
}
/* Re-enables GC */
-DEFINE_PRIMITIVE(end_scan)
+void primitive_end_scan(void)
{
gc_off = false;
}
@@ -911,12 +911,12 @@ void minor_gc(void)
garbage_collection(NURSERY,false,0);
}
-DEFINE_PRIMITIVE(gc)
+void primitive_gc(void)
{
gc();
}
-DEFINE_PRIMITIVE(gc_stats)
+void primitive_gc_stats(void)
{
GROWABLE_ARRAY(stats);
@@ -945,12 +945,12 @@ DEFINE_PRIMITIVE(gc_stats)
dpush(stats);
}
-DEFINE_PRIMITIVE(gc_reset)
+void primitive_gc_reset(void)
{
gc_reset();
}
-DEFINE_PRIMITIVE(become)
+void primitive_become(void)
{
F_ARRAY *new_objects = untag_array(dpop());
F_ARRAY *old_objects = untag_array(dpop());
diff --git a/vm/data_gc.h b/vm/data_gc.h
index 3c21695c2c..0d63cc6bfe 100755
--- a/vm/data_gc.h
+++ b/vm/data_gc.h
@@ -13,11 +13,11 @@ CELL binary_payload_start(CELL pointer);
void begin_scan(void);
CELL next_object(void);
-DECLARE_PRIMITIVE(data_room);
-DECLARE_PRIMITIVE(size);
-DECLARE_PRIMITIVE(begin_scan);
-DECLARE_PRIMITIVE(next_object);
-DECLARE_PRIMITIVE(end_scan);
+void primitive_data_room(void);
+void primitive_size(void);
+void primitive_begin_scan(void);
+void primitive_next_object(void);
+void primitive_end_scan(void);
void gc(void);
DLLEXPORT void minor_gc(void);
@@ -388,9 +388,9 @@ INLINE void* allot_object(CELL type, CELL a)
CELL collect_next(CELL scan);
-DECLARE_PRIMITIVE(gc);
-DECLARE_PRIMITIVE(gc_stats);
-DECLARE_PRIMITIVE(gc_reset);
-DECLARE_PRIMITIVE(become);
+void primitive_gc(void);
+void primitive_gc_stats(void);
+void primitive_gc_reset(void);
+void primitive_become(void);
CELL find_all_words(void);
diff --git a/vm/debug.c b/vm/debug.c
index 2550931c72..41205d4aff 100755
--- a/vm/debug.c
+++ b/vm/debug.c
@@ -474,7 +474,7 @@ void factorbug(void)
}
}
-DEFINE_PRIMITIVE(die)
+void primitive_die(void)
{
fprintf(stderr,"The die word was called by the library. Unless you called it yourself,\n");
fprintf(stderr,"you have triggered a bug in Factor. Please report.\n");
diff --git a/vm/debug.h b/vm/debug.h
index 547fdba436..594d8ec919 100755
--- a/vm/debug.h
+++ b/vm/debug.h
@@ -6,4 +6,4 @@ void dump_zone(F_ZONE *z);
bool fep_disabled;
-DECLARE_PRIMITIVE(die);
+void primitive_die(void);
diff --git a/vm/errors.c b/vm/errors.c
index 36072920fe..fe6e79be6d 100755
--- a/vm/errors.c
+++ b/vm/errors.c
@@ -142,19 +142,19 @@ void misc_signal_handler_impl(void)
signal_error(signal_number,signal_callstack_top);
}
-DEFINE_PRIMITIVE(throw)
+void primitive_throw(void)
{
dpop();
throw_impl(dpop(),stack_chain->callstack_top);
}
-DEFINE_PRIMITIVE(call_clear)
+void primitive_call_clear(void)
{
throw_impl(dpop(),stack_chain->callstack_bottom);
}
/* For testing purposes */
-DEFINE_PRIMITIVE(unimplemented)
+void primitive_unimplemented(void)
{
not_implemented_error();
}
diff --git a/vm/errors.h b/vm/errors.h
index 22cd6533c3..c7f8bc8712 100755
--- a/vm/errors.h
+++ b/vm/errors.h
@@ -22,7 +22,7 @@ typedef enum
void out_of_memory(void);
void fatal_error(char* msg, CELL tagged);
void critical_error(char* msg, CELL tagged);
-DECLARE_PRIMITIVE(die);
+void primitive_die(void);
void throw_error(CELL error, F_STACK_FRAME *native_stack);
void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, F_STACK_FRAME *native_stack);
@@ -32,8 +32,8 @@ void signal_error(int signal, F_STACK_FRAME *native_stack);
void type_error(CELL type, CELL tagged);
void not_implemented_error(void);
-DECLARE_PRIMITIVE(throw);
-DECLARE_PRIMITIVE(call_clear);
+void primitive_throw(void);
+void primitive_call_clear(void);
INLINE void type_check(CELL type, CELL tagged)
{
@@ -57,4 +57,4 @@ void memory_signal_handler_impl(void);
void divide_by_zero_signal_handler_impl(void);
void misc_signal_handler_impl(void);
-DECLARE_PRIMITIVE(unimplemented);
+void primitive_unimplemented(void);
diff --git a/vm/image.c b/vm/image.c
index 62f9e1c906..289c1e94c8 100755
--- a/vm/image.c
+++ b/vm/image.c
@@ -161,7 +161,7 @@ bool save_image(const F_CHAR *filename)
return true;
}
-DEFINE_PRIMITIVE(save_image)
+void primitive_save_image(void)
{
/* do a full GC to push everything into tenured space */
gc();
@@ -184,7 +184,7 @@ void strip_compiled_quotations(void)
gc_off = false;
}
-DEFINE_PRIMITIVE(save_image_and_exit)
+void primitive_save_image_and_exit(void)
{
/* 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
diff --git a/vm/image.h b/vm/image.h
index 9e582fc6c6..6e1b03af0d 100755
--- a/vm/image.h
+++ b/vm/image.h
@@ -40,8 +40,8 @@ void load_image(F_PARAMETERS *p);
void init_objects(F_HEADER *h);
bool save_image(const F_CHAR *file);
-DECLARE_PRIMITIVE(save_image);
-DECLARE_PRIMITIVE(save_image_and_exit);
+void primitive_save_image(void);
+void primitive_save_image_and_exit(void);
/* relocation base of currently loaded image's data heap */
CELL data_relocation_base;
diff --git a/vm/io.c b/vm/io.c
index bc561f5e5b..bad4854775 100755
--- a/vm/io.c
+++ b/vm/io.c
@@ -29,7 +29,7 @@ void io_error(void)
general_error(ERROR_IO,error,F,NULL);
}
-DEFINE_PRIMITIVE(fopen)
+void primitive_fopen(void)
{
char *mode = unbox_char_string();
REGISTER_C_STRING(mode);
@@ -49,7 +49,7 @@ DEFINE_PRIMITIVE(fopen)
}
}
-DEFINE_PRIMITIVE(fgetc)
+void primitive_fgetc(void)
{
FILE* file = unbox_alien();
@@ -74,7 +74,7 @@ DEFINE_PRIMITIVE(fgetc)
}
}
-DEFINE_PRIMITIVE(fread)
+void primitive_fread(void)
{
FILE* file = unbox_alien();
CELL size = unbox_array_size();
@@ -116,7 +116,7 @@ DEFINE_PRIMITIVE(fread)
}
}
-DEFINE_PRIMITIVE(fputc)
+void primitive_fputc(void)
{
FILE *file = unbox_alien();
F_FIXNUM ch = to_fixnum(dpop());
@@ -134,7 +134,7 @@ DEFINE_PRIMITIVE(fputc)
}
}
-DEFINE_PRIMITIVE(fwrite)
+void primitive_fwrite(void)
{
FILE *file = unbox_alien();
F_BYTE_ARRAY *text = untag_byte_array(dpop());
@@ -163,7 +163,7 @@ DEFINE_PRIMITIVE(fwrite)
}
}
-DEFINE_PRIMITIVE(fflush)
+void primitive_fflush(void)
{
FILE *file = unbox_alien();
for(;;)
@@ -175,7 +175,7 @@ DEFINE_PRIMITIVE(fflush)
}
}
-DEFINE_PRIMITIVE(fclose)
+void primitive_fclose(void)
{
FILE *file = unbox_alien();
for(;;)
diff --git a/vm/io.h b/vm/io.h
index f4af9b8bec..08c9dd7807 100755
--- a/vm/io.h
+++ b/vm/io.h
@@ -3,15 +3,15 @@ void io_error(void);
int err_no(void);
void clear_err_no(void);
-DECLARE_PRIMITIVE(fopen);
-DECLARE_PRIMITIVE(fgetc);
-DECLARE_PRIMITIVE(fread);
-DECLARE_PRIMITIVE(fputc);
-DECLARE_PRIMITIVE(fwrite);
-DECLARE_PRIMITIVE(fflush);
-DECLARE_PRIMITIVE(fclose);
+void primitive_fopen(void);
+void primitive_fgetc(void);
+void primitive_fread(void);
+void primitive_fputc(void);
+void primitive_fwrite(void);
+void primitive_fflush(void);
+void primitive_fclose(void);
/* Platform specific primitives */
-DECLARE_PRIMITIVE(open_file);
-DECLARE_PRIMITIVE(existsp);
-DECLARE_PRIMITIVE(read_dir);
+void primitive_open_file(void);
+void primitive_existsp(void);
+void primitive_read_dir(void);
diff --git a/vm/math.c b/vm/math.c
index 7d3b64ed39..388a472f2e 100644
--- a/vm/math.c
+++ b/vm/math.c
@@ -21,12 +21,12 @@ CELL to_cell(CELL tagged)
return (CELL)to_fixnum(tagged);
}
-DEFINE_PRIMITIVE(bignum_to_fixnum)
+void primitive_bignum_to_fixnum(void)
{
drepl(tag_fixnum(bignum_to_fixnum(untag_object(dpeek()))));
}
-DEFINE_PRIMITIVE(float_to_fixnum)
+void primitive_float_to_fixnum(void)
{
drepl(tag_fixnum(float_to_fixnum(dpeek())));
}
@@ -35,13 +35,13 @@ DEFINE_PRIMITIVE(float_to_fixnum)
F_FIXNUM y = untag_fixnum_fast(dpop()); \
F_FIXNUM x = untag_fixnum_fast(dpop());
-DEFINE_PRIMITIVE(fixnum_add)
+void primitive_fixnum_add(void)
{
POP_FIXNUMS(x,y)
box_signed_cell(x + y);
}
-DEFINE_PRIMITIVE(fixnum_subtract)
+void primitive_fixnum_subtract(void)
{
POP_FIXNUMS(x,y)
box_signed_cell(x - y);
@@ -49,7 +49,7 @@ DEFINE_PRIMITIVE(fixnum_subtract)
/* Multiply two integers, and trap overflow.
Thanks to David Blaikie (The_Vulture from freenode #java) for the hint. */
-DEFINE_PRIMITIVE(fixnum_multiply)
+void primitive_fixnum_multiply(void)
{
POP_FIXNUMS(x,y)
@@ -72,13 +72,13 @@ DEFINE_PRIMITIVE(fixnum_multiply)
}
}
-DEFINE_PRIMITIVE(fixnum_divint)
+void primitive_fixnum_divint(void)
{
POP_FIXNUMS(x,y)
box_signed_cell(x / y);
}
-DEFINE_PRIMITIVE(fixnum_divmod)
+void primitive_fixnum_divmod(void)
{
POP_FIXNUMS(x,y)
box_signed_cell(x / y);
@@ -90,7 +90,7 @@ DEFINE_PRIMITIVE(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.
*/
-DEFINE_PRIMITIVE(fixnum_shift)
+void primitive_fixnum_shift(void)
{
POP_FIXNUMS(x,y)
@@ -122,12 +122,12 @@ DEFINE_PRIMITIVE(fixnum_shift)
}
/* Bignums */
-DEFINE_PRIMITIVE(fixnum_to_bignum)
+void primitive_fixnum_to_bignum(void)
{
drepl(tag_bignum(fixnum_to_bignum(untag_fixnum_fast(dpeek()))));
}
-DEFINE_PRIMITIVE(float_to_bignum)
+void primitive_float_to_bignum(void)
{
drepl(tag_bignum(float_to_bignum(dpeek())));
}
@@ -136,37 +136,37 @@ DEFINE_PRIMITIVE(float_to_bignum)
F_ARRAY *y = untag_object(dpop()); \
F_ARRAY *x = untag_object(dpop());
-DEFINE_PRIMITIVE(bignum_eq)
+void primitive_bignum_eq(void)
{
POP_BIGNUMS(x,y);
box_boolean(bignum_equal_p(x,y));
}
-DEFINE_PRIMITIVE(bignum_add)
+void primitive_bignum_add(void)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_add(x,y)));
}
-DEFINE_PRIMITIVE(bignum_subtract)
+void primitive_bignum_subtract(void)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_subtract(x,y)));
}
-DEFINE_PRIMITIVE(bignum_multiply)
+void primitive_bignum_multiply(void)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_multiply(x,y)));
}
-DEFINE_PRIMITIVE(bignum_divint)
+void primitive_bignum_divint(void)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_quotient(x,y)));
}
-DEFINE_PRIMITIVE(bignum_divmod)
+void primitive_bignum_divmod(void)
{
F_ARRAY *q, *r;
POP_BIGNUMS(x,y);
@@ -175,74 +175,74 @@ DEFINE_PRIMITIVE(bignum_divmod)
dpush(tag_bignum(r));
}
-DEFINE_PRIMITIVE(bignum_mod)
+void primitive_bignum_mod(void)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_remainder(x,y)));
}
-DEFINE_PRIMITIVE(bignum_and)
+void primitive_bignum_and(void)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_bitwise_and(x,y)));
}
-DEFINE_PRIMITIVE(bignum_or)
+void primitive_bignum_or(void)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_bitwise_ior(x,y)));
}
-DEFINE_PRIMITIVE(bignum_xor)
+void primitive_bignum_xor(void)
{
POP_BIGNUMS(x,y);
dpush(tag_bignum(bignum_bitwise_xor(x,y)));
}
-DEFINE_PRIMITIVE(bignum_shift)
+void primitive_bignum_shift(void)
{
F_FIXNUM y = to_fixnum(dpop());
F_ARRAY* x = untag_object(dpop());
dpush(tag_bignum(bignum_arithmetic_shift(x,y)));
}
-DEFINE_PRIMITIVE(bignum_less)
+void primitive_bignum_less(void)
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) == bignum_comparison_less);
}
-DEFINE_PRIMITIVE(bignum_lesseq)
+void primitive_bignum_lesseq(void)
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) != bignum_comparison_greater);
}
-DEFINE_PRIMITIVE(bignum_greater)
+void primitive_bignum_greater(void)
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) == bignum_comparison_greater);
}
-DEFINE_PRIMITIVE(bignum_greatereq)
+void primitive_bignum_greatereq(void)
{
POP_BIGNUMS(x,y);
box_boolean(bignum_compare(x,y) != bignum_comparison_less);
}
-DEFINE_PRIMITIVE(bignum_not)
+void primitive_bignum_not(void)
{
drepl(tag_bignum(bignum_bitwise_not(untag_object(dpeek()))));
}
-DEFINE_PRIMITIVE(bignum_bitp)
+void primitive_bignum_bitp(void)
{
F_FIXNUM bit = to_fixnum(dpop());
F_ARRAY *x = untag_object(dpop());
box_boolean(bignum_logbitp(bit,x));
}
-DEFINE_PRIMITIVE(bignum_log2)
+void primitive_bignum_log2(void)
{
drepl(tag_bignum(bignum_integer_length(untag_object(dpeek()))));
}
@@ -253,7 +253,7 @@ unsigned int bignum_producer(unsigned int digit)
return *(ptr + digit);
}
-DEFINE_PRIMITIVE(byte_array_to_bignum)
+void primitive_byte_array_to_bignum(void)
{
type_check(BYTE_ARRAY_TYPE,dpeek());
CELL n_digits = array_capacity(untag_object(dpeek()));
@@ -383,7 +383,7 @@ CELL unbox_array_size(void)
/* Does not reduce to lowest terms, so should only be used by math
library implementation, to avoid breaking invariants. */
-DEFINE_PRIMITIVE(from_fraction)
+void primitive_from_fraction(void)
{
F_RATIO* ratio = allot_object(RATIO_TYPE,sizeof(F_RATIO));
ratio->denominator = dpop();
@@ -392,17 +392,17 @@ DEFINE_PRIMITIVE(from_fraction)
}
/* Floats */
-DEFINE_PRIMITIVE(fixnum_to_float)
+void primitive_fixnum_to_float(void)
{
drepl(allot_float(fixnum_to_float(dpeek())));
}
-DEFINE_PRIMITIVE(bignum_to_float)
+void primitive_bignum_to_float(void)
{
drepl(allot_float(bignum_to_float(dpeek())));
}
-DEFINE_PRIMITIVE(str_to_float)
+void primitive_str_to_float(void)
{
char *c_str, *end;
double f;
@@ -418,7 +418,7 @@ DEFINE_PRIMITIVE(str_to_float)
drepl(allot_float(f));
}
-DEFINE_PRIMITIVE(float_to_str)
+void primitive_float_to_str(void)
{
char tmp[33];
snprintf(tmp,32,"%.16g",untag_float(dpop()));
@@ -430,82 +430,82 @@ DEFINE_PRIMITIVE(float_to_str)
double y = untag_float_fast(dpop()); \
double x = untag_float_fast(dpop());
-DEFINE_PRIMITIVE(float_eq)
+void primitive_float_eq(void)
{
POP_FLOATS(x,y);
box_boolean(x == y);
}
-DEFINE_PRIMITIVE(float_add)
+void primitive_float_add(void)
{
POP_FLOATS(x,y);
box_double(x + y);
}
-DEFINE_PRIMITIVE(float_subtract)
+void primitive_float_subtract(void)
{
POP_FLOATS(x,y);
box_double(x - y);
}
-DEFINE_PRIMITIVE(float_multiply)
+void primitive_float_multiply(void)
{
POP_FLOATS(x,y);
box_double(x * y);
}
-DEFINE_PRIMITIVE(float_divfloat)
+void primitive_float_divfloat(void)
{
POP_FLOATS(x,y);
box_double(x / y);
}
-DEFINE_PRIMITIVE(float_mod)
+void primitive_float_mod(void)
{
POP_FLOATS(x,y);
box_double(fmod(x,y));
}
-DEFINE_PRIMITIVE(float_less)
+void primitive_float_less(void)
{
POP_FLOATS(x,y);
box_boolean(x < y);
}
-DEFINE_PRIMITIVE(float_lesseq)
+void primitive_float_lesseq(void)
{
POP_FLOATS(x,y);
box_boolean(x <= y);
}
-DEFINE_PRIMITIVE(float_greater)
+void primitive_float_greater(void)
{
POP_FLOATS(x,y);
box_boolean(x > y);
}
-DEFINE_PRIMITIVE(float_greatereq)
+void primitive_float_greatereq(void)
{
POP_FLOATS(x,y);
box_boolean(x >= y);
}
-DEFINE_PRIMITIVE(float_bits)
+void primitive_float_bits(void)
{
box_unsigned_4(float_bits(untag_float(dpop())));
}
-DEFINE_PRIMITIVE(bits_float)
+void primitive_bits_float(void)
{
box_float(bits_float(to_cell(dpop())));
}
-DEFINE_PRIMITIVE(double_bits)
+void primitive_double_bits(void)
{
box_unsigned_8(double_bits(untag_float(dpop())));
}
-DEFINE_PRIMITIVE(bits_double)
+void primitive_bits_double(void)
{
box_double(bits_double(to_unsigned_8(dpop())));
}
@@ -532,7 +532,7 @@ void box_double(double flo)
/* Complex numbers */
-DEFINE_PRIMITIVE(from_rect)
+void primitive_from_rect(void)
{
F_COMPLEX* complex = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX));
complex->imaginary = dpop();
diff --git a/vm/math.h b/vm/math.h
index 07d7fa9199..4fa3c8d35f 100644
--- a/vm/math.h
+++ b/vm/math.h
@@ -6,15 +6,15 @@
DLLEXPORT F_FIXNUM to_fixnum(CELL tagged);
DLLEXPORT CELL to_cell(CELL tagged);
-DECLARE_PRIMITIVE(bignum_to_fixnum);
-DECLARE_PRIMITIVE(float_to_fixnum);
+void primitive_bignum_to_fixnum(void);
+void primitive_float_to_fixnum(void);
-DECLARE_PRIMITIVE(fixnum_add);
-DECLARE_PRIMITIVE(fixnum_subtract);
-DECLARE_PRIMITIVE(fixnum_multiply);
-DECLARE_PRIMITIVE(fixnum_divint);
-DECLARE_PRIMITIVE(fixnum_divmod);
-DECLARE_PRIMITIVE(fixnum_shift);
+void primitive_fixnum_add(void);
+void primitive_fixnum_subtract(void);
+void primitive_fixnum_multiply(void);
+void primitive_fixnum_divint(void);
+void primitive_fixnum_divmod(void);
+void primitive_fixnum_shift(void);
CELL bignum_zero;
CELL bignum_pos_one;
@@ -25,27 +25,27 @@ INLINE CELL tag_bignum(F_ARRAY* bignum)
return RETAG(bignum,BIGNUM_TYPE);
}
-DECLARE_PRIMITIVE(fixnum_to_bignum);
-DECLARE_PRIMITIVE(float_to_bignum);
-DECLARE_PRIMITIVE(bignum_eq);
-DECLARE_PRIMITIVE(bignum_add);
-DECLARE_PRIMITIVE(bignum_subtract);
-DECLARE_PRIMITIVE(bignum_multiply);
-DECLARE_PRIMITIVE(bignum_divint);
-DECLARE_PRIMITIVE(bignum_divmod);
-DECLARE_PRIMITIVE(bignum_mod);
-DECLARE_PRIMITIVE(bignum_and);
-DECLARE_PRIMITIVE(bignum_or);
-DECLARE_PRIMITIVE(bignum_xor);
-DECLARE_PRIMITIVE(bignum_shift);
-DECLARE_PRIMITIVE(bignum_less);
-DECLARE_PRIMITIVE(bignum_lesseq);
-DECLARE_PRIMITIVE(bignum_greater);
-DECLARE_PRIMITIVE(bignum_greatereq);
-DECLARE_PRIMITIVE(bignum_not);
-DECLARE_PRIMITIVE(bignum_bitp);
-DECLARE_PRIMITIVE(bignum_log2);
-DECLARE_PRIMITIVE(byte_array_to_bignum);
+void primitive_fixnum_to_bignum(void);
+void primitive_float_to_bignum(void);
+void primitive_bignum_eq(void);
+void primitive_bignum_add(void);
+void primitive_bignum_subtract(void);
+void primitive_bignum_multiply(void);
+void primitive_bignum_divint(void);
+void primitive_bignum_divmod(void);
+void primitive_bignum_mod(void);
+void primitive_bignum_and(void);
+void primitive_bignum_or(void);
+void primitive_bignum_xor(void);
+void primitive_bignum_shift(void);
+void primitive_bignum_less(void);
+void primitive_bignum_lesseq(void);
+void primitive_bignum_greater(void);
+void primitive_bignum_greatereq(void);
+void primitive_bignum_not(void);
+void primitive_bignum_bitp(void);
+void primitive_bignum_log2(void);
+void primitive_byte_array_to_bignum(void);
INLINE CELL allot_integer(F_FIXNUM x)
{
@@ -80,7 +80,7 @@ DLLEXPORT u64 to_unsigned_8(CELL obj);
CELL unbox_array_size(void);
-DECLARE_PRIMITIVE(from_fraction);
+void primitive_from_fraction(void);
INLINE double untag_float_fast(CELL tagged)
{
@@ -125,26 +125,26 @@ DLLEXPORT float to_float(CELL value);
DLLEXPORT void box_double(double flo);
DLLEXPORT double to_double(CELL value);
-DECLARE_PRIMITIVE(fixnum_to_float);
-DECLARE_PRIMITIVE(bignum_to_float);
-DECLARE_PRIMITIVE(str_to_float);
-DECLARE_PRIMITIVE(float_to_str);
-DECLARE_PRIMITIVE(float_to_bits);
+void primitive_fixnum_to_float(void);
+void primitive_bignum_to_float(void);
+void primitive_str_to_float(void);
+void primitive_float_to_str(void);
+void primitive_float_to_bits(void);
-DECLARE_PRIMITIVE(float_eq);
-DECLARE_PRIMITIVE(float_add);
-DECLARE_PRIMITIVE(float_subtract);
-DECLARE_PRIMITIVE(float_multiply);
-DECLARE_PRIMITIVE(float_divfloat);
-DECLARE_PRIMITIVE(float_mod);
-DECLARE_PRIMITIVE(float_less);
-DECLARE_PRIMITIVE(float_lesseq);
-DECLARE_PRIMITIVE(float_greater);
-DECLARE_PRIMITIVE(float_greatereq);
+void primitive_float_eq(void);
+void primitive_float_add(void);
+void primitive_float_subtract(void);
+void primitive_float_multiply(void);
+void primitive_float_divfloat(void);
+void primitive_float_mod(void);
+void primitive_float_less(void);
+void primitive_float_lesseq(void);
+void primitive_float_greater(void);
+void primitive_float_greatereq(void);
-DECLARE_PRIMITIVE(float_bits);
-DECLARE_PRIMITIVE(bits_float);
-DECLARE_PRIMITIVE(double_bits);
-DECLARE_PRIMITIVE(bits_double);
+void primitive_float_bits(void);
+void primitive_bits_float(void);
+void primitive_double_bits(void);
+void primitive_bits_double(void);
-DECLARE_PRIMITIVE(from_rect);
+void primitive_from_rect(void);
diff --git a/vm/os-unix.c b/vm/os-unix.c
index 4ca62e6623..c11962f6e1 100755
--- a/vm/os-unix.c
+++ b/vm/os-unix.c
@@ -55,7 +55,7 @@ void ffi_dlclose(F_DLL *dll)
dll->dll = NULL;
}
-DEFINE_PRIMITIVE(existsp)
+void primitive_existsp(void)
{
struct stat sb;
box_boolean(stat(unbox_char_string(),&sb) >= 0);
diff --git a/vm/os-windows-ce.c b/vm/os-windows-ce.c
index 9b73692aa0..02b51b82ed 100755
--- a/vm/os-windows-ce.c
+++ b/vm/os-windows-ce.c
@@ -27,7 +27,7 @@ char *getenv(char *name)
return 0; /* unreachable */
}
-DEFINE_PRIMITIVE(os_envs)
+void primitive_os_envs(void)
{
not_implemented_error();
}
diff --git a/vm/os-windows.c b/vm/os-windows.c
index c19aa5c4b5..fc289c288e 100755
--- a/vm/os-windows.c
+++ b/vm/os-windows.c
@@ -87,7 +87,7 @@ const F_CHAR *vm_executable_path(void)
return safe_strdup(full_path);
}
-DEFINE_PRIMITIVE(existsp)
+void primitive_existsp(void)
{
BY_HANDLE_FILE_INFORMATION bhfi;
diff --git a/vm/primitives.h b/vm/primitives.h
index 811b473acd..30e0a4af96 100644
--- a/vm/primitives.h
+++ b/vm/primitives.h
@@ -1,42 +1 @@
extern void *primitives[];
-
-/* Primitives are called with two parameters, the word itself and the current
-callstack pointer. The DEFINE_PRIMITIVE() macro takes care of boilerplate to
-save the current callstack pointer so that GC and other facilities can proceed
-to inspect Factor stack frames below the primitive's C stack frame.
-
-Usage:
-
-DEFINE_PRIMITIVE(name)
-{
- ... CODE ...
-}
-
-Becomes
-
-F_FASTCALL void primitive_name(CELL word, F_STACK_FRAME *callstack_top)
-{
- save_callstack_top(callstack_top);
- ... CODE ...
-}
-
-On x86, F_FASTCALL expands into a GCC declaration which forces the two
-parameters to be passed in registers. This simplifies the quotation compiler
-and support code in cpu-x86.S.
-
-We do the assignment of stack_chain->callstack_top in a ``noinline'' function
-to inhibit assignment re-ordering. */
-#define DEFINE_PRIMITIVE(name) \
- INLINE void primitive_##name##_impl(void); \
- \
- F_FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top) \
- { \
- save_callstack_top(callstack_top); \
- primitive_##name##_impl(); \
- } \
- \
- INLINE void primitive_##name##_impl(void) \
-
-/* Prototype for header files */
-#define DECLARE_PRIMITIVE(name) \
- F_FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top)
diff --git a/vm/profiler.c b/vm/profiler.c
index 250e5a996a..e3db67964f 100755
--- a/vm/profiler.c
+++ b/vm/profiler.c
@@ -79,7 +79,7 @@ void set_profiling(bool profiling)
iterate_code_heap(relocate_code_block);
}
-DEFINE_PRIMITIVE(profiling)
+void primitive_profiling(void)
{
set_profiling(to_boolean(dpop()));
}
diff --git a/vm/profiler.h b/vm/profiler.h
index d14ceb283b..26a3a78d4b 100755
--- a/vm/profiler.h
+++ b/vm/profiler.h
@@ -1,4 +1,4 @@
bool profiling_p;
-DECLARE_PRIMITIVE(profiling);
+void primitive_profiling(void);
F_COMPILED *compile_profiling_stub(F_WORD *word);
void update_word_xt(F_WORD *word);
diff --git a/vm/quotations.c b/vm/quotations.c
index b75d3f79e0..bf917aeec0 100755
--- a/vm/quotations.c
+++ b/vm/quotations.c
@@ -209,6 +209,7 @@ void jit_compile(CELL quot, bool relocate)
case FIXNUM_TYPE:
if(jit_primitive_call_p(untag_object(array),i))
{
+ EMIT(userenv[JIT_SAVE_STACK],0);
EMIT(userenv[JIT_PRIMITIVE],to_fixnum(obj));
i++;
@@ -344,6 +345,7 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
case FIXNUM_TYPE:
if(jit_primitive_call_p(untag_object(array),i))
{
+ COUNT(userenv[JIT_SAVE_STACK],i);
COUNT(userenv[JIT_PRIMITIVE],i);
i++;
@@ -412,7 +414,7 @@ F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack)
}
/* push a new quotation on the stack */
-DEFINE_PRIMITIVE(array_to_quotation)
+void primitive_array_to_quotation(void)
{
F_QUOTATION *quot = allot_object(QUOTATION_TYPE,sizeof(F_QUOTATION));
quot->array = dpeek();
@@ -421,7 +423,7 @@ DEFINE_PRIMITIVE(array_to_quotation)
drepl(tag_object(quot));
}
-DEFINE_PRIMITIVE(quotation_xt)
+void primitive_quotation_xt(void)
{
F_QUOTATION *quot = untag_quotation(dpeek());
drepl(allot_cell((CELL)quot->xt));
diff --git a/vm/quotations.h b/vm/quotations.h
index 0845957c0b..45bf78d14f 100755
--- a/vm/quotations.h
+++ b/vm/quotations.h
@@ -2,5 +2,5 @@ void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code);
void jit_compile(CELL quot, bool relocate);
F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack);
F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset);
-DECLARE_PRIMITIVE(array_to_quotation);
-DECLARE_PRIMITIVE(quotation_xt);
+void primitive_array_to_quotation(void);
+void primitive_quotation_xt(void);
diff --git a/vm/run.c b/vm/run.c
index c4a3e115c1..c7d93d29c8 100755
--- a/vm/run.c
+++ b/vm/run.c
@@ -105,13 +105,13 @@ bool stack_to_array(CELL bottom, CELL top)
}
}
-DEFINE_PRIMITIVE(datastack)
+void primitive_datastack(void)
{
if(!stack_to_array(ds_bot,ds))
general_error(ERROR_DS_UNDERFLOW,F,F,NULL);
}
-DEFINE_PRIMITIVE(retainstack)
+void primitive_retainstack(void)
{
if(!stack_to_array(rs_bot,rs))
general_error(ERROR_RS_UNDERFLOW,F,F,NULL);
@@ -125,45 +125,45 @@ CELL array_to_stack(F_ARRAY *array, CELL bottom)
return bottom + depth - CELLS;
}
-DEFINE_PRIMITIVE(set_datastack)
+void primitive_set_datastack(void)
{
ds = array_to_stack(untag_array(dpop()),ds_bot);
}
-DEFINE_PRIMITIVE(set_retainstack)
+void primitive_set_retainstack(void)
{
rs = array_to_stack(untag_array(dpop()),rs_bot);
}
-DEFINE_PRIMITIVE(getenv)
+void primitive_getenv(void)
{
F_FIXNUM e = untag_fixnum_fast(dpeek());
drepl(userenv[e]);
}
-DEFINE_PRIMITIVE(setenv)
+void primitive_setenv(void)
{
F_FIXNUM e = untag_fixnum_fast(dpop());
CELL value = dpop();
userenv[e] = value;
}
-DEFINE_PRIMITIVE(exit)
+void primitive_exit(void)
{
exit(to_fixnum(dpop()));
}
-DEFINE_PRIMITIVE(millis)
+void primitive_millis(void)
{
box_unsigned_8(current_millis());
}
-DEFINE_PRIMITIVE(sleep)
+void primitive_sleep(void)
{
sleep_millis(to_cell(dpop()));
}
-DEFINE_PRIMITIVE(set_slot)
+void primitive_set_slot(void)
{
F_FIXNUM slot = untag_fixnum_fast(dpop());
CELL obj = dpop();
diff --git a/vm/run.h b/vm/run.h
index 96e606e38c..2dbbcc8c06 100755
--- a/vm/run.h
+++ b/vm/run.h
@@ -48,8 +48,8 @@ typedef enum {
JIT_RETURN,
JIT_PROFILING,
JIT_PUSH_IMMEDIATE,
-
JIT_DECLARE_WORD = 42,
+ JIT_SAVE_STACK,
STACK_TRACES_ENV = 59,
@@ -226,18 +226,18 @@ DLLEXPORT void nest_stacks(void);
DLLEXPORT void unnest_stacks(void);
void init_stacks(CELL ds_size, CELL rs_size);
-DECLARE_PRIMITIVE(datastack);
-DECLARE_PRIMITIVE(retainstack);
-DECLARE_PRIMITIVE(getenv);
-DECLARE_PRIMITIVE(setenv);
-DECLARE_PRIMITIVE(exit);
-DECLARE_PRIMITIVE(os_env);
-DECLARE_PRIMITIVE(os_envs);
-DECLARE_PRIMITIVE(set_os_env);
-DECLARE_PRIMITIVE(unset_os_env);
-DECLARE_PRIMITIVE(set_os_envs);
-DECLARE_PRIMITIVE(millis);
-DECLARE_PRIMITIVE(sleep);
-DECLARE_PRIMITIVE(set_slot);
+void primitive_datastack(void);
+void primitive_retainstack(void);
+void primitive_getenv(void);
+void primitive_setenv(void);
+void primitive_exit(void);
+void primitive_os_env(void);
+void primitive_os_envs(void);
+void primitive_set_os_env(void);
+void primitive_unset_os_env(void);
+void primitive_set_os_envs(void);
+void primitive_millis(void);
+void primitive_sleep(void);
+void primitive_set_slot(void);
bool stage2;
diff --git a/vm/types.c b/vm/types.c
index 38fe3460e7..f1588465a4 100755
--- a/vm/types.c
+++ b/vm/types.c
@@ -29,7 +29,7 @@ CELL clone_object(CELL object)
}
}
-DEFINE_PRIMITIVE(clone)
+void primitive_clone(void)
{
drepl(clone_object(dpeek()));
}
@@ -68,7 +68,7 @@ F_WORD *allot_word(CELL vocab, CELL name)
}
/* <word> ( name vocabulary -- word ) */
-DEFINE_PRIMITIVE(word)
+void primitive_word(void)
{
CELL vocab = dpop();
CELL name = dpop();
@@ -76,7 +76,7 @@ DEFINE_PRIMITIVE(word)
}
/* word-xt ( word -- start end ) */
-DEFINE_PRIMITIVE(word_xt)
+void primitive_word_xt(void)
{
F_WORD *word = untag_word(dpop());
F_COMPILED *code = (profiling_p ? word->profiling : word->code);
@@ -84,7 +84,7 @@ DEFINE_PRIMITIVE(word_xt)
dpush(allot_cell((CELL)code + sizeof(F_COMPILED) + code->code_length));
}
-DEFINE_PRIMITIVE(wrapper)
+void primitive_wrapper(void)
{
F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
wrapper->object = dpeek();
@@ -123,7 +123,7 @@ F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill)
}
/* push a new array on the stack */
-DEFINE_PRIMITIVE(array)
+void primitive_array(void)
{
CELL initial = dpop();
CELL size = unbox_array_size();
@@ -194,7 +194,7 @@ F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill)
return new_array;
}
-DEFINE_PRIMITIVE(resize_array)
+void primitive_resize_array(void)
{
F_ARRAY* array = untag_array(dpop());
CELL capacity = unbox_array_size();
@@ -259,7 +259,7 @@ F_BYTE_ARRAY *allot_byte_array(CELL size)
}
/* push a new byte array on the stack */
-DEFINE_PRIMITIVE(byte_array)
+void primitive_byte_array(void)
{
CELL size = unbox_array_size();
dpush(tag_object(allot_byte_array(size)));
@@ -280,7 +280,7 @@ F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity)
return new_array;
}
-DEFINE_PRIMITIVE(resize_byte_array)
+void primitive_resize_byte_array(void)
{
F_BYTE_ARRAY* array = untag_byte_array(dpop());
CELL capacity = unbox_array_size();
@@ -313,7 +313,7 @@ F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout)
return tuple;
}
-DEFINE_PRIMITIVE(tuple)
+void primitive_tuple(void)
{
F_TUPLE_LAYOUT *layout = untag_object(dpop());
F_FIXNUM size = untag_fixnum_fast(layout->size);
@@ -327,7 +327,7 @@ DEFINE_PRIMITIVE(tuple)
}
/* push a new tuple on the stack, filling its slots from the stack */
-DEFINE_PRIMITIVE(tuple_boa)
+void primitive_tuple_boa(void)
{
F_TUPLE_LAYOUT *layout = untag_object(dpop());
F_FIXNUM size = untag_fixnum_fast(layout->size);
@@ -434,7 +434,7 @@ F_STRING *allot_string(CELL capacity, CELL fill)
return string;
}
-DEFINE_PRIMITIVE(string)
+void primitive_string(void)
{
CELL initial = to_cell(dpop());
CELL length = unbox_array_size();
@@ -477,7 +477,7 @@ F_STRING* reallot_string(F_STRING* string, CELL capacity, CELL fill)
return new_string;
}
-DEFINE_PRIMITIVE(resize_string)
+void primitive_resize_string(void)
{
F_STRING* string = untag_string(dpop());
CELL capacity = unbox_array_size();
@@ -544,7 +544,7 @@ F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size)
for(i = 0; i < capacity; i++) \
string[i] = string_nth(s,i); \
} \
- DEFINE_PRIMITIVE(type##_string_to_memory) \
+ void primitive_##type##_string_to_memory(void) \
{ \
type *address = unbox_alien(); \
F_STRING *str = untag_string(dpop()); \
@@ -576,14 +576,14 @@ F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size)
STRING_TO_MEMORY(char);
STRING_TO_MEMORY(u16);
-DEFINE_PRIMITIVE(string_nth)
+void primitive_string_nth(void)
{
F_STRING *string = untag_object(dpop());
CELL index = untag_fixnum_fast(dpop());
dpush(tag_fixnum(string_nth(string,index)));
}
-DEFINE_PRIMITIVE(set_string_nth)
+void primitive_set_string_nth(void)
{
F_STRING *string = untag_object(dpop());
CELL index = untag_fixnum_fast(dpop());
diff --git a/vm/types.h b/vm/types.h
index 6efae35f5e..ebbb8a2642 100755
--- a/vm/types.h
+++ b/vm/types.h
@@ -112,23 +112,23 @@ 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);
-DECLARE_PRIMITIVE(array);
-DECLARE_PRIMITIVE(tuple);
-DECLARE_PRIMITIVE(tuple_boa);
-DECLARE_PRIMITIVE(tuple_layout);
-DECLARE_PRIMITIVE(byte_array);
-DECLARE_PRIMITIVE(clone);
+void primitive_array(void);
+void primitive_tuple(void);
+void primitive_tuple_boa(void);
+void primitive_tuple_layout(void);
+void primitive_byte_array(void);
+void primitive_clone(void);
F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill);
F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity);
-DECLARE_PRIMITIVE(resize_array);
-DECLARE_PRIMITIVE(resize_byte_array);
+void primitive_resize_array(void);
+void primitive_resize_byte_array(void);
F_STRING* allot_string_internal(CELL capacity);
F_STRING* allot_string(CELL capacity, CELL fill);
-DECLARE_PRIMITIVE(string);
+void primitive_string(void);
F_STRING *reallot_string(F_STRING *string, CELL capacity, CELL fill);
-DECLARE_PRIMITIVE(resize_string);
+void primitive_resize_string(void);
F_STRING *memory_to_char_string(const char *string, CELL length);
F_STRING *from_char_string(const char *c_string);
@@ -152,14 +152,14 @@ DLLEXPORT u16 *unbox_u16_string(void);
CELL string_nth(F_STRING* string, CELL index);
void set_string_nth(F_STRING* string, CELL index, CELL value);
-DECLARE_PRIMITIVE(string_nth);
-DECLARE_PRIMITIVE(set_string_nth);
+void primitive_string_nth(void);
+void primitive_set_string_nth(void);
F_WORD *allot_word(CELL vocab, CELL name);
-DECLARE_PRIMITIVE(word);
-DECLARE_PRIMITIVE(word_xt);
+void primitive_word(void);
+void primitive_word_xt(void);
-DECLARE_PRIMITIVE(wrapper);
+void primitive_wrapper(void);
/* Macros to simulate a vector in C */
#define GROWABLE_ARRAY(result) \