vm: big overhaul of non-optimizing compiler

- change some primitives into sub-primitives: fixnum+ fixnum- fixnum* inline-cache-miss inline-cache-miss-tail
- rename some relocation types for clarity
- some other minor re-organizations and cleanups

basis/bootstrap/image/image.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays byte-arrays generic hashtables
+USING: alien alien.strings arrays byte-arrays generic hashtables
 hashtables.private io io.binary io.files io.encodings.binary
 io.pathnames kernel kernel.private math namespaces make parser
 prettyprint sequences strings sbufs vectors words quotations
@@ -10,7 +10,7 @@ vocabs.loader source-files definitions debugger
 quotations.private combinators combinators.short-circuit
 math.order math.private accessors slots.private
 generic.single.private compiler.units compiler.constants fry
-bootstrap.image.syntax ;
+locals bootstrap.image.syntax generalizations ;
 IN: bootstrap.image
 
 : arch ( os cpu -- arch )
@@ -107,8 +107,11 @@ SYMBOL: sub-primitives
 
 SYMBOL: jit-relocations
 
+SYMBOL: jit-offset
+
 : compute-offset ( rc -- offset )
-    [ building get length ] dip rc-absolute-cell = bootstrap-cell 4 ? - ;
+    [ building get length jit-offset get + ] dip
+    rc-absolute-cell = bootstrap-cell 4 ? - ;
 
 : jit-rel ( rc rt -- )
     over compute-offset 3array jit-relocations get push-all ;
@@ -123,8 +126,21 @@ SYMBOL: jit-literals
 : jit-literal ( literal -- )
     jit-literals get push ;
 
-: make-jit ( quot -- jit-parameters jit-literals jit-data )
+: jit-vm ( offset rc -- )
+    [ jit-parameter ] dip rt-vm jit-rel ;
+
+: jit-dlsym ( name library rc -- )
+    rt-dlsym jit-rel [ string>symbol jit-parameter ] bi@ ;
+
+:: jit-conditional ( test-quot false-quot -- )
+    [ 0 test-quot call ] B{ } make length :> len
+    building get length jit-offset get + len +
+    [ jit-offset set false-quot call ] B{ } make
+    [ length test-quot call ] [ % ] bi ; inline
+
+: make-jit ( quot -- jit-parameters jit-literals jit-code )
     [
+        0 jit-offset set
         V{ } clone jit-parameters set
         V{ } clone jit-literals set
         V{ } clone jit-relocations set
@@ -140,6 +156,15 @@ SYMBOL: jit-literals
 : define-sub-primitive ( quot word -- )
     [ make-jit 3array ] dip sub-primitives get set-at ;
 
+: define-sub-primitive* ( quot non-tail-quot tail-quot word -- )
+    [
+        [ make-jit ]
+        [ make-jit 2nip ]
+        [ make-jit 2nip ]
+        tri* 5 narray
+    ] dip
+    sub-primitives get set-at ;
+
 ! The image being constructed; a vector of word-size integers
 SYMBOL: image
 
@@ -163,35 +188,32 @@ USERENV: jit-primitive-word 24
 USERENV: jit-primitive 25
 USERENV: jit-word-jump 26
 USERENV: jit-word-call 27
-USERENV: jit-word-special 28
+USERENV: jit-if-word 28
-USERENV: jit-if-word 29
+USERENV: jit-if 29
-USERENV: jit-if 30
+USERENV: jit-epilog 30
-USERENV: jit-epilog 31
+USERENV: jit-return 31
-USERENV: jit-return 32
+USERENV: jit-profiling 32
-USERENV: jit-profiling 33
+USERENV: jit-push-immediate 33
-USERENV: jit-push-immediate 34
+USERENV: jit-dip-word 34
-USERENV: jit-dip-word 35
+USERENV: jit-dip 35
-USERENV: jit-dip 36
+USERENV: jit-2dip-word 36
-USERENV: jit-2dip-word 37
+USERENV: jit-2dip 37
-USERENV: jit-2dip 38
+USERENV: jit-3dip-word 38
-USERENV: jit-3dip-word 39
+USERENV: jit-3dip 39
-USERENV: jit-3dip 40
+USERENV: jit-execute 40
-USERENV: jit-execute-word 41
+USERENV: jit-declare-word 41
-USERENV: jit-execute-jump 42
-USERENV: jit-execute-call 43
-USERENV: jit-declare-word 44
 
-USERENV: callback-stub 45
+USERENV: callback-stub 48
 
 ! PIC stubs
-USERENV: pic-load 47
+USERENV: pic-load 49
-USERENV: pic-tag 48
+USERENV: pic-tag 50
-USERENV: pic-tuple 49
+USERENV: pic-tuple 51
-USERENV: pic-check-tag 50
+USERENV: pic-check-tag 52
-USERENV: pic-check-tuple 51
+USERENV: pic-check-tuple 53
-USERENV: pic-hit 52
+USERENV: pic-hit 54
-USERENV: pic-miss-word 53
+USERENV: pic-miss-word 55
-USERENV: pic-miss-tail-word 54
+USERENV: pic-miss-tail-word 56
 
 ! Megamorphic dispatch
 USERENV: mega-lookup 57
@@ -513,7 +535,6 @@ M: quotation '
     \ dip jit-dip-word set
     \ 2dip jit-2dip-word set
     \ 3dip jit-3dip-word set
-    \ (execute) jit-execute-word set
     \ inline-cache-miss \ pic-miss-word set
     \ inline-cache-miss-tail \ pic-miss-tail-word set
     \ mega-cache-lookup \ mega-lookup-word set

basis/compiler/cfg/build-stack-frame/build-stack-frame.factor

@@ -22,8 +22,7 @@ UNION: stack-frame-insn
 M: stack-frame-insn compute-stack-frame*
     stack-frame>> request-stack-frame ;
 
-M: ##call compute-stack-frame*
+M: ##call compute-stack-frame* drop frame-required? on ;
-    word>> sub-primitive>> [ frame-required? on ] unless ;
 
 M: ##gc compute-stack-frame*
     frame-required? on

basis/compiler/codegen/codegen.factor

@@ -61,9 +61,7 @@ SYMBOL: labels
 ! Special cases
 M: ##no-tco generate-insn drop ;
 
-M: ##call generate-insn
+M: ##call generate-insn word>> [ add-call ] [ %call ] bi ;
-    word>> dup sub-primitive>>
-    [ third first % ] [ [ add-call ] [ %call ] bi ] ?if ;
 
 M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
 

basis/compiler/codegen/fixup/fixup.factor

@@ -74,7 +74,7 @@ SYMBOL: relocation-table
     [ def>> first add-parameter ] dip rt-primitive rel-fixup ;
 
 : rel-immediate ( literal class -- )
-    [ add-literal ] dip rt-immediate rel-fixup ;
+    [ add-literal ] dip rt-literal rel-fixup ;
 
 : rel-this ( class -- )
     rt-this rel-fixup ;

basis/compiler/constants/constants.factor

@@ -47,8 +47,8 @@ CONSTANT: rt-xt-pic 4
 CONSTANT: rt-xt-pic-tail 5
 CONSTANT: rt-here 6
 CONSTANT: rt-this 7
-CONSTANT: rt-immediate 8
+CONSTANT: rt-literal 8
-CONSTANT: rt-stack-chain 9
+CONSTANT: rt-context 9
 CONSTANT: rt-untagged 10
 CONSTANT: rt-megamorphic-cache-hits 11
 CONSTANT: rt-vm 12

basis/cpu/ppc/bootstrap.factor

@@ -1,9 +1,9 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: bootstrap.image.private kernel kernel.private namespaces
 system cpu.ppc.assembler compiler.codegen.fixup compiler.units
-compiler.constants math math.private layouts words
+compiler.constants math math.private layouts words vocabs
-vocabs slots.private locals.backend ;
+slots.private locals locals.backend generic.single.private fry ;
 FROM: cpu.ppc.assembler => B ;
 IN: bootstrap.ppc
 
@@ -21,8 +21,16 @@ CONSTANT: rs-reg 14
 : next-save ( -- n ) stack-frame bootstrap-cell - ;
 : xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;
 
+: jit-conditional* ( test-quot true-quot -- )
+    [ '[ bootstrap-cell /i 1 + @ ] ] dip jit-conditional ; inline
+
+: jit-save-context ( -- )
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-context jit-rel
+    4 3 0 LWZ
+    1 4 0 STW ;
+
 [
-    0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel
     11 3 profile-count-offset LWZ
     11 11 1 tag-fixnum ADDI
     11 3 profile-count-offset STW
@@ -43,14 +51,12 @@ CONSTANT: rs-reg 14
 ] jit-prolog jit-define
 
 [
-    0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel
     3 ds-reg 4 STWU
 ] jit-push-immediate jit-define
 
 [
-    0 3 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
+    jit-save-context
-    4 3 0 LWZ
-    1 4 0 STW
     4 0 swap LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel
     0 5 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
     5 MTCTR
@@ -64,14 +70,11 @@ CONSTANT: rs-reg 14
     0 B rc-relative-ppc-3 rt-xt-pic-tail jit-rel
 ] jit-word-jump jit-define
 
-[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-special jit-define
-
 [
     3 ds-reg 0 LWZ
     ds-reg dup 4 SUBI
     0 3 \ f type-number CMPI
-    2 BEQ
+    [ BEQ ] [ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-conditional*
-    0 B rc-relative-ppc-3 rt-xt jit-rel
     0 B rc-relative-ppc-3 rt-xt jit-rel
 ] jit-if jit-define
 
@@ -139,16 +142,6 @@ CONSTANT: rs-reg 14
     jit-3r>
 ] jit-3dip jit-define
 
-: prepare-(execute) ( -- operand )
-    3 ds-reg 0 LWZ
-    ds-reg dup 4 SUBI
-    4 3 word-xt-offset LWZ
-    4 ;
-
-[ prepare-(execute) MTCTR BCTR ] jit-execute-jump jit-define
-
-[ prepare-(execute) MTLR BLRL ] jit-execute-call jit-define
-
 [
     0 1 lr-save stack-frame + LWZ
     1 1 stack-frame ADDI
@@ -179,26 +172,29 @@ CONSTANT: rs-reg 14
     3 4 MR
     load-tag
     0 4 tuple type-number tag-fixnum CMPI
-    2 BNE
+    [ BNE ]
-    4 3 tuple type-number neg bootstrap-cell + LWZ
+    [ 4 3 tuple type-number neg bootstrap-cell + LWZ ]
+    jit-conditional*
 ] pic-tuple jit-define
 
 [
-    0 4 0 CMPI rc-absolute-ppc-2 rt-immediate jit-rel
+    0 4 0 CMPI rc-absolute-ppc-2 rt-literal jit-rel
 ] pic-check-tag jit-define
 
 [
-    0 5 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
+    0 5 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel
     4 0 5 CMP
 ] pic-check-tuple jit-define
 
-[ 2 BNE 0 B rc-relative-ppc-3 rt-xt jit-rel ] pic-hit jit-define
+[
+    [ BNE ] [ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-conditional*
+] pic-hit jit-define
 
 ! ! ! Megamorphic caches
 
 [
     ! cache = ...
-    0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel
     ! key = hashcode(class)
     5 4 1 SRAWI
     ! key &= cache.length - 1
@@ -210,7 +206,8 @@ CONSTANT: rs-reg 14
     ! if(get(cache) == class)
     6 3 0 LWZ
     6 0 4 CMP
-    10 BNE
+    [ BNE ]
+    [
         ! megamorphic_cache_hits++
         0 4 LOAD32 rc-absolute-ppc-2/2 rt-megamorphic-cache-hits jit-rel
         5 4 0 LWZ
@@ -221,6 +218,8 @@ CONSTANT: rs-reg 14
         3 3 word-xt-offset LWZ
         3 MTCTR
         BCTR
+    ]
+    jit-conditional*
     ! fall-through on miss
 ] mega-lookup jit-define
 
@@ -238,9 +237,24 @@ CONSTANT: rs-reg 14
     ds-reg dup 4 SUBI
     4 0 swap LOAD32 0 jit-parameter rc-absolute-ppc-2/2 rt-vm jit-rel
     5 3 quot-xt-offset LWZ
-    5 MTCTR
+]
-    BCTR
+[ 5 MTLR BLRL ]
-] \ (call) define-sub-primitive
+[ 5 MTCTR BCTR ] \ (call) define-sub-primitive*
+
+[
+    3 ds-reg 0 LWZ
+    ds-reg dup 4 SUBI
+    4 3 word-xt-offset LWZ
+]
+[ 4 MTLR BLRL ]
+[ 4 MTCTR BCTR ] \ (execute) define-sub-primitive*
+
+[
+    3 ds-reg 0 LWZ
+    ds-reg dup 4 SUBI
+    4 3 word-xt-offset LWZ
+    4 MTCTR BCTR
+] jit-execute jit-define
 
 ! Objects
 [
@@ -361,7 +375,7 @@ CONSTANT: rs-reg 14
 ! Comparisons
 : jit-compare ( insn -- )
     t jit-literal
-    0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel
     4 ds-reg 0 LWZ
     5 ds-reg -4 LWZU
     5 0 4 CMP
@@ -387,8 +401,7 @@ CONSTANT: rs-reg 14
     3 3 tag-mask get ANDI
     \ f type-number 4 LI
     0 3 0 CMPI
-    2 BNE
+    [ BNE ] [ 1 tag-fixnum 4 LI ] jit-conditional*
-    1 tag-fixnum 4 LI
     4 ds-reg 0 STW
 ] \ both-fixnums? define-sub-primitive
 
@@ -433,8 +446,7 @@ CONSTANT: rs-reg 14
     7 4 6 SRAW
     7 7 0 0 31 tag-bits get - RLWINM
     0 3 0 CMPI
-    2 BGT
+    [ BGT ] [ 5 7 MR ] jit-conditional*
-    5 7 MR
     5 ds-reg 0 STW
 ] \ fixnum-shift-fast define-sub-primitive
 
@@ -482,4 +494,67 @@ CONSTANT: rs-reg 14
     rs-reg 3 rs-reg SUBF
 ] \ drop-locals define-sub-primitive
 
+! Inline cache miss entry points
+: jit-load-return-address ( -- ) 6 MFLR ;
+
+! These are always in tail position with an existing stack
+! frame, and the stack. The frame setup takes this into account.
+: jit-inline-cache-miss ( -- )
+    jit-save-context
+    3 6 MR
+    4 0 LOAD32 0 rc-absolute-ppc-2/2 jit-vm
+    5 0 LOAD32 "inline_cache_miss" f rc-absolute-ppc-2/2 jit-dlsym ;
+
+[ jit-load-return-address jit-inline-cache-miss ]
+[ 5 MTLR BLRL ]
+[ 5 MTCTR BCTR ]
+\ inline-cache-miss define-sub-primitive*
+
+[ jit-inline-cache-miss ]
+[ 5 MTLR BLRL ]
+[ 5 MTCTR BCTR ]
+\ inline-cache-miss-tail define-sub-primitive*
+
+! Overflowing fixnum arithmetic
+:: jit-overflow ( insn func -- )
+    jit-save-context
+    3 ds-reg 0 LWZ
+    4 ds-reg -4 LWZ
+    ds-reg ds-reg 4 SUBI
+    0 0 LI
+    0 MTXER
+    6 3 4 insn call( d a s -- )
+    6 ds-reg 0 STW
+    [ BNO ]
+    [
+       0 5 LOAD32 0 rc-absolute-ppc-2/2 jit-vm
+       0 6 LOAD32 func f rc-absolute-ppc-2/2 jit-dlsym
+    ]
+    jit-conditional ;
+
+[ [ ADDO. ] "overflow_fixnum_add" jit-overflow ] \ fixnum+ define-sub-primitive
+
+[ [ SUBFO. ] "overflow_fixnum_subtract" jit-overflow ] \ fixnum- define-sub-primitive
+
+[
+    jit-save-context
+    3 ds-reg 0 LWZ
+    3 3 tag-bits get SRAWI
+    4 ds-reg -4 LWZ
+    ds-reg ds-reg 4 SUBI
+    0 0 LI
+    0 MTXER
+    6 3 4 MULLWO.
+    6 ds-reg 0 STW
+    [ BNO ]
+    [
+        4 4 tag-bits get SRAWI
+        0 5 LOAD32 0 rc-absolute-ppc-2/2 jit-vm
+        0 6 LOAD32 "overflow_fixnum_multiply" f rc-absolute-ppc-2/2 jit-dlsym
+        6 MTLR
+        BLRL
+    ]
+    jit-conditional
+] \ fixnum* define-sub-primitive
+
 [ "bootstrap.ppc" forget-vocab ] with-compilation-unit

basis/cpu/x86/32/bootstrap.factor

@@ -2,12 +2,13 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: bootstrap.image.private kernel namespaces system
 cpu.x86.assembler cpu.x86.assembler.operands layouts
-vocabs parser compiler.constants sequences ;
+vocabs parser compiler.constants sequences math math.private
+generic.single.private ;
 IN: bootstrap.x86
 
 4 \ cell set
 
-: stack-frame-size ( -- n ) 4 bootstrap-cells ;
+: stack-frame-size ( -- n ) 8 bootstrap-cells ;
 : shift-arg ( -- reg ) ECX ;
 : div-arg ( -- reg ) EAX ;
 : mod-arg ( -- reg ) EDX ;
@@ -25,15 +26,89 @@ IN: bootstrap.x86
 : rex-length ( -- n ) 0 ;
 
 [
-    ! load stack_chain
+    ! save stack frame size
-    temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel
+    stack-frame-size PUSH
+    ! push XT
+    0 PUSH rc-absolute-cell rt-this jit-rel
+    ! alignment
+    ESP stack-frame-size 3 bootstrap-cells - SUB
+] jit-prolog jit-define
+
+: jit-save-context ( -- )
+    EAX 0 [] MOV rc-absolute-cell rt-context jit-rel
     ! save stack pointer
-    temp0 [] stack-reg MOV
+    ECX ESP -4 [+] LEA
+    EAX [] ECX MOV ;
+
+[
+    jit-save-context
     ! pass vm ptr to primitive
-    arg1 0 MOV rc-absolute-cell rt-vm jit-rel
+    EAX 0 MOV rc-absolute-cell rt-vm jit-rel
     ! call the primitive
-    0 JMP rc-relative rt-primitive jit-rel
+    0 CALL rc-relative rt-primitive jit-rel
 ] jit-primitive jit-define
 
+! Inline cache miss entry points
+: jit-load-return-address ( -- )
+    EBX ESP stack-frame-size bootstrap-cell - [+] MOV ;
+
+! These are always in tail position with an existing stack
+! frame, and the stack. The frame setup takes this into account.
+: jit-inline-cache-miss ( -- )
+    jit-save-context
+    ESP 4 [+] 0 MOV 0 rc-absolute-cell jit-vm
+    ESP [] EBX MOV
+    0 CALL "inline_cache_miss" f rc-relative jit-dlsym ;
+
+[ jit-load-return-address jit-inline-cache-miss ]
+[ EAX CALL ]
+[ EAX JMP ]
+\ inline-cache-miss define-sub-primitive*
+
+[ jit-inline-cache-miss ]
+[ EAX CALL ]
+[ EAX JMP ]
+\ inline-cache-miss-tail define-sub-primitive*
+
+! Overflowing fixnum arithmetic
+: jit-overflow ( insn func -- )
+    jit-save-context
+    EAX ds-reg -4 [+] MOV
+    EDX ds-reg [] MOV
+    ds-reg 4 SUB
+    ECX EAX MOV
+    [ [ ECX EDX ] dip call( dst src -- ) ] dip
+    ds-reg [] ECX MOV
+    [ JNO ]
+    [
+        ECX 0 MOV 0 rc-absolute-cell jit-vm
+        [ 0 CALL ] dip f rc-relative jit-dlsym
+    ]
+    jit-conditional ;
+
+[ [ ADD ] "overflow_fixnum_add" jit-overflow ] \ fixnum+ define-sub-primitive
+
+[ [ SUB ] "overflow_fixnum_subtract" jit-overflow ] \ fixnum- define-sub-primitive
+
+[
+    jit-save-context
+    ECX ds-reg -4 [+] MOV
+    EBX ds-reg [] MOV
+    EBX tag-bits get SAR
+    ds-reg 4 SUB
+    EAX ECX MOV
+    EBX IMUL
+    ds-reg [] EAX MOV
+    [ JNO ]
+    [
+        EAX ECX MOV
+        EAX tag-bits get SAR
+        EDX EBX MOV
+        ECX 0 MOV 0 rc-absolute-cell jit-vm
+        0 CALL "overflow_fixnum_multiply" f rc-relative jit-dlsym
+    ]
+    jit-conditional
+] \ fixnum* define-sub-primitive
+
 << "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >>
 call

basis/cpu/x86/64/bootstrap.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: bootstrap.image.private kernel namespaces system
-layouts vocabs parser compiler.constants math
+layouts vocabs parser compiler.constants math math.private
-cpu.x86.assembler cpu.x86.assembler.operands sequences ;
+cpu.x86.assembler cpu.x86.assembler.operands sequences
+generic.single.private ;
 IN: bootstrap.x86
 
 8 \ cell set
@@ -22,18 +23,94 @@ IN: bootstrap.x86
 : rex-length ( -- n ) 1 ;
 
 [
-    ! load stack_chain
+    ! load XT
-    temp0 0 MOV rc-absolute-cell rt-stack-chain jit-rel
+    RDI 0 MOV rc-absolute-cell rt-this jit-rel
+    ! save stack frame size
+    stack-frame-size PUSH
+    ! push XT
+    RDI PUSH
+    ! alignment
+    RSP stack-frame-size 3 bootstrap-cells - SUB
+] jit-prolog jit-define
+
+: jit-save-context ( -- )
+    temp0 0 MOV rc-absolute-cell rt-context jit-rel
     temp0 temp0 [] MOV
     ! save stack pointer
-    temp0 [] stack-reg MOV
+    temp1 stack-reg bootstrap-cell neg [+] LEA
+    temp0 [] temp1 MOV ;
+
+[
+    jit-save-context
     ! load vm ptr
     arg1 0 MOV rc-absolute-cell rt-vm jit-rel
     ! load XT
     temp1 0 MOV rc-absolute-cell rt-primitive jit-rel
     ! go
-    temp1 JMP
+    temp1 CALL
 ] jit-primitive jit-define
 
+! Inline cache miss entry points
+: jit-load-return-address ( -- )
+    RBX RSP stack-frame-size bootstrap-cell - [+] MOV ;
+
+! These are always in tail position with an existing stack
+! frame, and the stack. The frame setup takes this into account.
+: jit-inline-cache-miss ( -- )
+    jit-save-context
+    arg1 RBX MOV
+    arg2 0 MOV 0 rc-absolute-cell jit-vm
+    0 CALL "inline_cache_miss" f rc-relative jit-dlsym ;
+
+[ jit-load-return-address jit-inline-cache-miss ]
+[ RAX CALL ]
+[ RAX JMP ]
+\ inline-cache-miss define-sub-primitive*
+
+[ jit-inline-cache-miss ]
+[ RAX CALL ]
+[ RAX JMP ]
+\ inline-cache-miss-tail define-sub-primitive*
+
+! Overflowing fixnum arithmetic
+: jit-overflow ( insn func -- )
+    jit-save-context
+    arg1 ds-reg bootstrap-cell neg [+] MOV
+    arg2 ds-reg [] MOV
+    ds-reg bootstrap-cell SUB
+    arg3 arg1 MOV
+    [ [ arg3 arg2 ] dip call ] dip
+    ds-reg [] arg3 MOV
+    [ JNO ]
+    [
+        arg3 0 MOV 0 rc-absolute-cell jit-vm
+        [ 0 CALL ] dip f rc-relative jit-dlsym
+    ]
+    jit-conditional ; inline
+
+[ [ ADD ] "overflow_fixnum_add" jit-overflow ] \ fixnum+ define-sub-primitive
+
+[ [ SUB ] "overflow_fixnum_subtract" jit-overflow ] \ fixnum- define-sub-primitive
+
+[
+    jit-save-context
+    RCX ds-reg bootstrap-cell neg [+] MOV
+    RBX ds-reg [] MOV
+    RBX tag-bits get SAR
+    ds-reg bootstrap-cell SUB
+    RAX RCX MOV
+    RBX IMUL
+    ds-reg [] RAX MOV
+    [ JNO ]
+    [
+        arg1 RCX MOV
+        arg1 tag-bits get SAR
+        arg2 RBX MOV
+        arg3 0 MOV 0 rc-absolute-cell jit-vm
+        0 CALL "overflow_fixnum_multiply" f rc-relative jit-dlsym
+    ]
+    jit-conditional
+] \ fixnum* define-sub-primitive
+
 << "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >>
 call

basis/cpu/x86/64/unix/bootstrap.factor

@@ -8,6 +8,7 @@ IN: bootstrap.x86
 : stack-frame-size ( -- n ) 4 bootstrap-cells ;
 : arg1 ( -- reg ) RDI ;
 : arg2 ( -- reg ) RSI ;
+: arg3 ( -- reg ) RDX ;
 
 << "vocab:cpu/x86/64/bootstrap.factor" parse-file suffix! >>
 call

basis/cpu/x86/64/winnt/bootstrap.factor

@@ -8,6 +8,7 @@ IN: bootstrap.x86
 : stack-frame-size ( -- n ) 8 bootstrap-cells ;
 : arg1 ( -- reg ) RCX ;
 : arg2 ( -- reg ) RDX ;
+: arg3 ( -- reg ) R8 ;
 
 << "vocab:cpu/x86/64/bootstrap.factor" parse-file suffix! >>
 call

basis/cpu/x86/bootstrap.factor

@@ -10,7 +10,7 @@ big-endian off
 
 [
     ! Load word
-    temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
+    temp0 0 MOV rc-absolute-cell rt-literal jit-rel
     ! Bump profiling counter
     temp0 profile-count-offset [+] 1 tag-fixnum ADD
     ! Load word->code
@@ -21,20 +21,9 @@ big-endian off
     temp0 JMP
 ] jit-profiling jit-define
 
-[
-    ! load XT
-    temp0 0 MOV rc-absolute-cell rt-this jit-rel
-    ! save stack frame size
-    stack-frame-size PUSH
-    ! push XT
-    temp0 PUSH
-    ! alignment
-    stack-reg stack-frame-size 3 bootstrap-cells - SUB
-] jit-prolog jit-define
-
 [
     ! load literal
-    temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
+    temp0 0 MOV rc-absolute-cell rt-literal jit-rel
     ! increment datastack pointer
     ds-reg bootstrap-cell ADD
     ! store literal on datastack
@@ -50,10 +39,6 @@ big-endian off
     0 CALL rc-relative rt-xt-pic jit-rel
 ] jit-word-call jit-define
 
-[
-    0 JMP rc-relative rt-xt jit-rel
-] jit-word-special jit-define
-
 [
     ! load boolean
     temp0 ds-reg [] MOV
@@ -133,20 +118,35 @@ big-endian off
     jit-3r>
 ] jit-3dip jit-define
 
-: prepare-(execute) ( -- operand )
+[
     ! load from stack
-    temp0 ds-reg [] MOV
+    arg1 ds-reg [] MOV
     ! pop stack
     ds-reg bootstrap-cell SUB
-    ! execute word
+    ! pass vm pointer
-    temp0 word-xt-offset [+] ;
+    arg2 0 MOV 0 rc-absolute-cell jit-vm
-
+]
-[ prepare-(execute) JMP ] jit-execute-jump jit-define
+[ arg1 quot-xt-offset [+] CALL ]
-
+[ arg1 quot-xt-offset [+] JMP ]
-[ prepare-(execute) CALL ] jit-execute-call jit-define
+\ (call) define-sub-primitive*
+
+[
+    ! load from stack
+    arg1 ds-reg [] MOV
+    ! pop stack
+    ds-reg bootstrap-cell SUB
+]
+[ arg1 word-xt-offset [+] CALL ]
+[ arg1 word-xt-offset [+] JMP ]
+\ (execute) define-sub-primitive*
+
+[
+    arg1 ds-reg [] MOV
+    ds-reg bootstrap-cell SUB
+    arg1 word-xt-offset [+] JMP
+] jit-execute jit-define
 
 [
-    ! unwind stack frame
     stack-reg stack-frame-size bootstrap-cell - ADD
 ] jit-epilog jit-define
 
@@ -176,16 +176,17 @@ big-endian off
     temp0 temp1 MOV
     load-tag
     temp1 tuple type-number tag-fixnum CMP
-    [ temp1 temp0 tuple type-number neg bootstrap-cell + [+] MOV ] { } make
+    [ JNE ]
-    [ length JNE ] [ % ] bi
+    [ temp1 temp0 tuple type-number neg bootstrap-cell + [+] MOV ]
+    jit-conditional
 ] pic-tuple jit-define
 
 [
-    temp1 HEX: ffffffff CMP rc-absolute rt-immediate jit-rel
+    temp1 HEX: ffffffff CMP rc-absolute rt-literal jit-rel
 ] pic-check-tag jit-define
 
 [
-    temp2 HEX: ffffffff MOV rc-absolute-cell rt-immediate jit-rel
+    temp2 HEX: ffffffff MOV rc-absolute-cell rt-literal jit-rel
     temp1 temp2 CMP
 ] pic-check-tuple jit-define
 
@@ -195,7 +196,7 @@ big-endian off
 
 [
     ! cache = ...
-    temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
+    temp0 0 MOV rc-absolute-cell rt-literal jit-rel
     ! key = hashcode(class)
     temp2 temp1 MOV
     bootstrap-cell 4 = [ temp2 1 SHR ] when
@@ -224,18 +225,6 @@ big-endian off
 
 ! ! ! Sub-primitives
 
-! Quotations and words
-[
-    ! load from stack
-    arg1 ds-reg [] MOV
-    ! pop stack
-    ds-reg bootstrap-cell SUB
-    ! pass vm pointer
-    arg2 0 MOV 0 jit-parameter rc-absolute-cell rt-vm jit-rel
-    ! call quotation
-    arg1 quot-xt-offset [+] JMP
-] \ (call) define-sub-primitive
-
 ! Objects
 [
     ! load from stack
@@ -373,7 +362,7 @@ big-endian off
 : jit-compare ( insn -- )
     ! load t
     t jit-literal
-    temp3 0 MOV rc-absolute-cell rt-immediate jit-rel
+    temp3 0 MOV rc-absolute-cell rt-literal jit-rel
     ! load f
     temp1 \ f type-number MOV
     ! load first value

core/bootstrap/primitives.factor

@@ -326,6 +326,9 @@ tuple
     { "fixnum-shift-fast" "math.private" (( x y -- z )) }
     { "fixnum/i-fast" "math.private" (( x y -- z )) }
     { "fixnum/mod-fast" "math.private" (( x y -- z w )) }
+    { "fixnum+" "math.private" (( x y -- z )) }
+    { "fixnum-" "math.private" (( x y -- z )) }
+    { "fixnum*" "math.private" (( x y -- z )) }
     { "fixnum<" "math.private" (( x y -- ? )) }
     { "fixnum<=" "math.private" (( x y -- z )) }
     { "fixnum>" "math.private" (( x y -- ? )) }
@@ -352,6 +355,8 @@ tuple
     { "load-local" "locals.backend" (( obj -- )) }
     { "drop-locals" "locals.backend" (( n -- )) }
     { "mega-cache-lookup" "generic.single.private" (( methods index cache -- )) }
+    { "inline-cache-miss" "generic.single.private" (( generic methods index cache -- )) }
+    { "inline-cache-miss-tail" "generic.single.private" (( generic methods index cache -- )) }
 } [ first3 make-sub-primitive ] each
 
 ! Primitive words
@@ -374,9 +379,6 @@ tuple
     { "double>bits" "math" (( x -- n )) }
     { "bits>float" "math" (( n -- x )) }
     { "bits>double" "math" (( n -- x )) }
-    { "fixnum+" "math.private" (( x y -- z )) }
-    { "fixnum-" "math.private" (( x y -- z )) }
-    { "fixnum*" "math.private" (( x y -- z )) }
     { "fixnum/i" "math.private" (( x y -- z )) }
     { "fixnum/mod" "math.private" (( x y -- z w )) }
     { "fixnum-shift" "math.private" (( x y -- z )) }
@@ -508,8 +510,6 @@ tuple
     { "jit-compile" "quotations" (( quot -- )) }
     { "load-locals" "locals.backend" (( ... n -- )) }
     { "check-datastack" "kernel.private" (( array in# out# -- ? )) }
-    { "inline-cache-miss" "generic.single.private" (( generic methods index cache -- )) }
-    { "inline-cache-miss-tail" "generic.single.private" (( generic methods index cache -- )) }
     { "mega-cache-miss" "generic.single.private" (( methods index cache -- method )) }
     { "lookup-method" "generic.single.private" (( object methods -- method )) }
     { "reset-dispatch-stats" "tools.dispatch.private" (( -- )) }

core/compiler/units/units.factor

@@ -100,7 +100,7 @@ GENERIC: definitions-changed ( assoc obj -- )
 ! Incremented each time stack effects potentially changed, used
 ! by compiler.tree.propagation.call-effect for call( and execute(
 ! inline caching
-: effect-counter ( -- n ) 46 getenv ; inline
+: effect-counter ( -- n ) 47 getenv ; inline
 
 GENERIC: bump-effect-counter* ( defspec -- ? )
 
@@ -132,7 +132,7 @@ M: object bump-effect-counter* drop f ;
     or ;
 
 : bump-effect-counter ( -- )
-    bump-effect-counter? [ 46 getenv 0 or 1 + 46 setenv ] when ;
+    bump-effect-counter? [ 47 getenv 0 or 1 + 47 setenv ] when ;
 
 : notify-observers ( -- )
     updated-definitions dup assoc-empty?

vm/callstack.cpp

@@ -28,29 +28,32 @@ stack_frame *factor_vm::fix_callstack_top(stack_frame *top, stack_frame *bottom)
 	return frame + 1;
 }
 
-/* We ignore the topmost frame, the one calling 'callstack',
+/* We ignore the two topmost frames, the 'callstack' primitive
+frame itself, and the frame calling the 'callstack' primitive,
 so that set-callstack doesn't get stuck in an infinite loop.
 
 This means that if 'callstack' is called in tail position, we
 will have popped a necessary frame... however this word is only
 called by continuation implementation, and user code shouldn't
 be calling it at all, so we leave it as it is for now. */
-stack_frame *factor_vm::capture_start()
+stack_frame *factor_vm::second_from_top_stack_frame()
 {
 	stack_frame *frame = ctx->callstack_bottom - 1;
-	while(frame >= ctx->callstack_top && frame_successor(frame) >= ctx->callstack_top)
+	while(frame >= ctx->callstack_top
+		&& frame_successor(frame) >= ctx->callstack_top
+		&& frame_successor(frame_successor(frame)) >= ctx->callstack_top)
+	{
 		frame = frame_successor(frame);
+	}
 	return frame + 1;
 }
 
 void factor_vm::primitive_callstack()
 {
-	stack_frame *top = capture_start();
+	stack_frame *top = second_from_top_stack_frame();
 	stack_frame *bottom = ctx->callstack_bottom;
 
-	fixnum size = (cell)bottom - (cell)top;
+	fixnum size = std::max((fixnum)0,(fixnum)bottom - (fixnum)top);
-	if(size < 0)
-		size = 0;
 
 	callstack *stack = allot_callstack(size);
 	memcpy(stack->top(),top,size);

vm/callstack.hpp

@@ -6,7 +6,7 @@ inline static cell callstack_size(cell size)
 	return sizeof(callstack) + size;
 }
 
-VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom, factor_vm *vm);
+VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom, factor_vm *parent);
 
 /* This is a little tricky. The iterator may allocate memory, so we
 keep the callstack in a GC root and use relative offsets */
@@ -25,12 +25,9 @@ template<typename Iterator> void factor_vm::iterate_callstack_object(callstack *
 
 template<typename Iterator> void factor_vm::iterate_callstack(context *ctx, Iterator &iterator)
 {
-	cell top = (cell)ctx->callstack_top;
+	stack_frame *frame = ctx->callstack_bottom - 1;
-	cell bottom = (cell)ctx->callstack_bottom;
 
-	stack_frame *frame = (stack_frame *)bottom - 1;
+	while(frame >= ctx->callstack_top)
-
-	while((cell)frame >= top)
 	{
 		iterator(frame);
 		frame = frame_successor(frame);

vm/code_blocks.cpp

@@ -264,7 +264,7 @@ struct initial_code_block_visitor {
 	{
 		switch(op.rel_type())
 		{
-		case RT_IMMEDIATE:
+		case RT_LITERAL:
 			op.store_value(next_literal());
 			break;
 		case RT_XT:

vm/compaction.cpp

@@ -108,7 +108,7 @@ struct code_block_compaction_relocation_visitor {
 
 		switch(op.rel_type())
 		{
-		case RT_IMMEDIATE:
+		case RT_LITERAL:
 			op.store_value(slot_forwarder.visit_pointer(op.load_value(old_offset)));
 			break;
 		case RT_XT:

vm/cpu-ppc.S

@@ -4,49 +4,6 @@ in the public domain. */
 
 #define DS_REG r13
 
-DEF(void,primitive_fixnum_add,(void *vm)):
-	mr r5,r3  /* save vm ptr for overflow */
-	lwz r3,0(DS_REG)
-	lwz r4,-4(DS_REG)
-	subi DS_REG,DS_REG,4
-	li r0,0
-	mtxer r0
-	addo. r6,r3,r4
-	bso add_overflow
-	stw r6,0(DS_REG)
-	blr
-add_overflow:
-	b MANGLE(overflow_fixnum_add)
-
-DEF(void,primitive_fixnum_subtract,(void *vm)):
-	mr r5,r3  /* save vm ptr for overflow */
-	lwz r3,-4(DS_REG)
-	lwz r4,0(DS_REG)
-	subi DS_REG,DS_REG,4
-	li r0,0
-	mtxer r0
-	subfo. r6,r4,r3
-	bso sub_overflow
-	stw r6,0(DS_REG)
-	blr
-sub_overflow:
-	b MANGLE(overflow_fixnum_subtract)
-
-DEF(void,primitive_fixnum_multiply,(void *vm)):
-	mr r5,r3  /* save vm ptr for overflow */
-	lwz r3,0(DS_REG)
-	lwz r4,-4(DS_REG)
-	subi DS_REG,DS_REG,4
-	srawi r3,r3,4
-	mullwo. r6,r3,r4
-	bso multiply_overflow
-	stw r6,0(DS_REG)
-	blr
-multiply_overflow:
-	srawi r4,r4,4
-	b MANGLE(overflow_fixnum_multiply)
-	
-/* Note that the XT is passed to the quotation in r11 */
 #define CALL_OR_JUMP_QUOT \
 	lwz r11,12(r3)	   /* load quotation-xt slot */ XX \
 
@@ -299,17 +256,6 @@ DEF(void,flush_icache,(void *start, int len)):
 	isync
 	blr
 
-DEF(void,primitive_inline_cache_miss,(void *vm)):
-	mflr r6
-DEF(void,primitive_inline_cache_miss_tail,(void *vm)):
-	PROLOGUE
-	mr r4,r3          /* vm ptr in 2nd arg */
-	mr r3,r6
-	bl MANGLE(inline_cache_miss)
-	EPILOGUE
-	mtctr r3
-	bctr
-
 DEF(void,get_ppc_fpu_env,(void*)):
 	mffs f0
 	stfd f0,0(r3)
@@ -341,4 +287,3 @@ DEF(void,set_ppc_vmx_env,(const void*)):
 	lvxl v0,0,r4
 	mtvscr v0
 	blr
-

vm/cpu-x86.32.S

@@ -10,10 +10,6 @@
 #define NV0 %ebx
 #define NV1 %ebp
 
-#define ARITH_TEMP_1 %ebp
-#define ARITH_TEMP_2 %ebx
-#define DIV_RESULT %eax
-
 #define CELL_SIZE 4
 #define STACK_PADDING 12
 
@@ -44,20 +40,32 @@ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, voi
 	add $12,%esp                       /* pop args from the stack */
 	ret                                /* return _with new stack_ */
 
+DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to, void *vm)):
+	mov ARG2,NV0  /* remember vm ptr in case quot_xt = lazy_jit_compile */		
+	/* clear x87 stack, but preserve rounding mode and exception flags */
+	sub $2,STACK_REG
+	fnstcw (STACK_REG)
+	fninit
+	fldcw (STACK_REG)
+	/* rewind_to */
+	mov ARG1,STACK_REG
+	mov NV0,ARG1
+	jmp *QUOT_XT_OFFSET(ARG0)
+
+DEF(F_FASTCALL void,lazy_jit_compile,(CELL quot, void *vm)):
+	mov ARG1,ARG2
+	mov STACK_REG,ARG1           /* Save stack pointer */
+	sub $STACK_PADDING,STACK_REG
+	call MANGLE(lazy_jit_compile_impl)
+	mov RETURN_REG,ARG0          /* No-op on 32-bit */
+	add $STACK_PADDING,STACK_REG
+    jmp *QUOT_XT_OFFSET(ARG0)    /* Call the quotation */
+
+
 DEF(long long,read_timestamp_counter,(void)):
 	rdtsc
 	ret
 
-DEF(void,primitive_inline_cache_miss,(void *vm)):
-	mov (%esp),%ebx
-DEF(void,primitive_inline_cache_miss_tail,(void *vm)):
-	sub $4,%esp
-	push ARG0   /* push vm ptr */
-	push %ebx
-	call MANGLE(inline_cache_miss)
-	add $12,%esp
-	jmp *%eax
-
 DEF(void,get_sse_env,(void*)):
 	movl 4(%esp), %eax
 	stmxcsr (%eax)
@@ -80,28 +88,6 @@ DEF(void,set_x87_env,(const void*)):
 	fldcw 2(%eax)
 	ret
 
-DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to, void *vm)):
-	mov ARG2,NV0  /* remember vm ptr in case quot_xt = lazy_jit_compile */		
-	/* clear x87 stack, but preserve rounding mode and exception flags */
-	sub $2,STACK_REG
-	fnstcw (STACK_REG)
-	fninit
-	fldcw (STACK_REG)
-	/* rewind_to */
-	mov ARG1,STACK_REG
-	mov NV0,ARG1
-	jmp *QUOT_XT_OFFSET(ARG0)
-
-DEF(F_FASTCALL void,lazy_jit_compile,(CELL quot, void *vm)):
-	mov ARG1,ARG2
-	mov STACK_REG,ARG1           /* Save stack pointer */
-	sub $STACK_PADDING,STACK_REG
-	call MANGLE(lazy_jit_compile_impl)
-	mov RETURN_REG,ARG0          /* No-op on 32-bit */
-	add $STACK_PADDING,STACK_REG
-    jmp *QUOT_XT_OFFSET(ARG0)    /* Call the quotation */
-
-	
 #include "cpu-x86.S"
 
 #ifdef WINDOWS

vm/cpu-x86.64.S

@@ -10,10 +10,6 @@
 #define NV0 %rbp
 #define NV1 %r12
 
-#define ARITH_TEMP_1 %r8
-#define ARITH_TEMP_2 %r9
-#define DIV_RESULT %rax
-
 #ifdef WINDOWS
 
 	#define ARG0 %rcx
@@ -69,41 +65,6 @@ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, voi
 	call *ARG3                         /* call memcpy */
 	ret                                /* return _with new stack_ */
 
-DEF(long long,read_timestamp_counter,(void)):
-	mov $0,%rax
-	rdtsc
-	shl $32,%rdx
-	or %rdx,%rax
-	ret
-
-DEF(void,primitive_inline_cache_miss,(void *vm)):
-	mov (%rsp),%rbx
-DEF(void,primitive_inline_cache_miss_tail,(void *vm)):
-	sub $STACK_PADDING,%rsp
-	mov ARG0,ARG1
-	mov %rbx,ARG0
-	call MANGLE(inline_cache_miss)
-	add $STACK_PADDING,%rsp
-	jmp *%rax
-
-DEF(void,get_sse_env,(void*)):
-	stmxcsr (%rdi)
-	ret
-
-DEF(void,set_sse_env,(const void*)):
-	ldmxcsr (%rdi)
-	ret
-
-DEF(void,get_x87_env,(void*)):
-	fnstsw (%rdi)
-	fnstcw 2(%rdi)
-	ret
-
-DEF(void,set_x87_env,(const void*)):
-	fnclex
-	fldcw 2(%rdi)
-	ret
-
 DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to, void *vm)):
 	/* clear x87 stack, but preserve rounding mode and exception flags */
 	sub $2,STACK_REG
@@ -124,5 +85,29 @@ DEF(F_FASTCALL void,lazy_jit_compile,(CELL quot, void *vm)):
 	add $STACK_PADDING,STACK_REG
         jmp *QUOT_XT_OFFSET(ARG0)    /* Call the quotation */
 
+DEF(long long,read_timestamp_counter,(void)):
+	mov $0,%rax
+	rdtsc
+	shl $32,%rdx
+	or %rdx,%rax
+	ret
+
+DEF(void,get_sse_env,(void*)):
+	stmxcsr (%rdi)
+	ret
+
+DEF(void,set_sse_env,(const void*)):
+	ldmxcsr (%rdi)
+	ret
+
+DEF(void,get_x87_env,(void*)):
+	fnstsw (%rdi)
+	fnstcw 2(%rdi)
+	ret
+
+DEF(void,set_x87_env,(const void*)):
+	fnclex
+	fldcw 2(%rdi)
+	ret
 	
 #include "cpu-x86.S"

vm/cpu-x86.S

@@ -1,44 +1,3 @@
-DEF(void,primitive_fixnum_add,(void *myvm)):
-	mov ARG0, ARG2  /* save vm ptr for overflow */
-	mov (DS_REG),ARG0
-	mov -CELL_SIZE(DS_REG),ARG1
-	sub $CELL_SIZE,DS_REG
-	mov ARG1,ARITH_TEMP_1
-	add ARG0,ARITH_TEMP_1
-	jo MANGLE(overflow_fixnum_add)
-	mov ARITH_TEMP_1,(DS_REG)
-	ret
-
-DEF(void,primitive_fixnum_subtract,(void *myvm)):
-	mov ARG0, ARG2  /* save vm ptr for overflow */
-	mov (DS_REG),ARG1
-	mov -CELL_SIZE(DS_REG),ARG0
-	sub $CELL_SIZE,DS_REG
-	mov ARG0,ARITH_TEMP_1
-	sub ARG1,ARITH_TEMP_1
-	jo MANGLE(overflow_fixnum_subtract)
-	mov ARITH_TEMP_1,(DS_REG)
-	ret
-
-DEF(void,primitive_fixnum_multiply,(void *myvm)):
-	push ARG0  /* save vm ptr for overflow */
-	mov (DS_REG),ARITH_TEMP_1
-	mov ARITH_TEMP_1,DIV_RESULT
-	mov -CELL_SIZE(DS_REG),ARITH_TEMP_2
-	sar $4,ARITH_TEMP_2
-	sub $CELL_SIZE,DS_REG
-	imul ARITH_TEMP_2
-	jo multiply_overflow
-	mov DIV_RESULT,(DS_REG)
-	pop ARG2
-	ret
-multiply_overflow:
-	sar $4,ARITH_TEMP_1
-	mov ARITH_TEMP_1,ARG0
-	mov ARITH_TEMP_2,ARG1
-	pop ARG2
-	jmp MANGLE(overflow_fixnum_multiply)
-
 DEF(F_FASTCALL void,c_to_factor,(CELL quot, void *vm)):
 	PUSH_NONVOLATILE
 	mov ARG0,NV0

vm/cpu-x86.hpp

@@ -47,7 +47,12 @@ inline static void set_call_target(cell return_address, void *target)
 
 inline static bool tail_call_site_p(cell return_address)
 {
-	return call_site_opcode(return_address) == jmp_opcode;
+	switch(call_site_opcode(return_address))
+	{
+	case jmp_opcode: return true;
+	case call_opcode: return false;
+	default: abort(); return false;
+	}
 }
 
 inline static unsigned int fpu_status(unsigned int status)

vm/data_heap.cpp

@@ -268,9 +268,4 @@ void factor_vm::primitive_all_instances()
 	dpush(instances(TYPE_COUNT));
 }
 
-cell factor_vm::find_all_words()
-{
-	return instances(WORD_TYPE);
-}
-
 }

vm/debug.cpp

@@ -160,8 +160,11 @@ struct stack_frame_printer {
 	explicit stack_frame_printer(factor_vm *parent_) : parent(parent_) {}
 	void operator()(stack_frame *frame)
 	{
+		std::cout << "frame: " << std::hex << (cell)frame << std::dec << std::endl;
+		std::cout << "executing: ";
 		parent->print_obj(parent->frame_executing(frame));
 		std::cout << std::endl;
+		std::cout << "scan: ";
 		parent->print_obj(parent->frame_scan(frame));
 		std::cout << std::endl;
 		std::cout << "word/quot addr: ";

vm/dispatch.cpp

@@ -166,7 +166,7 @@ void quotation_jit::emit_mega_cache_lookup(cell methods_, fixnum index, cell cac
 	/* Now the new method has been stored into the cache, and its on
 	   the stack. */
 	emit(parent->special_objects[JIT_EPILOG]);
-	emit(parent->special_objects[JIT_EXECUTE_JUMP]);
+	emit(parent->special_objects[JIT_EXECUTE]);
 }
 
 }

vm/full_collector.cpp

@@ -75,7 +75,7 @@ void factor_vm::update_code_roots_for_compaction()
 		/* Offset of return address within 16-byte allocation line */
 		cell offset = root->value - (cell)block;
 
-		if(root->valid && state->marked_p((code_block *)root->value))
+		if(root->valid && state->marked_p(block))
 		{
 			block = state->forward_block(block);
 			root->value = (cell)block + offset;

vm/image.cpp

@@ -182,7 +182,7 @@ struct code_block_fixup_relocation_visitor {
 
 		switch(op.rel_type())
 		{
-		case RT_IMMEDIATE:
+		case RT_LITERAL:
 			op.store_value(data_visitor.visit_pointer(op.load_value(old_offset)));
 			break;
 		case RT_XT:

vm/inline_cache.cpp

@@ -104,16 +104,24 @@ void inline_cache_jit::compile_inline_cache(fixnum index,
 		emit_with_literal(parent->special_objects[PIC_HIT],method);
 	}
 
-	/* Generate machine code to handle a cache miss, which ultimately results in
+	/* If none of the above conditionals tested true, then execution "falls
-	   this function being called again.
+	   through" to here. */
 
-	   The inline-cache-miss primitive call receives enough information to
+	/* A stack frame is set up, since the inline-cache-miss sub-primitive
-	   reconstruct the PIC. */
+	makes a subroutine call to the VM. */
+	emit(parent->special_objects[JIT_PROLOG]);
+
+	/* The inline-cache-miss sub-primitive call receives enough information to
+	   reconstruct the PIC with the new entry. */
 	push(generic_word.value());
 	push(methods.value());
 	push(tag_fixnum(index));
 	push(cache_entries.value());
-	word_special(parent->special_objects[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]);
+
+	emit_subprimitive(
+		parent->special_objects[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD],
+		true, /* tail_call_p */
+		true); /* stack_frame_p */
 }
 
 code_block *factor_vm::compile_inline_cache(fixnum index,
@@ -180,8 +188,15 @@ to take care of the details. */
 void *factor_vm::inline_cache_miss(cell return_address_)
 {
 	code_root return_address(return_address_,this);
-
 	check_code_pointer(return_address.value);
+	bool tail_call_site = tail_call_site_p(return_address.value);
+
+#ifdef PIC_DEBUG
+	std::cout << "Inline cache miss at "
+		<< (tail_call_site ? "tail" : "non-tail")
+		<< " call site 0x" << std::hex << return_address.value << std::dec
+		<< std::endl;
+#endif
 
 	data_root<array> cache_entries(dpop(),this);
 	fixnum index = untag_fixnum(dpop());
@@ -206,11 +221,12 @@ void *factor_vm::inline_cache_miss(cell return_address_)
 			cache_entries.value(),
 			klass,
 			method),this);
+
 		xt = compile_inline_cache(index,
 			generic_word.value(),
 			methods.value(),
 			new_cache_entries.value(),
-					  tail_call_site_p(return_address.value))->xt();
+			tail_call_site)->xt();
 	}
 
 	/* Install the new stub. */
@@ -224,9 +240,9 @@ void *factor_vm::inline_cache_miss(cell return_address_)
 
 #ifdef PIC_DEBUG
 		std::cout << "Updated "
-			<< (tail_call_site_p(return_address.value) ? "tail" : "non-tail")
+			<< (tail_call_site ? "tail" : "non-tail")
 			<< " call site 0x" << std::hex << return_address.value << std::dec
-			<< " with " << std::hex << (cell)xt << std::dec << "\n";
+			<< " with 0x" << std::hex << (cell)xt << std::dec << std::endl;
 #endif
 	}
 

vm/instruction_operands.hpp

@@ -18,8 +18,8 @@ enum relocation_type {
 	RT_HERE,
 	/* current code block */
 	RT_THIS,
-	/* immediate literal */
+	/* data heap literal */
-	RT_IMMEDIATE,
+	RT_LITERAL,
 	/* address of ctx var */
 	RT_CONTEXT,
 	/* untagged fixnum literal */
@@ -103,7 +103,7 @@ struct relocation_entry {
 		case RT_XT:
 		case RT_XT_PIC:
 		case RT_XT_PIC_TAIL:
-		case RT_IMMEDIATE:
+		case RT_LITERAL:
 		case RT_HERE:
 		case RT_UNTAGGED:
 		case RT_THIS:

vm/jit.cpp

@@ -82,6 +82,27 @@ void jit::emit_with_parameter(cell code_template_, cell argument_) {
 	emit(code_template.value());
 }
 
+bool jit::emit_subprimitive(cell word_, bool tail_call_p, bool stack_frame_p)
+{
+	data_root<word> word(word_,parent);
+	data_root<array> code_template(word->subprimitive,parent);
+	parameters.append(untag<array>(array_nth(code_template.untagged(),0)));
+	literals.append(untag<array>(array_nth(code_template.untagged(),1)));
+	emit(array_nth(code_template.untagged(),2));
+	if(array_capacity(code_template.untagged()) == 5)
+	{
+		if(tail_call_p)
+		{
+			if(stack_frame_p) emit(parent->special_objects[JIT_EPILOG]);
+			emit(array_nth(code_template.untagged(),4));
+			return true;
+		}
+		else
+			emit(array_nth(code_template.untagged(),3));
+	}
+	return false;
+}
+	
 void jit::emit_class_lookup(fixnum index, cell type)
 {
 	emit_with_literal(parent->special_objects[PIC_LOAD],tag_fixnum(-index * sizeof(cell)));

vm/jit.hpp

@@ -43,19 +43,7 @@ struct jit {
 		emit_with_literal(parent->special_objects[JIT_WORD_CALL],word);
 	}
 
-	void word_special(cell word)
+	bool emit_subprimitive(cell word_, bool tail_call_p, bool stack_frame_p);
-	{
-		emit_with_literal(parent->special_objects[JIT_WORD_SPECIAL],word);
-	}
-
-	void emit_subprimitive(cell word_)
-	{
-		data_root<word> word(word_,parent);
-		data_root<array> code_triple(word->subprimitive,parent);
-		parameters.append(untag<array>(array_nth(code_triple.untagged(),0)));
-		literals.append(untag<array>(array_nth(code_triple.untagged(),1)));
-		emit(array_nth(code_triple.untagged(),2));
-	}
 
 	void emit_class_lookup(fixnum index, cell type);
 

vm/objects.hpp

@@ -42,7 +42,6 @@ enum special_object {
 	JIT_PRIMITIVE,
 	JIT_WORD_JUMP,
 	JIT_WORD_CALL,
-	JIT_WORD_SPECIAL,
 	JIT_IF_WORD,
 	JIT_IF,
 	JIT_EPILOG,
@@ -55,20 +54,18 @@ enum special_object {
 	JIT_2DIP,
 	JIT_3DIP_WORD,
 	JIT_3DIP,
-	JIT_EXECUTE_WORD,
+	JIT_EXECUTE,
-	JIT_EXECUTE_JUMP,
-	JIT_EXECUTE_CALL,
 	JIT_DECLARE_WORD,
 
-	/* Callback stub generation in callbacks.c */
-	CALLBACK_STUB = 45,
-	
 	/* Incremented on every modify-code-heap call; invalidates call( inline
 	caching */
-	REDEFINITION_COUNTER = 46,
+	REDEFINITION_COUNTER = 47,
+
+	/* Callback stub generation in callbacks.c */
+	CALLBACK_STUB = 48,
 	
 	/* Polymorphic inline cache generation in inline_cache.c */
-	PIC_LOAD = 47,
+	PIC_LOAD = 49,
 	PIC_TAG,
 	PIC_TUPLE,
 	PIC_CHECK_TAG,

vm/primitives.cpp

@@ -143,9 +143,6 @@ const primitive_type primitives[] = {
 	primitive_double_bits,
 	primitive_bits_float,
 	primitive_bits_double,
-	primitive_fixnum_add,
-	primitive_fixnum_subtract,
-	primitive_fixnum_multiply,
 	primitive_fixnum_divint,
 	primitive_fixnum_divmod,
 	primitive_fixnum_shift,
@@ -279,8 +276,6 @@ const primitive_type primitives[] = {
 	primitive_jit_compile,
 	primitive_load_locals,
 	primitive_check_datastack,
-	primitive_inline_cache_miss,
-	primitive_inline_cache_miss_tail,
 	primitive_mega_cache_miss,
 	primitive_lookup_method,
 	primitive_reset_dispatch_stats,

vm/quotations.cpp

@@ -82,18 +82,23 @@ bool quotation_jit::declare_p(cell i, cell length)
 		&& array_nth(elements.untagged(),i + 1) == parent->special_objects[JIT_DECLARE_WORD];
 }
 
+bool quotation_jit::word_stack_frame_p(cell obj)
+{
+	return to_boolean(untag<word>(obj)->subprimitive)
+		|| obj == parent->special_objects[JIT_PRIMITIVE_WORD];
+}
+
 bool quotation_jit::stack_frame_p()
 {
 	fixnum length = array_capacity(elements.untagged());
-	fixnum i;
 
-	for(i = 0; i < length - 1; i++)
+	for(fixnum i = 0; i < length; i++)
 	{
 		cell obj = array_nth(elements.untagged(),i);
 		switch(tagged<object>(obj).type())
 		{
 		case WORD_TYPE:
-			if(!to_boolean(untag<word>(obj)->subprimitive))
+			if(i != length - 1 || word_stack_frame_p(obj))
 				return true;
 			break;
 		case QUOTATION_TYPE:
@@ -153,49 +158,22 @@ void quotation_jit::iterate_quotation()
 		switch(obj.type())
 		{
 		case WORD_TYPE:
-			/* Intrinsics */
+			/* Sub-primitives */
 			if(to_boolean(obj.as<word>()->subprimitive))
-				emit_subprimitive(obj.value());
-			/* The (execute) primitive is special-cased */
-			else if(obj.value() == parent->special_objects[JIT_EXECUTE_WORD])
 			{
-				if(i == length - 1)
+				tail_call = emit_subprimitive(obj.value(), /* word */
-				{
+					i == length - 1, /* tail_call_p */
-					if(stack_frame) emit(parent->special_objects[JIT_EPILOG]);
+					stack_frame); /* stack_frame_p */
-					tail_call = true;
-					emit(parent->special_objects[JIT_EXECUTE_JUMP]);
-				}
-				else
-					emit(parent->special_objects[JIT_EXECUTE_CALL]);
 			}
 			/* Everything else */
-			else
+			else if(i == length - 1)
-			{
-				if(i == length - 1)
 			{
 				if(stack_frame) emit(parent->special_objects[JIT_EPILOG]);
 				tail_call = true;
-					/* Inline cache misses are special-cased.
-					   The calling convention for tail
-					   calls stores the address of the next
-					   instruction in a register. However,
-					   PIC miss stubs themselves tail-call
-					   the inline cache miss primitive, and
-					   we don't want to clobber the saved
-					   address. */
-					if(obj.value() == parent->special_objects[PIC_MISS_WORD]
-					   || obj.value() == parent->special_objects[PIC_MISS_TAIL_WORD])
-					{
-						word_special(obj.value());
-					}
-					else
-					{
 				word_jump(obj.value());
 			}
-				}
 			else
 				word_call(obj.value());
-			}
 			break;
 		case WRAPPER_TYPE:
 			push(obj.as<wrapper>()->object);
@@ -209,8 +187,6 @@ void quotation_jit::iterate_quotation()
 				emit(parent->special_objects[JIT_PRIMITIVE]);
 
 				i++;
-
-				tail_call = true;
 			}
 			else
 				push(obj.value());
@@ -257,12 +233,13 @@ void quotation_jit::iterate_quotation()
 			/* Method dispatch */
 			if(mega_lookup_p(i,length))
 			{
+				if(stack_frame) emit(parent->special_objects[JIT_EPILOG]);
+				tail_call = true;
 				emit_mega_cache_lookup(
 					array_nth(elements.untagged(),i),
 					untag_fixnum(array_nth(elements.untagged(),i + 1)),
 					array_nth(elements.untagged(),i + 2));
 				i += 3;
-				tail_call = true;
 			}
 			/* Non-optimizing compiler ignores declarations */
 			else if(declare_p(i,length))
@@ -280,8 +257,7 @@ void quotation_jit::iterate_quotation()
 	{
 		set_position(length);
 
-		if(stack_frame)
+		if(stack_frame) emit(parent->special_objects[JIT_EPILOG]);
-			emit(parent->special_objects[JIT_EPILOG]);
 		emit(parent->special_objects[JIT_RETURN]);
 	}
 }
@@ -342,37 +318,6 @@ void factor_vm::primitive_quotation_xt()
 	drepl(allot_cell((cell)quot->xt));
 }
 
-/* Compile a word definition with the non-optimizing compiler. Allocates memory */
-void factor_vm::jit_compile_word(cell word_, cell def_, bool relocating)
-{
-	data_root<word> word(word_,this);
-	data_root<quotation> def(def_,this);
-
-	code_block *compiled = jit_compile_quot(word.value(),def.value(),relocating);
-	word->code = compiled;
-
-	if(to_boolean(word->pic_def)) jit_compile_quot(word->pic_def,relocating);
-	if(to_boolean(word->pic_tail_def)) jit_compile_quot(word->pic_tail_def,relocating);
-}
-
-void factor_vm::compile_all_words()
-{
-	data_root<array> words(find_all_words(),this);
-
-	cell i;
-	cell length = array_capacity(words.untagged());
-	for(i = 0; i < length; i++)
-	{
-		data_root<word> word(array_nth(words.untagged(),i),this);
-
-		if(!word->code || !word->code->optimized_p())
-			jit_compile_word(word.value(),word->def,false);
-
-		update_word_xt(word.untagged());
-
-	}
-}
-
 /* Allocates memory */
 fixnum factor_vm::quot_code_offset_to_scan(cell quot_, cell offset)
 {

vm/quotations.hpp

@@ -22,6 +22,7 @@ struct quotation_jit : public jit {
 	bool fast_3dip_p(cell i, cell length);
 	bool mega_lookup_p(cell i, cell length);
 	bool declare_p(cell i, cell length);
+	bool word_stack_frame_p(cell obj);
 	bool stack_frame_p();
 	void iterate_quotation();
 };

vm/slot_visitor.hpp

@@ -191,7 +191,7 @@ struct literal_references_visitor {
 
 	void operator()(instruction_operand op)
 	{
-		if(op.rel_type() == RT_IMMEDIATE)
+		if(op.rel_type() == RT_LITERAL)
 			op.store_value(visitor->visit_pointer(op.load_value()));
 	}
 };

vm/vm.hpp

@@ -232,7 +232,6 @@ struct factor_vm
 	void end_scan();
 	cell instances(cell type);
 	void primitive_all_instances();
-	cell find_all_words();
 
 	template<typename Generation, typename Iterator>
 	inline void each_object(Generation *gen, Iterator &iterator)
@@ -398,6 +397,9 @@ struct factor_vm
 	void update_word_xt(word *w_);
 	void primitive_optimized_p();
 	void primitive_wrapper();
+	void jit_compile_word(cell word_, cell def_, bool relocating);
+	cell find_all_words();
+	void compile_all_words();
 
 	//math
 	void primitive_bignum_to_fixnum();
@@ -562,7 +564,7 @@ struct factor_vm
 	void check_frame(stack_frame *frame);
 	callstack *allot_callstack(cell size);
 	stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom);
-	stack_frame *capture_start();
+	stack_frame *second_from_top_stack_frame();
 	void primitive_callstack();
 	void primitive_set_callstack();
 	code_block *frame_code(stack_frame *frame);
@@ -605,8 +607,6 @@ struct factor_vm
 	void set_quot_xt(quotation *quot, code_block *code);
 	code_block *jit_compile_quot(cell owner_, cell quot_, bool relocating);
 	void jit_compile_quot(cell quot_, bool relocating);
-	void jit_compile_word(cell word_, cell def_, bool relocating);
-	void compile_all_words();
 	fixnum quot_code_offset_to_scan(cell quot_, cell offset);
 	cell lazy_jit_compile_impl(cell quot_, stack_frame *stack);
 	void primitive_quot_compiled_p();

vm/words.cpp

@@ -3,6 +3,41 @@
 namespace factor
 {
 
+/* Compile a word definition with the non-optimizing compiler. Allocates memory */
+void factor_vm::jit_compile_word(cell word_, cell def_, bool relocating)
+{
+	data_root<word> word(word_,this);
+	data_root<quotation> def(def_,this);
+
+	code_block *compiled = jit_compile_quot(word.value(),def.value(),relocating);
+	word->code = compiled;
+
+	if(to_boolean(word->pic_def)) jit_compile_quot(word->pic_def,relocating);
+	if(to_boolean(word->pic_tail_def)) jit_compile_quot(word->pic_tail_def,relocating);
+}
+
+cell factor_vm::find_all_words()
+{
+	return instances(WORD_TYPE);
+}
+
+void factor_vm::compile_all_words()
+{
+	data_root<array> words(find_all_words(),this);
+
+	cell length = array_capacity(words.untagged());
+	for(cell i = 0; i < length; i++)
+	{
+		data_root<word> word(array_nth(words.untagged(),i),this);
+
+		if(!word->code || !word->code->optimized_p())
+			jit_compile_word(word.value(),word->def,false);
+
+		update_word_xt(word.untagged());
+
+	}
+}
+
 word *factor_vm::allot_word(cell name_, cell vocab_, cell hashcode_)
 {
 	data_root<object> vocab(vocab_,this);