diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index 62130cb179..632938bb2d 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -85,8 +85,16 @@ SYMBOL: objects
: 1-offset 8 ; inline
: -1-offset 9 ; inline
+SYMBOL: sub-primitives
+
+: make-jit ( quot rc rt offset -- quad )
+ { [ { } make ] [ ] [ ] [ ] } spread 4array ; inline
+
: jit-define ( quot rc rt offset name -- )
- >r { [ { } make ] [ ] [ ] [ ] } spread 4array r> set ;
+ >r make-jit r> set ; inline
+
+: define-sub-primitive ( quot rc rt offset word -- )
+ >r make-jit r> sub-primitives get set-at ;
! The image being constructed; a vector of word-size integers
SYMBOL: image
@@ -118,29 +126,7 @@ SYMBOL: jit-dispatch
SYMBOL: jit-epilog
SYMBOL: jit-return
SYMBOL: jit-profiling
-SYMBOL: jit-tag
-SYMBOL: jit-tag-word
-SYMBOL: jit-eq?
-SYMBOL: jit-eq?-word
-SYMBOL: jit-slot
-SYMBOL: jit-slot-word
SYMBOL: jit-declare-word
-SYMBOL: jit-drop
-SYMBOL: jit-drop-word
-SYMBOL: jit-dup
-SYMBOL: jit-dup-word
-SYMBOL: jit->r
-SYMBOL: jit->r-word
-SYMBOL: jit-r>
-SYMBOL: jit-r>-word
-SYMBOL: jit-swap
-SYMBOL: jit-swap-word
-SYMBOL: jit-over
-SYMBOL: jit-over-word
-SYMBOL: jit-fixnum-fast
-SYMBOL: jit-fixnum-fast-word
-SYMBOL: jit-fixnum>=
-SYMBOL: jit-fixnum>=-word
! Default definition for undefined words
SYMBOL: undefined-quot
@@ -163,29 +149,7 @@ SYMBOL: undefined-quot
{ jit-epilog 33 }
{ jit-return 34 }
{ jit-profiling 35 }
- { jit-tag 36 }
- { jit-tag-word 37 }
- { jit-eq? 38 }
- { jit-eq?-word 39 }
- { jit-slot 40 }
- { jit-slot-word 41 }
{ jit-declare-word 42 }
- { jit-drop 43 }
- { jit-drop-word 44 }
- { jit-dup 45 }
- { jit-dup-word 46 }
- { jit->r 47 }
- { jit->r-word 48 }
- { jit-r> 49 }
- { jit-r>-word 50 }
- { jit-swap 51 }
- { jit-swap-word 52 }
- { jit-over 53 }
- { jit-over-word 54 }
- { jit-fixnum-fast 55 }
- { jit-fixnum-fast-word 56 }
- { jit-fixnum>= 57 }
- { jit-fixnum>=-word 58 }
{ undefined-quot 60 }
} at header-size + ;
@@ -305,6 +269,9 @@ M: f '
! Words
+: word-sub-primitive ( word -- obj )
+ global [ target-word ] bind sub-primitives get at ;
+
: emit-word ( word -- )
[
[ subwords [ emit-word ] each ]
@@ -316,12 +283,13 @@ M: f '
[ vocabulary>> , ]
[ def>> , ]
[ props>> , ]
+ [ drop f , ]
+ [ drop 0 , ] ! count
+ [ word-sub-primitive , ]
+ [ drop 0 , ] ! xt
+ [ drop 0 , ] ! code
+ [ drop 0 , ] ! profiling
} cleave
- f ,
- 0 , ! count
- 0 , ! xt
- 0 , ! code
- 0 , ! profiling
] { } make [ ' ] map
] bi
\ word type-number object tag-number
@@ -460,18 +428,7 @@ M: quotation '
\ if jit-if-word set
\ dispatch jit-dispatch-word set
\ do-primitive jit-primitive-word set
- \ tag jit-tag-word set
- \ eq? jit-eq?-word set
- \ slot jit-slot-word set
\ declare jit-declare-word set
- \ drop jit-drop-word set
- \ dup jit-dup-word set
- \ >r jit->r-word set
- \ r> jit-r>-word set
- \ swap jit-swap-word set
- \ over jit-over-word set
- \ fixnum-fast jit-fixnum-fast-word set
- \ fixnum>= jit-fixnum>=-word set
[ undefined ] undefined-quot set
{
jit-code-format
@@ -488,29 +445,7 @@ M: quotation '
jit-epilog
jit-return
jit-profiling
- jit-tag
- jit-tag-word
- jit-eq?
- jit-eq?-word
- jit-slot
- jit-slot-word
jit-declare-word
- jit-drop
- jit-drop-word
- jit-dup
- jit-dup-word
- jit->r
- jit->r-word
- jit-r>
- jit-r>-word
- jit-swap
- jit-swap-word
- jit-over
- jit-over-word
- jit-fixnum-fast
- jit-fixnum-fast-word
- jit-fixnum>=
- jit-fixnum>=-word
undefined-quot
} [ emit-userenv ] each ;
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 6498dfde60..d748e063c2 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -13,6 +13,8 @@ IN: bootstrap.primitives
crossref off
+H{ } clone sub-primitives set
+
"resource:core/bootstrap/syntax.factor" parse-file
"resource:core/cpu/" architecture get {
@@ -256,6 +258,7 @@ bi
"props"
{ "compiled" read-only }
{ "counter" { "fixnum" "math" } }
+ { "sub-primitive" read-only }
} define-builtin
"byte-array" "byte-arrays" create { } define-builtin
@@ -323,14 +326,55 @@ tuple
[ tuple-layout [ <tuple-boa> ] curry ] tri
(( quot1 quot2 -- compose )) define-declared
+! Sub-primitive words
+: make-sub-primitive ( word vocab -- )
+ create
+ dup reset-word
+ dup 1quotation define ;
+
+{
+ { "(execute)" "words.private" }
+ { "(call)" "kernel.private" }
+ { "fixnum+fast" "math.private" }
+ { "fixnum-fast" "math.private" }
+ { "fixnum*fast" "math.private" }
+ { "fixnum-bitand" "math.private" }
+ { "fixnum-bitor" "math.private" }
+ { "fixnum-bitxor" "math.private" }
+ { "fixnum-bitnot" "math.private" }
+ { "fixnum<" "math.private" }
+ { "fixnum<=" "math.private" }
+ { "fixnum>" "math.private" }
+ { "fixnum>=" "math.private" }
+ { "drop" "kernel" }
+ { "2drop" "kernel" }
+ { "3drop" "kernel" }
+ { "dup" "kernel" }
+ { "2dup" "kernel" }
+ { "3dup" "kernel" }
+ { "rot" "kernel" }
+ { "-rot" "kernel" }
+ { "dupd" "kernel" }
+ { "swapd" "kernel" }
+ { "nip" "kernel" }
+ { "2nip" "kernel" }
+ { "tuck" "kernel" }
+ { "over" "kernel" }
+ { "pick" "kernel" }
+ { "swap" "kernel" }
+ { ">r" "kernel" }
+ { "r>" "kernel" }
+ { "eq?" "kernel" }
+ { "tag" "kernel.private" }
+ { "slot" "slots.private" }
+} [ make-sub-primitive ] assoc-each
+
! Primitive words
: make-primitive ( word vocab n -- )
>r create dup reset-word r>
[ do-primitive ] curry [ ] like define ;
{
- { "(execute)" "words.private" }
- { "(call)" "kernel.private" }
{ "bignum>fixnum" "math.private" }
{ "float>fixnum" "math.private" }
{ "fixnum>bignum" "math.private" }
@@ -346,24 +390,13 @@ tuple
{ "bits>double" "math" }
{ "<complex>" "math.private" }
{ "fixnum+" "math.private" }
- { "fixnum+fast" "math.private" }
{ "fixnum-" "math.private" }
- { "fixnum-fast" "math.private" }
{ "fixnum*" "math.private" }
- { "fixnum*fast" "math.private" }
{ "fixnum/i" "math.private" }
{ "fixnum-mod" "math.private" }
{ "fixnum/mod" "math.private" }
- { "fixnum-bitand" "math.private" }
- { "fixnum-bitor" "math.private" }
- { "fixnum-bitxor" "math.private" }
- { "fixnum-bitnot" "math.private" }
{ "fixnum-shift" "math.private" }
{ "fixnum-shift-fast" "math.private" }
- { "fixnum<" "math.private" }
- { "fixnum<=" "math.private" }
- { "fixnum>" "math.private" }
- { "fixnum>=" "math.private" }
{ "bignum=" "math.private" }
{ "bignum+" "math.private" }
{ "bignum-" "math.private" }
@@ -395,25 +428,6 @@ tuple
{ "float>=" "math.private" }
{ "<word>" "words" }
{ "word-xt" "words" }
- { "drop" "kernel" }
- { "2drop" "kernel" }
- { "3drop" "kernel" }
- { "dup" "kernel" }
- { "2dup" "kernel" }
- { "3dup" "kernel" }
- { "rot" "kernel" }
- { "-rot" "kernel" }
- { "dupd" "kernel" }
- { "swapd" "kernel" }
- { "nip" "kernel" }
- { "2nip" "kernel" }
- { "tuck" "kernel" }
- { "over" "kernel" }
- { "pick" "kernel" }
- { "swap" "kernel" }
- { ">r" "kernel" }
- { "r>" "kernel" }
- { "eq?" "kernel" }
{ "getenv" "kernel.private" }
{ "setenv" "kernel.private" }
{ "(exists?)" "io.files.private" }
@@ -433,7 +447,6 @@ tuple
{ "code-room" "memory" }
{ "os-env" "system" }
{ "millis" "system" }
- { "tag" "kernel.private" }
{ "modify-code-heap" "compiler.units" }
{ "dlopen" "alien" }
{ "dlsym" "alien" }
@@ -468,7 +481,6 @@ tuple
{ "set-alien-cell" "alien.accessors" }
{ "(throw)" "kernel.private" }
{ "alien-address" "alien" }
- { "slot" "slots.private" }
{ "set-slot" "slots.private" }
{ "string-nth" "strings.private" }
{ "set-string-nth" "strings.private" }
diff --git a/core/compiler/constants/constants.factor b/core/compiler/constants/constants.factor
index 622c63d7f0..80f0b4f515 100755
--- a/core/compiler/constants/constants.factor
+++ b/core/compiler/constants/constants.factor
@@ -18,8 +18,8 @@ IN: compiler.constants
: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ;
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ;
: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ;
-: word-xt-offset ( -- n ) 8 bootstrap-cells object tag-number - ;
+: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ;
: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
-: word-code-offset ( -- n ) 9 bootstrap-cells object tag-number - ;
+: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ;
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
: compiled-header-size ( -- n ) 4 bootstrap-cells ;
diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor
index bf176eebfa..bd90ca65f0 100755
--- a/core/cpu/x86/bootstrap.factor
+++ b/core/cpu/x86/bootstrap.factor
@@ -1,8 +1,9 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: bootstrap.image.private kernel namespaces system
-cpu.x86.assembler layouts compiler.units math generator.fixup
-compiler.constants vocabs ;
+USING: bootstrap.image.private kernel kernel.private namespaces
+system cpu.x86.assembler layouts compiler.units math math.private
+generator.fixup compiler.constants vocabs slots.private words
+words.private ;
IN: bootstrap.x86
big-endian off
@@ -74,27 +75,34 @@ big-endian off
arg0 quot-xt-offset [+] JMP ! execute branch
] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define
+[
+ stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
+] f f f jit-epilog jit-define
+
+[ 0 RET ] f f f jit-return jit-define
+
+! Sub-primitives
+
+! Quotations and words
+[
+ arg0 ds-reg [] MOV ! load from stack
+ ds-reg bootstrap-cell SUB ! pop stack
+ arg0 quot-xt-offset [+] JMP ! call quotation
+] f f f \ (call) define-sub-primitive
+
+[
+ arg0 ds-reg [] MOV ! load from stack
+ ds-reg bootstrap-cell SUB ! pop stack
+ arg0 word-xt-offset [+] JMP ! execute word
+] f f f \ (execute) define-sub-primitive
+
+! Objects
[
arg1 ds-reg [] MOV ! load from stack
arg1 tag-mask get AND ! compute tag
arg1 tag-bits get SHL ! tag the tag
ds-reg [] arg1 MOV ! push to stack
-] f f f jit-tag jit-define
-
-: jit-compare ( -- )
- arg1 0 MOV ! load t
- arg1 dup [] MOV
- temp-reg \ f tag-number MOV ! load f
- arg0 ds-reg [] MOV ! load first value
- ds-reg bootstrap-cell SUB ! adjust stack pointer
- ds-reg [] arg0 CMP ! compare with second value
- ;
-
-[
- jit-compare
- arg1 temp-reg CMOVNE ! not equal?
- ds-reg [] arg1 MOV ! store
-] rc-absolute-cell rt-literal 1 rex-length + jit-eq? jit-define
+] f f f \ tag define-sub-primitive
[
arg0 ds-reg [] MOV ! load slot number
@@ -105,63 +113,187 @@ big-endian off
arg1 tag-bits get SHL
arg0 arg1 arg0 [+] MOV ! load slot value
ds-reg [] arg0 MOV ! push to stack
-] f f f jit-slot jit-define
+] f f f \ slot define-sub-primitive
+! Shufflers
[
ds-reg bootstrap-cell SUB
-] f f f jit-drop jit-define
+] f f f \ drop define-sub-primitive
+
+[
+ ds-reg 2 bootstrap-cells SUB
+] f f f \ 2drop define-sub-primitive
+
+[
+ ds-reg 3 bootstrap-cells SUB
+] f f f \ 3drop define-sub-primitive
[
arg0 ds-reg [] MOV
ds-reg bootstrap-cell ADD
ds-reg [] arg0 MOV
-] f f f jit-dup jit-define
+] f f f \ dup define-sub-primitive
+
+[
+ arg0 ds-reg [] MOV
+ arg1 ds-reg bootstrap-cell neg [+] MOV
+ ds-reg 2 bootstrap-cells ADD
+ ds-reg [] arg0 MOV
+ ds-reg bootstrap-cell neg [+] arg1 MOV
+] f f f \ 2dup define-sub-primitive
+
+[
+ arg0 ds-reg [] MOV
+ arg1 ds-reg -1 bootstrap-cells [+] MOV
+ temp-reg ds-reg -2 bootstrap-cells [+] MOV
+ ds-reg 3 bootstrap-cells ADD
+ ds-reg [] arg0 MOV
+ ds-reg -1 bootstrap-cells [+] arg1 MOV
+ ds-reg -2 bootstrap-cells [+] temp-reg MOV
+] f f f \ 3dup define-sub-primitive
[
- rs-reg bootstrap-cell ADD
arg0 ds-reg [] MOV
ds-reg bootstrap-cell SUB
- rs-reg [] arg0 MOV
-] f f f jit->r jit-define
+ ds-reg [] arg0 MOV
+] f f f \ nip define-sub-primitive
[
- ds-reg bootstrap-cell ADD
- arg0 rs-reg [] MOV
- rs-reg bootstrap-cell SUB
+ arg0 ds-reg [] MOV
+ ds-reg 2 bootstrap-cells SUB
ds-reg [] arg0 MOV
-] f f f jit-r> jit-define
+] f f f \ 2nip define-sub-primitive
+
+[
+ arg0 ds-reg -1 bootstrap-cells [+] MOV
+ ds-reg bootstrap-cell ADD
+ ds-reg [] arg0 MOV
+] f f f \ over define-sub-primitive
+
+[
+ arg0 ds-reg -2 bootstrap-cells [+] MOV
+ ds-reg bootstrap-cell ADD
+ ds-reg [] arg0 MOV
+] f f f \ pick define-sub-primitive
+
+[
+ arg0 ds-reg [] MOV
+ arg1 ds-reg -1 bootstrap-cells [+] MOV
+ ds-reg [] arg1 MOV
+ ds-reg bootstrap-cell ADD
+ ds-reg [] arg0 MOV
+] f f f \ dupd define-sub-primitive
+
+[
+ arg0 ds-reg [] MOV
+ arg1 ds-reg -1 bootstrap-cells [+] MOV
+ ds-reg bootstrap-cell ADD
+ ds-reg [] arg0 MOV
+ ds-reg -1 bootstrap-cells [+] arg1 MOV
+ ds-reg -2 bootstrap-cells [+] arg0 MOV
+] f f f \ tuck define-sub-primitive
[
arg0 ds-reg [] MOV
arg1 ds-reg bootstrap-cell neg [+] MOV
ds-reg bootstrap-cell neg [+] arg0 MOV
ds-reg [] arg1 MOV
-] f f f jit-swap jit-define
+] f f f \ swap define-sub-primitive
[
- arg0 ds-reg bootstrap-cell neg [+] MOV
- ds-reg bootstrap-cell ADD
- ds-reg [] arg0 MOV
-] f f f jit-over jit-define
+ arg0 ds-reg -1 bootstrap-cells [+] MOV
+ arg1 ds-reg -2 bootstrap-cells [+] MOV
+ ds-reg -2 bootstrap-cells [+] arg0 MOV
+ ds-reg -1 bootstrap-cells [+] arg1 MOV
+] f f f \ swapd define-sub-primitive
[
arg0 ds-reg [] MOV
- ds-reg bootstrap-cell SUB
- arg1 ds-reg [] MOV
- arg1 arg0 SUB
+ arg1 ds-reg -1 bootstrap-cells [+] MOV
+ temp-reg ds-reg -2 bootstrap-cells [+] MOV
+ ds-reg -2 bootstrap-cells [+] arg1 MOV
+ ds-reg -1 bootstrap-cells [+] arg0 MOV
+ ds-reg [] temp-reg MOV
+] f f f \ rot define-sub-primitive
+
+[
+ arg0 ds-reg [] MOV
+ arg1 ds-reg -1 bootstrap-cells [+] MOV
+ temp-reg ds-reg -2 bootstrap-cells [+] MOV
+ ds-reg -2 bootstrap-cells [+] arg0 MOV
+ ds-reg -1 bootstrap-cells [+] temp-reg MOV
ds-reg [] arg1 MOV
-] f f f jit-fixnum-fast jit-define
+] f f f \ -rot define-sub-primitive
[
- jit-compare
- arg1 temp-reg CMOVL ! not equal?
+ rs-reg bootstrap-cell ADD
+ arg0 ds-reg [] MOV
+ ds-reg bootstrap-cell SUB
+ rs-reg [] arg0 MOV
+] f f f \ >r define-sub-primitive
+
+[
+ ds-reg bootstrap-cell ADD
+ arg0 rs-reg [] MOV
+ rs-reg bootstrap-cell SUB
+ ds-reg [] arg0 MOV
+] f f f \ r> define-sub-primitive
+
+! Comparisons
+: jit-compare ( insn -- )
+ arg1 0 MOV ! load t
+ arg1 dup [] MOV
+ temp-reg \ f tag-number MOV ! load f
+ arg0 ds-reg [] MOV ! load first value
+ ds-reg bootstrap-cell SUB ! adjust stack pointer
+ ds-reg [] arg0 CMP ! compare with second value
+ [ arg1 temp-reg ] dip execute ! move t if true
ds-reg [] arg1 MOV ! store
-] rc-absolute-cell rt-literal 1 rex-length + jit-fixnum>= jit-define
+ ;
+
+: define-jit-compare ( insn word -- )
+ [ [ jit-compare ] curry rc-absolute-cell rt-literal 1 rex-length + ] dip
+ define-sub-primitive ;
+
+\ CMOVNE \ eq? define-jit-compare
+\ CMOVL \ fixnum>= define-jit-compare
+\ CMOVG \ fixnum<= define-jit-compare
+\ CMOVLE \ fixnum> define-jit-compare
+\ CMOVGE \ fixnum< define-jit-compare
+
+! Math
+: jit-math ( insn -- )
+ arg0 ds-reg [] MOV ! load second input
+ ds-reg bootstrap-cell SUB ! pop stack
+ arg1 ds-reg [] MOV ! load first input
+ [ arg1 arg0 ] dip execute ! compute result
+ ds-reg [] arg1 MOV ! push result
+ ;
+
+[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
+
+[ \ SUB jit-math ] f f f \ fixnum-fast define-sub-primitive
[
- stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
-] f f f jit-epilog jit-define
+ arg0 ds-reg [] MOV ! load second input
+ ds-reg bootstrap-cell SUB ! pop stack
+ arg1 ds-reg [] MOV ! load first input
+ arg0 tag-bits get SAR ! untag second input
+ arg0 arg1 IMUL2 ! multiply
+ ds-reg [] arg1 MOV ! push result
+] f f f \ fixnum*fast define-sub-primitive
-[ 0 RET ] f f f jit-return jit-define
+[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive
+
+[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive
+
+[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive
+
+[
+ arg0 ds-reg [] MOV ! load input input
+ arg0 NOT ! complement
+ arg0 tag-mask get XOR ! clear tag bits
+ ds-reg [] arg0 MOV ! save
+] f f f \ fixnum-bitnot define-sub-primitive
[ "bootstrap.x86" forget-vocab ] with-compilation-unit
diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor
index ac79cce799..6f5277bc35 100755
--- a/core/inference/known-words/known-words.factor
+++ b/core/inference/known-words/known-words.factor
@@ -104,6 +104,8 @@ M: object infer-call
] if
] "infer" set-word-prop
+\ execute t "no-compile" set-word-prop
+
\ if [
3 ensure-values
2 d-tail [ special? ] contains? [
@@ -123,6 +125,8 @@ M: object infer-call
[ #dispatch ] infer-branches
] "infer" set-word-prop
+\ dispatch t "no-compile" set-word-prop
+
\ curry [
2 ensure-values
pop-d pop-d swap <curried> push-d
diff --git a/core/words/words.factor b/core/words/words.factor
index 9bf006fa16..1d84acbc14 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -34,7 +34,9 @@ M: symbol definer drop \ SYMBOL: f ;
M: symbol definition drop f ;
PREDICATE: primitive < word ( obj -- ? )
- def>> [ do-primitive ] tail? ;
+ [ def>> [ do-primitive ] tail? ]
+ [ sub-primitive>> >boolean ]
+ bi or ;
M: primitive definer drop \ PRIMITIVE: f ;
M: primitive definition drop f ;
diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor
index ef2bfd3d55..cc138dad92 100755
--- a/extra/irc/ui/ui.factor
+++ b/extra/irc/ui/ui.factor
@@ -82,10 +82,10 @@ M: irc-message write-irc
<scrolling-pane>
[ <pane-stream> swap display ] keep ;
-TUPLE: irc-editor outstream listener client ;
+TUPLE: irc-editor < editor outstream listener client ;
: <irc-editor> ( pane listener client -- editor )
- [ <editor> irc-editor construct-editor
+ [ irc-editor new-editor
swap >>listener swap <pane-stream> >>outstream
] dip client>> >>client ;
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 147e5b892e..cee0493459 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings fry namespaces math assocs shuffle debugger io
- vectors arrays math.parser math.order vectors combinators combinators.lib
+ vectors arrays math.parser math.order vectors combinators
classes sets unicode.categories compiler.units parser
words quotations effects memoize accessors locals effects splitting
combinators.short-circuit combinators.short-circuit.smart ;
diff --git a/extra/tuple-arrays/tuple-arrays-tests.factor b/extra/tuple-arrays/tuple-arrays-tests.factor
index dd9510405f..132a11f4a6 100755
--- a/extra/tuple-arrays/tuple-arrays-tests.factor
+++ b/extra/tuple-arrays/tuple-arrays-tests.factor
@@ -6,7 +6,7 @@ TUPLE: foo bar ;
C: <foo> foo
[ 2 ] [ 2 T{ foo } <tuple-array> dup mat set length ] unit-test
[ T{ foo } ] [ mat get first ] unit-test
-[ T{ foo f 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test
+[ T{ foo 2 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test
[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test
[ T{ foo f 3 } t ]
[ mat get [ foo-bar 2 + <foo> ] map [ first ] keep tuple-array? ] unit-test
diff --git a/extra/tuple-arrays/tuple-arrays.factor b/extra/tuple-arrays/tuple-arrays.factor
index 6a31dac808..63e7541c95 100644
--- a/extra/tuple-arrays/tuple-arrays.factor
+++ b/extra/tuple-arrays/tuple-arrays.factor
@@ -1,35 +1,26 @@
! Copyright (C) 2007 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: splitting grouping classes.tuple classes math kernel
-sequences arrays ;
+sequences arrays accessors ;
IN: tuple-arrays
-TUPLE: tuple-array example ;
-
-: prepare-example ( tuple -- seq n )
- dup class over delegate [ 1array ] [ f 2array ] if
- swap tuple>array length over length - ;
+TUPLE: tuple-array seq class ;
: <tuple-array> ( length example -- tuple-array )
- prepare-example [ rot * { } new-sequence ] keep
- <sliced-groups> tuple-array construct-delegate
- [ set-tuple-array-example ] keep ;
-
-: reconstruct ( seq example -- tuple )
- prepend >tuple ;
+ [ tuple>array length 1- [ * { } new-sequence ] keep <sliced-groups> ]
+ [ class ] bi tuple-array boa ;
M: tuple-array nth
- [ delegate nth ] keep
- tuple-array-example reconstruct ;
+ [ seq>> nth ] [ class>> ] bi prefix >tuple ;
-: deconstruct ( tuple example -- seq )
- >r tuple>array r> length tail-slice ;
+: deconstruct ( tuple -- seq )
+ tuple>array 1 tail ;
M: tuple-array set-nth ( elt n seq -- )
- tuck >r >r tuple-array-example deconstruct r> r>
- delegate set-nth ;
+ >r >r deconstruct r> r> seq>> set-nth ;
-M: tuple-array new-sequence tuple-array-example >tuple <tuple-array> ;
+M: tuple-array new-sequence
+ class>> new <tuple-array> ;
: >tuple-array ( seq -- tuple-array/seq )
dup empty? [
@@ -39,4 +30,6 @@ M: tuple-array new-sequence tuple-array-example >tuple <tuple-array> ;
M: tuple-array like
drop dup tuple-array? [ >tuple-array ] unless ;
+M: tuple-array length seq>> length ;
+
INSTANCE: tuple-array sequence
diff --git a/extra/ui/gadgets/tabs/tabs.factor b/extra/ui/gadgets/tabs/tabs.factor
index 1b4f633609..7c663f88e3 100755
--- a/extra/ui/gadgets/tabs/tabs.factor
+++ b/extra/ui/gadgets/tabs/tabs.factor
@@ -51,6 +51,6 @@ DEFER: (del-page)
tabbed new-frame
[ g 0 <model> >>model
<pile> 1 >>fill [ >>toggler ] keep swap @left grid-add
- [ keys g swap >>names ]
+ [ keys >vector g swap >>names ]
[ values g model>> <book> [ >>content ] keep swap @center grid-add ] bi
g redo-toggler g ] with-gadget ;
diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S
index 6233b4a14f..b1a3561974 100644
--- a/vm/cpu-x86.32.S
+++ b/vm/cpu-x86.32.S
@@ -6,7 +6,6 @@ and the callstack top is passed in EDX */
#define ARG0 %eax
#define ARG1 %edx
-#define XT_REG %ecx
#define STACK_REG %esp
#define DS_REG %esi
#define RETURN_REG %eax
@@ -22,9 +21,6 @@ and the callstack top is passed in EDX */
pop %ebx
#define QUOT_XT_OFFSET 9
-#define PROFILING_OFFSET 25
-#define WORD_DEF_OFFSET 13
-#define WORD_XT_OFFSET 29
/* We pass a function pointer to memcpy to work around a Mac OS X
ABI limitation which would otherwise require us to do a bizzaro PC-relative
diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S
index 4e8faa18de..57bfcee87b 100644
--- a/vm/cpu-x86.64.S
+++ b/vm/cpu-x86.64.S
@@ -2,7 +2,6 @@
#define ARG0 %rdi
#define ARG1 %rsi
-#define XT_REG %rcx
#define STACK_REG %rsp
#define DS_REG %r14
#define RETURN_REG %rax
@@ -22,9 +21,6 @@
pop %rbx
#define QUOT_XT_OFFSET 21
-#define PROFILING_OFFSET 53
-#define WORD_DEF_OFFSET 29
-#define WORD_XT_OFFSET 61
/* We pass a function pointer to memcpy to work around a Mac OS X
ABI limitation which would otherwise require us to do a bizzaro PC-relative
diff --git a/vm/cpu-x86.S b/vm/cpu-x86.S
index 5c0a105a55..e8e2af7b25 100755
--- a/vm/cpu-x86.S
+++ b/vm/cpu-x86.S
@@ -1,5 +1,3 @@
-#define JUMP_QUOT jmp *QUOT_XT_OFFSET(ARG0)
-
DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
PUSH_NONVOLATILE
push ARG0 /* Save quot */
@@ -14,20 +12,9 @@ DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
POP_NONVOLATILE
ret
-DEF(F_FASTCALL void,primitive_call,(void)):
- mov (DS_REG),ARG0 /* Load quotation from data stack */
- sub $CELL_SIZE,DS_REG /* Pop data stack */
- JUMP_QUOT
-
-/* Don't mess up EDX, it's the callstack top parameter to primitives. */
-DEF(F_FASTCALL void,primitive_execute,(void)):
- mov (DS_REG),ARG0 /* Load word from data stack */
- sub $CELL_SIZE,DS_REG /* Pop data stack */
- jmp *WORD_XT_OFFSET(ARG0) /* Load word-xt slot */
-
DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
mov ARG1,STACK_REG /* rewind_to */
- JUMP_QUOT
+ jmp *QUOT_XT_OFFSET(ARG0)
DEF(FASTCALL void,lazy_jit_compile,(CELL quot)):
mov STACK_REG,ARG1 /* Save stack pointer */
@@ -39,7 +26,7 @@ DEF(FASTCALL void,lazy_jit_compile,(CELL quot)):
pop ARG1 /* OK to clobber ARG1 here */
pop ARG1
pop ARG1
- JUMP_QUOT /* Call the quotation */
+ jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */
#ifdef WINDOWS
.section .drectve
diff --git a/vm/layouts.h b/vm/layouts.h
index 06a37672a7..7ebfe50dd4 100755
--- a/vm/layouts.h
+++ b/vm/layouts.h
@@ -129,6 +129,8 @@ typedef struct {
CELL compiledp;
/* TAGGED call count for profiling */
CELL counter;
+ /* TAGGED machine code for sub-primitive */
+ CELL subprimitive;
/* UNTAGGED execution token: jump here to execute word */
XT xt;
/* UNTAGGED compiled code block */
diff --git a/vm/math.c b/vm/math.c
index 8c4e7d537a..c1e13951dc 100644
--- a/vm/math.c
+++ b/vm/math.c
@@ -35,33 +35,18 @@ DEFINE_PRIMITIVE(float_to_fixnum)
F_FIXNUM y = untag_fixnum_fast(dpop()); \
F_FIXNUM x = untag_fixnum_fast(dpop());
-/* The fixnum arithmetic operations defined in C are relatively slow.
-The Factor compiler has optimized assembly intrinsics for some of these
-operations. */
DEFINE_PRIMITIVE(fixnum_add)
{
POP_FIXNUMS(x,y)
box_signed_cell(x + y);
}
-DEFINE_PRIMITIVE(fixnum_add_fast)
-{
- POP_FIXNUMS(x,y)
- dpush(tag_fixnum(x + y));
-}
-
DEFINE_PRIMITIVE(fixnum_subtract)
{
POP_FIXNUMS(x,y)
box_signed_cell(x - y);
}
-DEFINE_PRIMITIVE(fixnum_subtract_fast)
-{
- POP_FIXNUMS(x,y)
- dpush(tag_fixnum(x - y));
-}
-
/* Multiply two integers, and trap overflow.
Thanks to David Blaikie (The_Vulture from freenode #java) for the hint. */
DEFINE_PRIMITIVE(fixnum_multiply)
@@ -87,12 +72,6 @@ DEFINE_PRIMITIVE(fixnum_multiply)
}
}
-DEFINE_PRIMITIVE(fixnum_multiply_fast)
-{
- POP_FIXNUMS(x,y)
- dpush(tag_fixnum(x * y));
-}
-
DEFINE_PRIMITIVE(fixnum_divint)
{
POP_FIXNUMS(x,y)
@@ -112,24 +91,6 @@ DEFINE_PRIMITIVE(fixnum_mod)
dpush(tag_fixnum(x % y));
}
-DEFINE_PRIMITIVE(fixnum_and)
-{
- POP_FIXNUMS(x,y)
- dpush(tag_fixnum(x & y));
-}
-
-DEFINE_PRIMITIVE(fixnum_or)
-{
- POP_FIXNUMS(x,y)
- dpush(tag_fixnum(x | y));
-}
-
-DEFINE_PRIMITIVE(fixnum_xor)
-{
- POP_FIXNUMS(x,y)
- dpush(tag_fixnum(x ^ y));
-}
-
/*
* Note the hairy overflow check.
* If we're shifting right by n bits, we won't overflow as long as none of the
@@ -172,35 +133,6 @@ DEFINE_PRIMITIVE(fixnum_shift_fast)
dpush(tag_fixnum(y < 0 ? (x >> -y) : (x << y)));
}
-DEFINE_PRIMITIVE(fixnum_less)
-{
- POP_FIXNUMS(x,y)
- box_boolean(x < y);
-}
-
-DEFINE_PRIMITIVE(fixnum_lesseq)
-{
- POP_FIXNUMS(x,y)
- box_boolean(x <= y);
-}
-
-DEFINE_PRIMITIVE(fixnum_greater)
-{
- POP_FIXNUMS(x,y)
- box_boolean(x > y);
-}
-
-DEFINE_PRIMITIVE(fixnum_greatereq)
-{
- POP_FIXNUMS(x,y)
- box_boolean(x >= y);
-}
-
-DEFINE_PRIMITIVE(fixnum_not)
-{
- drepl(tag_fixnum(~untag_fixnum_fast(dpeek())));
-}
-
/* Bignums */
DEFINE_PRIMITIVE(fixnum_to_bignum)
{
diff --git a/vm/math.h b/vm/math.h
index d82a373571..6f81ece8a8 100644
--- a/vm/math.h
+++ b/vm/math.h
@@ -11,23 +11,12 @@ DECLARE_PRIMITIVE(float_to_fixnum);
DECLARE_PRIMITIVE(fixnum_add);
DECLARE_PRIMITIVE(fixnum_subtract);
-DECLARE_PRIMITIVE(fixnum_add_fast);
-DECLARE_PRIMITIVE(fixnum_subtract_fast);
DECLARE_PRIMITIVE(fixnum_multiply);
-DECLARE_PRIMITIVE(fixnum_multiply_fast);
DECLARE_PRIMITIVE(fixnum_divint);
DECLARE_PRIMITIVE(fixnum_divmod);
DECLARE_PRIMITIVE(fixnum_mod);
-DECLARE_PRIMITIVE(fixnum_and);
-DECLARE_PRIMITIVE(fixnum_or);
-DECLARE_PRIMITIVE(fixnum_xor);
DECLARE_PRIMITIVE(fixnum_shift);
DECLARE_PRIMITIVE(fixnum_shift_fast);
-DECLARE_PRIMITIVE(fixnum_less);
-DECLARE_PRIMITIVE(fixnum_lesseq);
-DECLARE_PRIMITIVE(fixnum_greater);
-DECLARE_PRIMITIVE(fixnum_greatereq);
-DECLARE_PRIMITIVE(fixnum_not);
CELL bignum_zero;
CELL bignum_pos_one;
diff --git a/vm/primitives.c b/vm/primitives.c
index d670b41897..b5d9403342 100755
--- a/vm/primitives.c
+++ b/vm/primitives.c
@@ -1,8 +1,6 @@
#include "master.h"
void *primitives[] = {
- primitive_execute,
- primitive_call,
primitive_bignum_to_fixnum,
primitive_float_to_fixnum,
primitive_fixnum_to_bignum,
@@ -18,24 +16,13 @@ void *primitives[] = {
primitive_bits_double,
primitive_from_rect,
primitive_fixnum_add,
- primitive_fixnum_add_fast,
primitive_fixnum_subtract,
- primitive_fixnum_subtract_fast,
primitive_fixnum_multiply,
- primitive_fixnum_multiply_fast,
primitive_fixnum_divint,
primitive_fixnum_mod,
primitive_fixnum_divmod,
- primitive_fixnum_and,
- primitive_fixnum_or,
- primitive_fixnum_xor,
- primitive_fixnum_not,
primitive_fixnum_shift,
primitive_fixnum_shift_fast,
- primitive_fixnum_less,
- primitive_fixnum_lesseq,
- primitive_fixnum_greater,
- primitive_fixnum_greatereq,
primitive_bignum_eq,
primitive_bignum_add,
primitive_bignum_subtract,
@@ -67,25 +54,6 @@ void *primitives[] = {
primitive_float_greatereq,
primitive_word,
primitive_word_xt,
- primitive_drop,
- primitive_2drop,
- primitive_3drop,
- primitive_dup,
- primitive_2dup,
- primitive_3dup,
- primitive_rot,
- primitive__rot,
- primitive_dupd,
- primitive_swapd,
- primitive_nip,
- primitive_2nip,
- primitive_tuck,
- primitive_over,
- primitive_pick,
- primitive_swap,
- primitive_to_r,
- primitive_from_r,
- primitive_eq,
primitive_getenv,
primitive_setenv,
primitive_existsp,
@@ -105,7 +73,6 @@ void *primitives[] = {
primitive_code_room,
primitive_os_env,
primitive_millis,
- primitive_tag,
primitive_modify_code_heap,
primitive_dlopen,
primitive_dlsym,
@@ -140,7 +107,6 @@ void *primitives[] = {
primitive_set_alien_cell,
primitive_throw,
primitive_alien_address,
- primitive_slot,
primitive_set_slot,
primitive_string_nth,
primitive_set_string_nth,
diff --git a/vm/quotations.c b/vm/quotations.c
index 7eab41688a..2d54f23a6f 100755
--- a/vm/quotations.c
+++ b/vm/quotations.c
@@ -1,8 +1,38 @@
#include "master.h"
-/* Simple JIT compiler. This is one of the two compilers implementing Factor;
-the second one is written in Factor and performs a lot of optimizations.
-See core/compiler/compiler.factor */
+/* Simple non-optimizing compiler.
+
+This is one of the two compilers implementing Factor; the second one is written
+in Factor and performs advanced optimizations. See core/compiler/compiler.factor.
+
+The non-optimizing compiler compiles a quotation at a time by concatenating
+machine code chunks; prolog, epilog, call word, jump to word, etc. These machine
+code chunks are generated from Factor code in core/cpu/.../bootstrap.factor.
+
+It actually does do a little bit of very simple optimization:
+
+1) Tail call optimization.
+
+2) If a quotation is determined to not call any other words (except for a few
+special words which are open-coded, see below), then no prolog/epilog is
+generated.
+
+3) When in tail position and immediately preceded by literal arguments, the
+'if' and 'dispatch' conditionals are generated inline, instead of as a call to
+the 'if' word.
+
+4) When preceded by an array, calls to the 'declare' word are optimized out
+entirely. This word is only used by the optimizing compiler, and with the
+non-optimizing compiler it would otherwise just decrease performance to have to
+push the array and immediately drop it after.
+
+5) Sub-primitives are primitive words which are implemented in assembly and not
+in the VM. They are open-coded and no subroutine call is generated. This
+includes stack shufflers, some fixnum arithmetic words, and words such as tag,
+slot and eq?. A primitive call is relatively expensive (two subroutine calls)
+so this results in a big speedup for relatively little effort.
+
+*/
bool jit_primitive_call_p(F_ARRAY *array, CELL i)
{
return (i + 2) == array_capacity(array)
@@ -32,15 +62,15 @@ bool jit_ignore_declare_p(F_ARRAY *array, CELL i)
&& array_nth(array,i + 1) == userenv[JIT_DECLARE_WORD];
}
-F_ARRAY *code_to_emit(CELL name)
+F_ARRAY *code_to_emit(CELL code)
{
- return untag_object(array_nth(untag_object(userenv[name]),0));
+ return untag_object(array_nth(untag_object(code),0));
}
-F_REL rel_to_emit(CELL name, CELL code_format, CELL code_length,
+F_REL rel_to_emit(CELL code, CELL code_format, CELL code_length,
CELL rel_argument, bool *rel_p)
{
- F_ARRAY *quadruple = untag_object(userenv[name]);
+ F_ARRAY *quadruple = untag_object(code);
CELL rel_class = array_nth(quadruple,1);
CELL rel_type = array_nth(quadruple,2);
CELL offset = array_nth(quadruple,3);
@@ -82,20 +112,9 @@ bool jit_stack_frame_p(F_ARRAY *array)
CELL obj = array_nth(array,i);
if(type_of(obj) == WORD_TYPE)
{
- if(obj != userenv[JIT_TAG_WORD]
- && obj != userenv[JIT_EQP_WORD]
- && obj != userenv[JIT_SLOT_WORD]
- && obj != userenv[JIT_DROP_WORD]
- && obj != userenv[JIT_DUP_WORD]
- && obj != userenv[JIT_TO_R_WORD]
- && obj != userenv[JIT_FROM_R_WORD]
- && obj != userenv[JIT_SWAP_WORD]
- && obj != userenv[JIT_OVER_WORD]
- && obj != userenv[JIT_FIXNUM_MINUS_WORD]
- && obj != userenv[JIT_FIXNUM_GE_WORD])
- {
+ F_WORD *word = untag_object(obj);
+ if(word->subprimitive == F && obj != userenv[JIT_DECLARE_WORD])
return true;
- }
}
}
@@ -139,7 +158,7 @@ void jit_compile(CELL quot, bool relocate)
bool stack_frame = jit_stack_frame_p(untag_object(array));
if(stack_frame)
- EMIT(JIT_PROLOG,0);
+ EMIT(userenv[JIT_PROLOG],0);
CELL i;
CELL length = array_capacity(untag_object(array));
@@ -154,84 +173,44 @@ void jit_compile(CELL quot, bool relocate)
switch(type_of(obj))
{
case WORD_TYPE:
+ word = untag_object(obj);
+
/* Intrinsics */
- if(obj == userenv[JIT_TAG_WORD])
+ if(word->subprimitive != F)
{
- EMIT(JIT_TAG,0);
- }
- else if(obj == userenv[JIT_EQP_WORD])
- {
- GROWABLE_ARRAY_ADD(literals,T);
- EMIT(JIT_EQP,literals_count - 1);
- }
- else if(obj == userenv[JIT_SLOT_WORD])
- {
- EMIT(JIT_SLOT,0);
- }
- else if(obj == userenv[JIT_DROP_WORD])
- {
- EMIT(JIT_DROP,0);
- }
- else if(obj == userenv[JIT_DUP_WORD])
- {
- EMIT(JIT_DUP,0);
- }
- else if(obj == userenv[JIT_TO_R_WORD])
- {
- EMIT(JIT_TO_R,0);
- }
- else if(obj == userenv[JIT_FROM_R_WORD])
- {
- EMIT(JIT_FROM_R,0);
- }
- else if(obj == userenv[JIT_SWAP_WORD])
- {
- EMIT(JIT_SWAP,0);
- }
- else if(obj == userenv[JIT_OVER_WORD])
- {
- EMIT(JIT_OVER,0);
- }
- else if(obj == userenv[JIT_FIXNUM_MINUS_WORD])
- {
- EMIT(JIT_FIXNUM_MINUS,0);
- }
- else if(obj == userenv[JIT_FIXNUM_GE_WORD])
- {
- GROWABLE_ARRAY_ADD(literals,T);
- EMIT(JIT_FIXNUM_GE,literals_count - 1);
+ if(array_nth(untag_object(word->subprimitive),1) != F)
+ {
+ GROWABLE_ARRAY_ADD(literals,T);
+ }
+
+ EMIT(word->subprimitive,literals_count - 1);
}
else
{
- /* Emit the epilog before the primitive call gate
- so that we save the C stack pointer minus the
- current stack frame. */
- word = untag_object(obj);
-
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
if(i == length - 1)
{
if(stack_frame)
- EMIT(JIT_EPILOG,0);
+ EMIT(userenv[JIT_EPILOG],0);
- EMIT(JIT_WORD_JUMP,literals_count - 1);
+ EMIT(userenv[JIT_WORD_JUMP],literals_count - 1);
tail_call = true;
}
else
- EMIT(JIT_WORD_CALL,literals_count - 1);
+ EMIT(userenv[JIT_WORD_CALL],literals_count - 1);
}
break;
case WRAPPER_TYPE:
wrapper = untag_object(obj);
GROWABLE_ARRAY_ADD(literals,wrapper->object);
- EMIT(JIT_PUSH_LITERAL,literals_count - 1);
+ EMIT(userenv[JIT_PUSH_LITERAL],literals_count - 1);
break;
case FIXNUM_TYPE:
if(jit_primitive_call_p(untag_object(array),i))
{
- EMIT(JIT_PRIMITIVE,to_fixnum(obj));
+ EMIT(userenv[JIT_PRIMITIVE],to_fixnum(obj));
i++;
@@ -242,11 +221,11 @@ void jit_compile(CELL quot, bool relocate)
if(jit_fast_if_p(untag_object(array),i))
{
if(stack_frame)
- EMIT(JIT_EPILOG,0);
+ EMIT(userenv[JIT_EPILOG],0);
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i + 1));
- EMIT(JIT_IF_JUMP,literals_count - 2);
+ EMIT(userenv[JIT_IF_JUMP],literals_count - 2);
i += 2;
@@ -257,10 +236,10 @@ void jit_compile(CELL quot, bool relocate)
if(jit_fast_dispatch_p(untag_object(array),i))
{
if(stack_frame)
- EMIT(JIT_EPILOG,0);
+ EMIT(userenv[JIT_EPILOG],0);
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
- EMIT(JIT_DISPATCH,literals_count - 1);
+ EMIT(userenv[JIT_DISPATCH],literals_count - 1);
i++;
@@ -274,7 +253,7 @@ void jit_compile(CELL quot, bool relocate)
}
default:
GROWABLE_ARRAY_ADD(literals,obj);
- EMIT(JIT_PUSH_LITERAL,literals_count - 1);
+ EMIT(userenv[JIT_PUSH_LITERAL],literals_count - 1);
break;
}
}
@@ -282,9 +261,9 @@ void jit_compile(CELL quot, bool relocate)
if(!tail_call)
{
if(stack_frame)
- EMIT(JIT_EPILOG,0);
+ EMIT(userenv[JIT_EPILOG],0);
- EMIT(JIT_RETURN,0);
+ EMIT(userenv[JIT_RETURN],0);
}
GROWABLE_ARRAY_TRIM(code);
@@ -330,7 +309,7 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
bool stack_frame = jit_stack_frame_p(untag_object(array));
if(stack_frame)
- COUNT(JIT_PROLOG,0)
+ COUNT(userenv[JIT_PROLOG],0)
CELL i;
CELL length = array_capacity(untag_object(array));
@@ -339,55 +318,34 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
for(i = 0; i < length; i++)
{
CELL obj = array_nth(untag_object(array),i);
+ F_WORD *word;
switch(type_of(obj))
{
case WORD_TYPE:
/* Intrinsics */
- if(obj == userenv[JIT_TAG_WORD])
- COUNT(JIT_TAG,i)
- else if(obj == userenv[JIT_EQP_WORD])
- COUNT(JIT_EQP,i)
- else if(obj == userenv[JIT_SLOT_WORD])
- COUNT(JIT_SLOT,i)
- else if(obj == userenv[JIT_DROP_WORD])
- COUNT(JIT_DROP,i)
- else if(obj == userenv[JIT_DUP_WORD])
- COUNT(JIT_DUP,i)
- else if(obj == userenv[JIT_TO_R_WORD])
- COUNT(JIT_TO_R,i)
- else if(obj == userenv[JIT_FROM_R_WORD])
- COUNT(JIT_FROM_R,i)
- else if(obj == userenv[JIT_SWAP_WORD])
- COUNT(JIT_SWAP,i)
- else if(obj == userenv[JIT_OVER_WORD])
- COUNT(JIT_OVER,i)
- else if(obj == userenv[JIT_FIXNUM_MINUS_WORD])
- COUNT(JIT_FIXNUM_MINUS,i)
- else if(obj == userenv[JIT_FIXNUM_GE_WORD])
- COUNT(JIT_FIXNUM_GE,i)
- else
+ word = untag_object(obj);
+ if(word->subprimitive != F)
+ COUNT(word->subprimitive,i)
+ else if(i == length - 1)
{
- if(i == length - 1)
- {
- if(stack_frame)
- COUNT(JIT_EPILOG,i);
-
- COUNT(JIT_WORD_JUMP,i)
-
- tail_call = true;
- }
- else
- COUNT(JIT_WORD_CALL,i)
+ if(stack_frame)
+ COUNT(userenv[JIT_EPILOG],i);
+
+ COUNT(userenv[JIT_WORD_JUMP],i)
+
+ tail_call = true;
}
+ else
+ COUNT(userenv[JIT_WORD_CALL],i)
break;
case WRAPPER_TYPE:
- COUNT(JIT_PUSH_LITERAL,i)
+ COUNT(userenv[JIT_PUSH_LITERAL],i)
break;
case FIXNUM_TYPE:
if(jit_primitive_call_p(untag_object(array),i))
{
- COUNT(JIT_PRIMITIVE,i);
+ COUNT(userenv[JIT_PRIMITIVE],i);
i++;
@@ -398,11 +356,11 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
if(jit_fast_if_p(untag_object(array),i))
{
if(stack_frame)
- COUNT(JIT_EPILOG,i)
+ COUNT(userenv[JIT_EPILOG],i)
i += 2;
- COUNT(JIT_IF_JUMP,i)
+ COUNT(userenv[JIT_IF_JUMP],i)
tail_call = true;
break;
@@ -411,11 +369,11 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
if(jit_fast_dispatch_p(untag_object(array),i))
{
if(stack_frame)
- COUNT(JIT_EPILOG,i)
+ COUNT(userenv[JIT_EPILOG],i)
i++;
- COUNT(JIT_DISPATCH,i)
+ COUNT(userenv[JIT_DISPATCH],i)
tail_call = true;
break;
@@ -429,7 +387,7 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
break;
}
default:
- COUNT(JIT_PUSH_LITERAL,i)
+ COUNT(userenv[JIT_PUSH_LITERAL],i)
break;
}
}
@@ -437,9 +395,9 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
if(!tail_call)
{
if(stack_frame)
- COUNT(JIT_EPILOG,length)
+ COUNT(userenv[JIT_EPILOG],length)
- COUNT(JIT_RETURN,length)
+ COUNT(userenv[JIT_RETURN],length)
}
return -1;
diff --git a/vm/run.c b/vm/run.c
index ae0c91d9e6..c4a3e115c1 100755
--- a/vm/run.c
+++ b/vm/run.c
@@ -90,133 +90,6 @@ void init_stacks(CELL ds_size_, CELL rs_size_)
stack_chain = NULL;
}
-DEFINE_PRIMITIVE(drop)
-{
- dpop();
-}
-
-DEFINE_PRIMITIVE(2drop)
-{
- ds -= 2 * CELLS;
-}
-
-DEFINE_PRIMITIVE(3drop)
-{
- ds -= 3 * CELLS;
-}
-
-DEFINE_PRIMITIVE(dup)
-{
- dpush(dpeek());
-}
-
-DEFINE_PRIMITIVE(2dup)
-{
- CELL top = dpeek();
- CELL next = get(ds - CELLS);
- ds += CELLS * 2;
- put(ds - CELLS,next);
- put(ds,top);
-}
-
-DEFINE_PRIMITIVE(3dup)
-{
- CELL c1 = dpeek();
- CELL c2 = get(ds - CELLS);
- CELL c3 = get(ds - CELLS * 2);
- ds += CELLS * 3;
- put (ds,c1);
- put (ds - CELLS,c2);
- put (ds - CELLS * 2,c3);
-}
-
-DEFINE_PRIMITIVE(rot)
-{
- CELL c1 = dpeek();
- CELL c2 = get(ds - CELLS);
- CELL c3 = get(ds - CELLS * 2);
- put(ds,c3);
- put(ds - CELLS,c1);
- put(ds - CELLS * 2,c2);
-}
-
-DEFINE_PRIMITIVE(_rot)
-{
- CELL c1 = dpeek();
- CELL c2 = get(ds - CELLS);
- CELL c3 = get(ds - CELLS * 2);
- put(ds,c2);
- put(ds - CELLS,c3);
- put(ds - CELLS * 2,c1);
-}
-
-DEFINE_PRIMITIVE(dupd)
-{
- CELL top = dpeek();
- CELL next = get(ds - CELLS);
- put(ds,next);
- put(ds - CELLS,next);
- dpush(top);
-}
-
-DEFINE_PRIMITIVE(swapd)
-{
- CELL top = get(ds - CELLS);
- CELL next = get(ds - CELLS * 2);
- put(ds - CELLS,next);
- put(ds - CELLS * 2,top);
-}
-
-DEFINE_PRIMITIVE(nip)
-{
- CELL top = dpop();
- drepl(top);
-}
-
-DEFINE_PRIMITIVE(2nip)
-{
- CELL top = dpeek();
- ds -= CELLS * 2;
- drepl(top);
-}
-
-DEFINE_PRIMITIVE(tuck)
-{
- CELL top = dpeek();
- CELL next = get(ds - CELLS);
- put(ds,next);
- put(ds - CELLS,top);
- dpush(top);
-}
-
-DEFINE_PRIMITIVE(over)
-{
- dpush(get(ds - CELLS));
-}
-
-DEFINE_PRIMITIVE(pick)
-{
- dpush(get(ds - CELLS * 2));
-}
-
-DEFINE_PRIMITIVE(swap)
-{
- CELL top = dpeek();
- CELL next = get(ds - CELLS);
- put(ds,next);
- put(ds - CELLS,top);
-}
-
-DEFINE_PRIMITIVE(to_r)
-{
- rpush(dpop());
-}
-
-DEFINE_PRIMITIVE(from_r)
-{
- dpush(rpop());
-}
-
bool stack_to_array(CELL bottom, CELL top)
{
F_FIXNUM depth = (F_FIXNUM)(top - bottom + CELLS);
@@ -280,13 +153,6 @@ DEFINE_PRIMITIVE(exit)
exit(to_fixnum(dpop()));
}
-DEFINE_PRIMITIVE(eq)
-{
- CELL lhs = dpop();
- CELL rhs = dpeek();
- drepl((lhs == rhs) ? T : F);
-}
-
DEFINE_PRIMITIVE(millis)
{
box_unsigned_8(current_millis());
@@ -297,18 +163,6 @@ DEFINE_PRIMITIVE(sleep)
sleep_millis(to_cell(dpop()));
}
-DEFINE_PRIMITIVE(tag)
-{
- drepl(tag_fixnum(TAG(dpeek())));
-}
-
-DEFINE_PRIMITIVE(slot)
-{
- F_FIXNUM slot = untag_fixnum_fast(dpop());
- CELL obj = dpop();
- dpush(get(SLOT(obj,slot)));
-}
-
DEFINE_PRIMITIVE(set_slot)
{
F_FIXNUM slot = untag_fixnum_fast(dpop());
diff --git a/vm/run.h b/vm/run.h
index b54640ec8a..8a03049b93 100755
--- a/vm/run.h
+++ b/vm/run.h
@@ -245,28 +245,9 @@ DLLEXPORT void save_stacks(void);
DLLEXPORT void nest_stacks(void);
DLLEXPORT void unnest_stacks(void);
void init_stacks(CELL ds_size, CELL rs_size);
-DECLARE_PRIMITIVE(drop);
-DECLARE_PRIMITIVE(2drop);
-DECLARE_PRIMITIVE(3drop);
-DECLARE_PRIMITIVE(dup);
-DECLARE_PRIMITIVE(2dup);
-DECLARE_PRIMITIVE(3dup);
-DECLARE_PRIMITIVE(rot);
-DECLARE_PRIMITIVE(_rot);
-DECLARE_PRIMITIVE(dupd);
-DECLARE_PRIMITIVE(swapd);
-DECLARE_PRIMITIVE(nip);
-DECLARE_PRIMITIVE(2nip);
-DECLARE_PRIMITIVE(tuck);
-DECLARE_PRIMITIVE(over);
-DECLARE_PRIMITIVE(pick);
-DECLARE_PRIMITIVE(swap);
-DECLARE_PRIMITIVE(to_r);
-DECLARE_PRIMITIVE(from_r);
+
DECLARE_PRIMITIVE(datastack);
DECLARE_PRIMITIVE(retainstack);
-DECLARE_PRIMITIVE(execute);
-DECLARE_PRIMITIVE(call);
DECLARE_PRIMITIVE(getenv);
DECLARE_PRIMITIVE(setenv);
DECLARE_PRIMITIVE(exit);
@@ -275,11 +256,8 @@ DECLARE_PRIMITIVE(os_envs);
DECLARE_PRIMITIVE(set_os_env);
DECLARE_PRIMITIVE(unset_os_env);
DECLARE_PRIMITIVE(set_os_envs);
-DECLARE_PRIMITIVE(eq);
DECLARE_PRIMITIVE(millis);
DECLARE_PRIMITIVE(sleep);
-DECLARE_PRIMITIVE(tag);
-DECLARE_PRIMITIVE(slot);
DECLARE_PRIMITIVE(set_slot);
bool stage2;
diff --git a/vm/types.c b/vm/types.c
index 3941f13042..59581ecee5 100755
--- a/vm/types.c
+++ b/vm/types.c
@@ -49,6 +49,7 @@ F_WORD *allot_word(CELL vocab, CELL name)
word->props = F;
word->counter = tag_fixnum(0);
word->compiledp = F;
+ word->subprimitive = F;
word->profiling = NULL;
word->code = NULL;