vm: 4 bit tags, new representation of alien objects makes unbox-any-c-ptr more efficient (work in progress)

basis/bootstrap/image/image.factor

@@ -176,14 +176,12 @@ USERENV: callback-stub 45
 ! PIC stubs
 USERENV: pic-load 47
 USERENV: pic-tag 48
-USERENV: pic-hi-tag 49
+USERENV: pic-tuple 49
-USERENV: pic-tuple 50
+USERENV: pic-check-tag 50
-USERENV: pic-hi-tag-tuple 51
+USERENV: pic-check-tuple 51
-USERENV: pic-check-tag 52
+USERENV: pic-hit 52
-USERENV: pic-check 53
+USERENV: pic-miss-word 53
-USERENV: pic-hit 54
+USERENV: pic-miss-tail-word 54
-USERENV: pic-miss-word 55
-USERENV: pic-miss-tail-word 56
 
 ! Megamorphic dispatch
 USERENV: mega-lookup 57
@@ -227,7 +225,8 @@ USERENV: undefined-quot 60
 : emit-fixnum ( n -- ) tag-fixnum emit ;
 
 : emit-object ( class quot -- addr )
-    over tag-number here-as [ swap type-number tag-fixnum emit call align-here ] dip ;
+    [ type-number ] dip over here-as
+    [ swap tag-fixnum emit call align-here ] dip ;
     inline
 
 ! Write an object to the image.
@@ -308,7 +307,7 @@ M: float '
 
 M: f '
     #! f is #define F RETAG(0,F_TYPE)
-    drop \ f tag-number ;
+    drop \ f type-number ;
 
 :  0, ( -- )  0 >bignum '  0-offset fixup ;
 :  1, ( -- )  1 >bignum '  1-offset fixup ;

basis/compiler/cfg/alias-analysis/alias-analysis.factor

@@ -284,7 +284,7 @@ M: ##copy analyze-aliases*
 M: ##compare analyze-aliases*
     call-next-method
     dup useless-compare? [
-        dst>> \ f tag-number \ ##load-immediate new-insn
+        dst>> \ f type-number \ ##load-immediate new-insn
         analyze-aliases*
     ] when ;
 

basis/compiler/cfg/builder/builder-tests.factor

@@ -119,7 +119,6 @@ IN: compiler.cfg.builder.tests
 
 {
     byte-array
-    simple-alien
     alien
     POSTPONE: f
 } [| class |
@@ -192,7 +191,7 @@ IN: compiler.cfg.builder.tests
 ] unit-test
 
 [ f t ] [
-    [ { fixnum simple-alien } declare <displaced-alien> 0 alien-cell ]
+    [ { fixnum alien } declare <displaced-alien> 0 alien-cell ]
     [ [ ##unbox-any-c-ptr? ] contains-insn? ]
     [ [ ##unbox-alien? ] contains-insn? ] bi
 ] unit-test
@@ -205,7 +204,7 @@ IN: compiler.cfg.builder.tests
     ] unit-test
 
     [ f t ] [
-        [ { byte-array fixnum } declare alien-cell { simple-alien } declare 4 alien-float ]
+        [ { byte-array fixnum } declare alien-cell { alien } declare 4 alien-float ]
         [ [ ##box-alien? ] contains-insn? ]
         [ [ ##allot? ] contains-insn? ] bi
     ] unit-test

basis/compiler/cfg/builder/builder.factor

@@ -117,7 +117,7 @@ M: #recursive emit-node
     and ;
 
 : emit-trivial-if ( -- )
-    ds-pop \ f tag-number cc/= ^^compare-imm ds-push ;
+    ds-pop \ f type-number cc/= ^^compare-imm ds-push ;
 
 : trivial-not-if? ( #if -- ? )
     children>> first2
@@ -126,12 +126,12 @@ M: #recursive emit-node
     and ;
 
 : emit-trivial-not-if ( -- )
-    ds-pop \ f tag-number cc= ^^compare-imm ds-push ;
+    ds-pop \ f type-number cc= ^^compare-imm ds-push ;
 
 : emit-actual-if ( #if -- )
     ! Inputs to the final instruction need to be copied because of
     ! loc>vreg sync
-    ds-pop any-rep ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ;
+    ds-pop any-rep ^^copy \ f type-number cc/= ##compare-imm-branch emit-if ;
 
 M: #if emit-node
     {

basis/compiler/cfg/gc-checks/gc-checks.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences assocs fry
+USING: accessors kernel sequences assocs fry math
 cpu.architecture layouts
 compiler.cfg.rpo
 compiler.cfg.registers
@@ -21,12 +21,14 @@ GENERIC: allocation-size* ( insn -- n )
 
 M: ##allot allocation-size* size>> ;
 
-M: ##box-alien allocation-size* drop 4 cells ;
+M: ##box-alien allocation-size* drop 5 cells ;
 
-M: ##box-displaced-alien allocation-size* drop 4 cells ;
+M: ##box-displaced-alien allocation-size* drop 5 cells ;
 
 : allocation-size ( bb -- n )
-    instructions>> [ ##allocation? ] filter [ allocation-size* ] map-sum ;
+    instructions>>
+    [ ##allocation? ] filter
+    [ allocation-size* data-alignment align ] map-sum ;
 
 : insert-gc-check ( bb -- )
     dup dup '[

basis/compiler/cfg/hats/hats.factor

@@ -43,14 +43,14 @@ insn-classes get [
 
 : ^^load-literal ( obj -- dst )
     [ next-vreg dup ] dip {
-        { [ dup not ] [ drop \ f tag-number ##load-immediate ] }
+        { [ dup not ] [ drop \ f type-number ##load-immediate ] }
         { [ dup fixnum? ] [ tag-fixnum ##load-immediate ] }
         { [ dup float? ] [ ##load-constant ] }
         [ ##load-reference ]
     } cond ;
 
 : ^^offset>slot ( slot -- vreg' )
-    cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ;
+    cell 4 = 2 1 ? ^^shr-imm ;
 
 : ^^tag-fixnum ( src -- dst )
     tag-bits get ^^shl-imm ;

basis/compiler/cfg/instructions/instructions.factor

@@ -530,7 +530,7 @@ use: src/int-rep ;
 : ##unbox-c-ptr ( dst src class temp -- )
     {
         { [ over \ f class<= ] [ 2drop ##unbox-f ] }
-        { [ over simple-alien class<= ] [ 2drop ##unbox-alien ] }
+        { [ over alien class<= ] [ 2drop ##unbox-alien ] }
         { [ over byte-array class<= ] [ 2drop ##unbox-byte-array ] }
         [ nip ##unbox-any-c-ptr ]
     } cond ;

basis/compiler/cfg/intrinsics/allot/allot.factor

@@ -8,7 +8,7 @@ compiler.cfg.utilities compiler.cfg.builder.blocks ;
 IN: compiler.cfg.intrinsics.allot
 
 : ##set-slots ( regs obj class -- )
-    '[ _ swap 1 + _ tag-number ##set-slot-imm ] each-index ;
+    '[ _ swap 1 + _ type-number ##set-slot-imm ] each-index ;
 
 : emit-simple-allot ( node -- )
     [ in-d>> length ] [ node-output-infos first class>> ] bi
@@ -31,10 +31,10 @@ IN: compiler.cfg.intrinsics.allot
     ] [ drop emit-primitive ] if ;
 
 : store-length ( len reg class -- )
-    [ [ ^^load-literal ] dip 1 ] dip tag-number ##set-slot-imm ;
+    [ [ ^^load-literal ] dip 1 ] dip type-number ##set-slot-imm ;
 
 :: store-initial-element ( len reg elt class -- )
-    len [ [ elt reg ] dip 2 + class tag-number ##set-slot-imm ] each ;
+    len [ [ elt reg ] dip 2 + class type-number ##set-slot-imm ] each ;
 
 : expand-<array>? ( obj -- ? )
     dup integer? [ 0 8 between? ] [ drop f ] if ;

basis/compiler/cfg/intrinsics/fixnum/fixnum.factor

@@ -21,7 +21,7 @@ IN: compiler.cfg.intrinsics.fixnum
     ds-push ;
 
 : tag-literal ( n -- tagged )
-    literal>> [ tag-fixnum ] [ \ f tag-number ] if* ;
+    literal>> [ tag-fixnum ] [ \ f type-number ] if* ;
 
 : emit-fixnum-op ( insn -- )
     [ 2inputs ] dip call ds-push ; inline

basis/compiler/cfg/intrinsics/slots/slots.factor

@@ -8,7 +8,7 @@ compiler.cfg.instructions compiler.cfg.utilities
 compiler.cfg.builder.blocks compiler.constants ;
 IN: compiler.cfg.intrinsics.slots
 
-: value-tag ( info -- n ) class>> class-tag ; inline
+: value-tag ( info -- n ) class>> type-number ; inline
 
 : ^^tag-offset>slot ( slot tag -- vreg' )
     [ ^^offset>slot ] dip ^^sub-imm ;

basis/compiler/cfg/representations/representations.factor

@@ -47,7 +47,7 @@ M:: vector-rep emit-box ( dst src rep -- )
     int-rep next-vreg-rep :> temp
     dst 16 2 cells + byte-array int-rep next-vreg-rep ##allot
     temp 16 tag-fixnum ##load-immediate
-    temp dst 1 byte-array tag-number ##set-slot-imm
+    temp dst 1 byte-array type-number ##set-slot-imm
     dst byte-array-offset src rep ##set-alien-vector ;
 
 M: vector-rep emit-unbox

basis/compiler/cfg/value-numbering/rewrite/rewrite.factor

@@ -37,7 +37,7 @@ M: insn rewrite drop f ;
     dup ##compare-imm-branch? [
         {
             [ cc>> cc/= eq? ]
-            [ src2>> \ f tag-number eq? ]
+            [ src2>> \ f type-number eq? ]
         } 1&&
     ] [ drop f ] if ; inline
 
@@ -110,7 +110,7 @@ M: ##compare-imm rewrite-tagged-comparison
 : rewrite-redundant-comparison? ( insn -- ? )
     {
         [ src1>> vreg>expr general-compare-expr? ]
-        [ src2>> \ f tag-number = ]
+        [ src2>> \ f type-number = ]
         [ cc>> { cc= cc/= } member-eq? ]
     } 1&& ; inline
 
@@ -204,7 +204,7 @@ M: ##compare-branch rewrite
     [ dst>> ] dip
     {
         { t [ t \ ##load-constant new-insn ] }
-        { f [ \ f tag-number \ ##load-immediate new-insn ] }
+        { f [ \ f type-number \ ##load-immediate new-insn ] }
     } case ;
 
 : rewrite-self-compare ( insn -- insn' )

basis/compiler/constants/constants.factor

@@ -12,19 +12,18 @@ CONSTANT: deck-bits 18
 ! These constants must match vm/layouts.h
 : slot-offset ( slot tag -- n ) [ bootstrap-cells ] dip - ; inline
 
-: header-offset ( -- n ) 0 object tag-number slot-offset ; inline
+: float-offset ( -- n ) 8 float type-number - ; inline
-: float-offset ( -- n ) 8 float tag-number - ; inline
+: string-offset ( -- n ) 4 string type-number slot-offset ; inline
-: string-offset ( -- n ) 4 string tag-number slot-offset ; inline
+: string-aux-offset ( -- n ) 2 string type-number slot-offset ; inline
-: string-aux-offset ( -- n ) 2 string tag-number slot-offset ; inline
+: profile-count-offset ( -- n ) 8 \ word type-number slot-offset ; inline
-: profile-count-offset ( -- n ) 8 \ word tag-number slot-offset ; inline
+: byte-array-offset ( -- n ) 16 byte-array type-number - ; inline
-: byte-array-offset ( -- n ) 16 byte-array tag-number - ; inline
+: alien-offset ( -- n ) 4 alien type-number slot-offset ; inline
-: alien-offset ( -- n ) 3 alien tag-number slot-offset ; inline
+: underlying-alien-offset ( -- n ) 1 alien type-number slot-offset ; inline
-: underlying-alien-offset ( -- n ) 1 alien tag-number slot-offset ; inline
+: tuple-class-offset ( -- n ) 1 tuple type-number slot-offset ; inline
-: tuple-class-offset ( -- n ) 1 tuple tag-number slot-offset ; inline
+: word-xt-offset ( -- n ) 10 \ word type-number slot-offset ; inline
-: word-xt-offset ( -- n ) 10 \ word tag-number slot-offset ; inline
+: quot-xt-offset ( -- n ) 4 quotation type-number slot-offset ; inline
-: quot-xt-offset ( -- n ) 4 quotation tag-number slot-offset ; inline
+: word-code-offset ( -- n ) 11 \ word type-number slot-offset ; inline
-: word-code-offset ( -- n ) 11 \ word tag-number slot-offset ; inline
+: array-start-offset ( -- n ) 2 array type-number slot-offset ; inline
-: array-start-offset ( -- n ) 2 array tag-number slot-offset ; inline
 : compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
 
 ! Relocation classes

basis/compiler/tests/codegen.factor

@@ -175,20 +175,6 @@ TUPLE: my-tuple ;
     ] compile-call
 ] unit-test
 
-[ 1 t ] [
-    B{ 1 2 3 4 } [
-        { c-ptr } declare
-        [ 0 alien-unsigned-1 ] keep hi-tag
-    ] compile-call byte-array type-number =
-] unit-test
-
-[ t ] [
-    B{ 1 2 3 4 } [
-        { c-ptr } declare
-        0 alien-cell hi-tag
-    ] compile-call alien type-number =
-] unit-test
-
 [ 2 1 ] [
     2 1
     [ 2dup fixnum< [ [ die ] dip ] when ] compile-call

basis/compiler/tests/intrinsics.factor

@@ -419,7 +419,7 @@ cell 8 = [
 "b" get [
     [ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-call ] unit-test
     [ 3 ] [ "b" get [ { alien } declare 2 alien-unsigned-1 ] compile-call ] unit-test
-    [ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
+    [ 3 ] [ "b" get 2 [ { alien fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
     [ 3 ] [ "b" get 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
 
     [ ] [ "b" get free ] unit-test

basis/compiler/tests/low-level-ir.factor

@@ -50,7 +50,7 @@ IN: compiler.tests.low-level-ir
 ! one of the sources
 [ t ] [
     V{
-        T{ ##load-immediate f 1 $[ 2 cell log2 shift array tag-number - ] }
+        T{ ##load-immediate f 1 $[ 2 cell log2 shift array type-number - ] }
         T{ ##load-reference f 0 { t f t } }
         T{ ##slot f 0 0 1 }
     } compile-test-bb
@@ -59,13 +59,13 @@ IN: compiler.tests.low-level-ir
 [ t ] [
     V{
         T{ ##load-reference f 0 { t f t } }
-        T{ ##slot-imm f 0 0 2 $[ array tag-number ] }
+        T{ ##slot-imm f 0 0 2 $[ array type-number ] }
     } compile-test-bb
 ] unit-test
 
 [ t ] [
     V{
-        T{ ##load-immediate f 1 $[ 2 cell log2 shift array tag-number - ] }
+        T{ ##load-immediate f 1 $[ 2 cell log2 shift array type-number - ] }
         T{ ##load-reference f 0 { t f t } }
         T{ ##set-slot f 0 0 1 }
     } compile-test-bb
@@ -75,7 +75,7 @@ IN: compiler.tests.low-level-ir
 [ t ] [
     V{
         T{ ##load-reference f 0 { t f t } }
-        T{ ##set-slot-imm f 0 0 2 $[ array tag-number ] }
+        T{ ##set-slot-imm f 0 0 2 $[ array type-number ] }
     } compile-test-bb
     dup first eq?
 ] unit-test

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -279,7 +279,7 @@ generic-comparison-ops [
 ] each
 
 \ alien-cell [
-    2drop simple-alien \ f class-or <class-info>
+    2drop alien \ f class-or <class-info>
 ] "outputs" set-word-prop
 
 { <tuple> <tuple-boa> } [

basis/compiler/tree/propagation/propagation-tests.factor

@@ -890,10 +890,10 @@ M: tuple-with-read-only-slot clone
     [ { 1 2 3 } dup tuple-with-read-only-slot boa clone x>> eq? ] final-classes
 ] unit-test
 
-! alien-cell outputs a simple-alien or f
+! alien-cell outputs a alien or f
 [ t ] [
     [ { byte-array fixnum } declare alien-cell dup [ "OOPS" throw ] unless ] final-classes
-    first simple-alien class=
+    first alien class=
 ] unit-test
 
 ! Don't crash if bad literal inputs are passed to unsafe words

basis/cpu/ppc/bootstrap.factor

@@ -69,7 +69,7 @@ CONSTANT: rs-reg 14
 [
     3 ds-reg 0 LWZ
     ds-reg dup 4 SUBI
-    0 3 \ f tag-number CMPI
+    0 3 \ f type-number CMPI
     2 BEQ
     0 B rc-relative-ppc-3 rt-xt jit-rel
     0 B rc-relative-ppc-3 rt-xt jit-rel
@@ -174,40 +174,15 @@ CONSTANT: rs-reg 14
 
 [ load-tag ] pic-tag jit-define
 
-! Hi-tag
-[
-    3 4 MR
-    load-tag
-    0 4 object tag-number tag-fixnum CMPI
-    2 BNE
-    4 3 object tag-number neg LWZ
-] pic-hi-tag jit-define
-
 ! Tuple
 [
     3 4 MR
     load-tag
-    0 4 tuple tag-number tag-fixnum CMPI
+    0 4 tuple type-number tag-fixnum CMPI
     2 BNE
-    4 3 tuple tag-number neg bootstrap-cell + LWZ
+    4 3 tuple type-number neg bootstrap-cell + LWZ
 ] pic-tuple jit-define
 
-! Hi-tag and tuple
-[
-    3 4 MR
-    load-tag
-    ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)
-    0 4 BIN: 110 tag-fixnum CMPI
-    5 BLT
-    ! Untag r3
-    3 3 0 0 31 tag-bits get - RLWINM
-    ! Set r4 to 0 for objects, and bootstrap-cell for tuples
-    4 4 1 tag-fixnum ANDI
-    4 4 1 SRAWI
-    ! Load header cell or tuple layout cell
-    4 4 3 LWZX
-] pic-hi-tag-tuple jit-define
-
 [
     0 4 0 CMPI rc-absolute-ppc-2 rt-immediate jit-rel
 ] pic-check-tag jit-define
@@ -215,7 +190,7 @@ CONSTANT: rs-reg 14
 [
     0 5 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
     4 0 5 CMP
-] pic-check jit-define
+] pic-check-tuple jit-define
 
 [ 2 BNE 0 B rc-relative-ppc-3 rt-xt jit-rel ] pic-hit jit-define
 
@@ -283,7 +258,7 @@ CONSTANT: rs-reg 14
 [
     3 ds-reg 0 LWZ
     4 ds-reg -4 LWZU
-    3 3 1 SRAWI
+    3 3 2 SRAWI
     4 4 0 0 31 tag-bits get - RLWINM
     4 3 3 LWZX
     3 ds-reg 0 STW
@@ -404,7 +379,7 @@ CONSTANT: rs-reg 14
     5 ds-reg -4 LWZU
     5 0 4 CMP
     2 swap execute( offset -- ) ! magic number
-    \ f tag-number 3 LI
+    \ f type-number 3 LI
     3 ds-reg 0 STW ;
 
 : define-jit-compare ( insn word -- )
@@ -423,7 +398,7 @@ CONSTANT: rs-reg 14
     4 ds-reg 0 LWZ
     3 3 4 OR
     3 3 tag-mask get ANDI
-    \ f tag-number 4 LI
+    \ f type-number 4 LI
     0 3 0 CMPI
     2 BNE
     1 tag-fixnum 4 LI

basis/cpu/ppc/ppc.factor

@@ -266,7 +266,7 @@ M:: ppc %unbox-any-c-ptr ( dst src temp -- )
         ! We come back here with displaced aliens
         "start" resolve-label
         ! Is the object f?
-        0 scratch-reg \ f tag-number CMPI
+        0 scratch-reg \ f type-number CMPI
         ! If so, done
         "end" get BEQ
         ! Is the object an alien?
@@ -288,25 +288,20 @@ M:: ppc %unbox-any-c-ptr ( dst src temp -- )
         "end" resolve-label
     ] with-scope ;
 
-: alien@ ( n -- n' ) cells object tag-number - ;
+: alien@ ( n -- n' ) cells alien type-number - ;
-
-:: %allot-alien ( dst displacement base temp -- )
-    dst 4 cells alien temp %allot
-    temp \ f tag-number %load-immediate
-    ! Store underlying-alien slot
-    base dst 1 alien@ STW
-    ! Store expired slot
-    temp dst 2 alien@ STW
-    ! Store offset
-    displacement dst 3 alien@ STW ;
 
 M:: ppc %box-alien ( dst src temp -- )
     [
         "f" define-label
-        dst \ f tag-number %load-immediate
+        dst  %load-immediate
         0 src 0 CMPI
         "f" get BEQ
-        dst src temp temp %allot-alien
+        dst 5 cells alien temp %allot
+        temp \ f type-number %load-immediate
+        temp dst 1 alien@ STW
+        temp dst 2 alien@ STW
+        displacement dst 3 alien@ STW
+        displacement dst 4 alien@ STW
         "f" resolve-label
     ] with-scope ;
 
@@ -323,7 +318,7 @@ M:: ppc %box-displaced-alien ( dst displacement base displacement' base' base-cl
         displacement' :> temp
         dst 4 cells alien temp %allot
         ! If base is already a displaced alien, unpack it
-        0 base \ f tag-number CMPI
+        0 base \ f type-number CMPI
         "simple-case" get BEQ
         temp base header-offset LWZ
         0 temp alien type-number tag-fixnum CMPI
@@ -343,7 +338,7 @@ M:: ppc %box-displaced-alien ( dst displacement base displacement' base' base-cl
         ! Store offset
         displacement' dst 3 alien@ STW
         ! Store expired slot (its ok to clobber displacement')
-        temp \ f tag-number %load-immediate
+        temp \ f type-number %load-immediate
         temp dst 2 alien@ STW
         "end" resolve-label
     ] with-scope ;
@@ -382,7 +377,7 @@ M: ppc %set-alien-double -rot STFD ;
     scratch-reg dst 0 STW ;
 
 : store-tagged ( dst tag -- )
-    dupd tag-number ORI ;
+    dupd type-number ORI ;
 
 M:: ppc %allot ( dst size class nursery-ptr -- )
     nursery-ptr dst load-allot-ptr
@@ -460,7 +455,7 @@ M: ppc %epilogue ( n -- )
 
 :: (%boolean) ( dst temp branch1 branch2 -- )
     "end" define-label
-    dst \ f tag-number %load-immediate
+    dst \ f type-number %load-immediate
     "end" get branch1 execute( label -- )
     branch2 [ "end" get branch2 execute( label -- ) ] when
     dst \ t %load-reference

basis/cpu/x86/32/bootstrap.factor

@@ -21,7 +21,7 @@ IN: bootstrap.x86
 : stack-reg ( -- reg ) ESP ;
 : ds-reg ( -- reg ) ESI ;
 : rs-reg ( -- reg ) EDI ;
-: fixnum>slot@ ( -- ) temp0 1 SAR ;
+: fixnum>slot@ ( -- ) temp0 2 SAR ;
 : rex-length ( -- n ) 0 ;
 
 [

basis/cpu/x86/64/bootstrap.factor

@@ -18,7 +18,7 @@ IN: bootstrap.x86
 : stack-reg ( -- reg ) RSP ;
 : ds-reg ( -- reg ) R14 ;
 : rs-reg ( -- reg ) R15 ;
-: fixnum>slot@ ( -- ) ;
+: fixnum>slot@ ( -- ) temp0 1 SAR ;
 : rex-length ( -- n ) 1 ;
 
 [

basis/cpu/x86/bootstrap.factor

@@ -60,7 +60,7 @@ big-endian off
     ! pop boolean
     ds-reg bootstrap-cell SUB
     ! compare boolean with f
-    temp0 \ f tag-number CMP
+    temp0 \ f type-number CMP
     ! jump to true branch if not equal
     0 JNE rc-relative rt-xt jit-rel
     ! jump to false branch if equal
@@ -154,7 +154,7 @@ big-endian off
 
 ! ! ! Polymorphic inline caches
 
-! The PIC and megamorphic code stubs are not permitted to touch temp3.
+! The PIC stubs are not permitted to touch temp3.
 
 ! Load a value from a stack position
 [
@@ -171,41 +171,15 @@ big-endian off
 ! The 'make' trick lets us compute the jump distance for the
 ! conditional branches there
 
-! Hi-tag
-[
-    temp0 temp1 MOV
-    load-tag
-    temp1 object tag-number tag-fixnum CMP
-    [ temp1 temp0 object tag-number neg [+] MOV ] { } make
-    [ length JNE ] [ % ] bi
-] pic-hi-tag jit-define
-
 ! Tuple
 [
     temp0 temp1 MOV
     load-tag
-    temp1 tuple tag-number tag-fixnum CMP
+    temp1 tuple type-number tag-fixnum CMP
-    [ temp1 temp0 tuple tag-number neg bootstrap-cell + [+] MOV ] { } make
+    [ temp1 temp0 tuple type-number neg bootstrap-cell + [+] MOV ] { } make
     [ length JNE ] [ % ] bi
 ] pic-tuple jit-define
 
-! Hi-tag and tuple
-[
-    temp0 temp1 MOV
-    load-tag
-    ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)
-    temp1 BIN: 110 tag-fixnum CMP
-    [
-        ! Untag temp0
-        temp0 tag-mask get bitnot AND
-        ! Set temp1 to 0 for objects, and bootstrap-cell for tuples
-        temp1 1 tag-fixnum AND
-        bootstrap-cell 4 = [ temp1 1 SHR ] when
-        ! Load header cell or tuple layout cell
-        temp1 temp0 temp1 [+] MOV
-    ] [ ] make [ length JL ] [ % ] bi
-] pic-hi-tag-tuple jit-define
-
 [
     temp1 HEX: ffffffff CMP rc-absolute rt-immediate jit-rel
 ] pic-check-tag jit-define
@@ -213,7 +187,7 @@ big-endian off
 [
     temp2 HEX: ffffffff MOV rc-absolute-cell rt-immediate jit-rel
     temp1 temp2 CMP
-] pic-check jit-define
+] pic-check-tuple jit-define
 
 [ 0 JE rc-relative rt-xt jit-rel ] pic-hit jit-define
 
@@ -224,14 +198,7 @@ big-endian off
     temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
     ! key = hashcode(class)
     temp2 temp1 MOV
-    temp2 3 SHR
+    bootstrap-cell 4 = [ temp2 1 SHR ] when
-    temp3 temp1 MOV
-    temp3 8 SHR
-    temp2 temp3 ADD
-    temp3 temp1 MOV
-    temp3 13 SHR
-    temp2 temp3 ADD
-    temp2 bootstrap-cell 4 = 3 4 ? SHL
     ! key &= cache.length - 1
     temp2 mega-cache-size get 1 - bootstrap-cell * AND
     ! cache += array-start-offset
@@ -417,7 +384,7 @@ big-endian off
     t jit-literal
     temp3 0 MOV rc-absolute-cell rt-immediate jit-rel
     ! load f
-    temp1 \ f tag-number MOV
+    temp1 \ f type-number MOV
     ! load first value
     temp0 ds-reg [] MOV
     ! adjust stack pointer
@@ -547,7 +514,7 @@ big-endian off
     ds-reg bootstrap-cell SUB
     temp0 ds-reg [] OR
     temp0 tag-mask get AND
-    temp0 \ f tag-number MOV
+    temp0 \ f type-number MOV
     temp1 1 tag-fixnum MOV
     temp0 temp1 CMOVE
     ds-reg [] temp0 MOV

basis/cpu/x86/x86.factor

@@ -179,46 +179,37 @@ M: x86 %unbox-alien ( dst src -- )
 
 M:: x86 %unbox-any-c-ptr ( dst src temp -- )
     [
-        { "is-byte-array" "end" "start" } [ define-label ] each
+        "end" define-label
-        dst 0 MOV
+        ! Compute tag in temp register
         temp src MOV
-        ! We come back here with displaced aliens
+        temp tag-mask get AND
-        "start" resolve-label
+        dst 0 MOV
         ! Is the object f?
-        temp \ f tag-number CMP
+        src \ f type-number CMP
         "end" get JE
-        ! Is the object an alien?
-        temp header-offset [+] alien type-number tag-fixnum CMP
-        "is-byte-array" get JNE
-        ! If so, load the offset and add it to the address
-        dst temp alien-offset [+] ADD
-        ! Now recurse on the underlying alien
-        temp temp underlying-alien-offset [+] MOV
-        "start" get JMP
-        "is-byte-array" resolve-label
-        ! Add byte array address to address being computed
-        dst temp ADD
         ! Add an offset to start of byte array's data
-        dst byte-array-offset ADD
+        dst src byte-array-offset [+] LEA
+        ! Is the object an alien?
+        temp alien type-number CMP
+        "end" get JNE
+        ! If so, load the offset and add it to the address
+        dst src alien-offset [+] MOV
         "end" resolve-label
     ] with-scope ;
 
-: alien@ ( reg n -- op ) cells alien tag-number - [+] ;
+: alien@ ( reg n -- op ) cells alien type-number - [+] ;
-
-:: %allot-alien ( dst displacement base temp -- )
-    dst 4 cells alien temp %allot
-    dst 1 alien@ base MOV ! alien
-    dst 2 alien@ \ f tag-number MOV ! expired
-    dst 3 alien@ displacement MOV ! displacement
-    ;
 
 M:: x86 %box-alien ( dst src temp -- )
     [
         "end" define-label
-        dst \ f tag-number MOV
+        dst \ f type-number MOV
         src 0 CMP
         "end" get JE
-        dst src \ f tag-number temp %allot-alien
+        dst 5 cells alien temp %allot
+        dst 1 alien@ \ f type-number MOV ! base
+        dst 2 alien@ \ f type-number MOV ! expired
+        dst 3 alien@ displacement MOV ! displacement
+        dst 4 alien@ displacement MOV ! address
         "end" resolve-label
     ] with-scope ;
 
@@ -235,9 +226,10 @@ M:: x86 %box-displaced-alien ( dst displacement base displacement' base' base-cl
         ! If base is already a displaced alien, unpack it
         base' base MOV
         displacement' displacement MOV
-        base \ f tag-number CMP
+        base \ f type-number CMP
         "ok" get JE
-        base header-offset [+] alien type-number tag-fixnum CMP
+        ! XXX
+        base 0 [+] alien type-number tag-fixnum CMP
         "ok" get JNE
         ! displacement += base.displacement
         displacement' base 3 alien@ ADD
@@ -245,7 +237,7 @@ M:: x86 %box-displaced-alien ( dst displacement base displacement' base' base-cl
         base' base 1 alien@ MOV
         "ok" resolve-label
         dst 1 alien@ base' MOV ! alien
-        dst 2 alien@ \ f tag-number MOV ! expired
+        dst 2 alien@ \ f type-number MOV ! expired
         dst 3 alien@ displacement' MOV ! displacement
         "end" resolve-label
     ] with-scope ;
@@ -402,7 +394,7 @@ M: x86 %vm-field-ptr ( dst field -- )
     [ [] ] [ type-number tag-fixnum ] bi* MOV ;
 
 : store-tagged ( dst tag -- )
-    tag-number OR ;
+    type-number OR ;
 
 M:: x86 %allot ( dst size class nursery-ptr -- )
     nursery-ptr dst load-allot-ptr
@@ -444,7 +436,7 @@ M: x86 %alien-global ( dst symbol library -- )
 M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
 
 :: %boolean ( dst temp word -- )
-    dst \ f tag-number MOV
+    dst \ f type-number MOV
     temp 0 MOV \ t rc-absolute-cell rel-immediate
     dst temp word execute ; inline
 

basis/io/buffers/buffers.factor

@@ -8,7 +8,7 @@ IN: io.buffers
 
 TUPLE: buffer
 { size fixnum }
-{ ptr simple-alien }
+{ ptr alien }
 { fill fixnum }
 { pos fixnum }
 disposed ;

basis/stack-checker/known-words/known-words.factor

@@ -592,7 +592,7 @@ M: bad-executable summary
 
 \ set-alien-double { float c-ptr integer } { } define-primitive
 
-\ alien-cell { c-ptr integer } { simple-c-ptr } define-primitive
+\ alien-cell { c-ptr integer } { pinned-c-ptr } define-primitive
 \ alien-cell make-flushable
 
 \ set-alien-cell { c-ptr c-ptr integer } { } define-primitive

basis/tools/time/time.factor

@@ -13,18 +13,18 @@ IN: tools.time
 
 : dispatch-stats. ( stats -- )
     "== Megamorphic caches ==" print nl
-    { "Hits" "Misses" } swap zip simple-table. ;
+    [ { "Hits" "Misses" } ] dip zip simple-table. ;
 
 : inline-cache-stats. ( stats -- )
     "== Polymorphic inline caches ==" print nl
     3 cut
     [
         "- Transitions:" print
-        { "Cold to monomorphic" "Mono to polymorphic" "Poly to megamorphic" } swap zip
+        [ { "Cold to monomorphic" "Mono to polymorphic" "Poly to megamorphic" } ] dip zip
         simple-table. nl
     ] [
         "- Type check stubs:" print
-        { "Tag only" "Hi-tag" "Tuple" "Hi-tag and tuple" } swap zip
+        [ { "Tag" "Tuple" } ] dip zip
         simple-table.
     ] bi* ;
 

core/alien/alien.factor

@@ -4,19 +4,9 @@ USING: accessors assocs kernel math namespaces sequences system
 kernel.private byte-arrays arrays init ;
 IN: alien
 
-! Some predicate classes used by the compiler for optimization
+PREDICATE: pinned-alien < alien underlying>> not ;
-! purposes
-PREDICATE: simple-alien < alien underlying>> not ;
 
-UNION: simple-c-ptr
+UNION: pinned-c-ptr pinned-alien POSTPONE: f ;
-simple-alien POSTPONE: f byte-array ;
-
-DEFER: pinned-c-ptr?
-
-PREDICATE: pinned-alien < alien underlying>> pinned-c-ptr? ;
-
-UNION: pinned-c-ptr
-    pinned-alien POSTPONE: f ;
 
 GENERIC: >c-ptr ( obj -- c-ptr )
 
@@ -33,7 +23,7 @@ M: alien expired? expired>> ;
 M: f expired? drop t ;
 
 : <alien> ( address -- alien )
-    f <displaced-alien> { simple-c-ptr } declare ; inline
+    f <displaced-alien> { pinned-c-ptr } declare ; inline
 
 : <bad-alien> ( -- alien )
     -1 <alien> t >>expired ; inline

core/bootstrap/layouts/layouts.factor

@@ -7,32 +7,26 @@ kernel.private ;
 
 16 data-alignment set
 
-BIN: 111 tag-mask set
+BIN: 1111 tag-mask set
-8 num-tags set
+4 tag-bits set
-3 tag-bits set
 
-15 num-types set
+14 num-types set
 
 32 mega-cache-size set
 
 H{
-    { fixnum      BIN: 000 }
+    { fixnum 0 }
-    { bignum      BIN: 001 }
+    { bignum 1 }
-    { array       BIN: 010 }
+    { array 2 }
-    { float       BIN: 011 }
+    { float 3 }
-    { quotation   BIN: 100 }
+    { quotation 4 }
-    { POSTPONE: f BIN: 101 }
+    { POSTPONE: f 5 }
-    { object      BIN: 110 }
+    { alien 6 }
-    { hi-tag      BIN: 110 }
+    { tuple 7 }
-    { tuple       BIN: 111 }
-} tag-numbers set
-
-tag-numbers get H{
     { wrapper 8 }
     { byte-array 9 }
     { callstack 10 }
     { string 11 }
     { word 12 }
     { dll 13 }
-    { alien 14 }
+} type-numbers set
-} assoc-union type-numbers set

core/bootstrap/primitives.factor

@@ -177,10 +177,6 @@ bi
 
 "object?" "kernel" vocab-words delete-at
 
-! Class of objects with object tag
-"hi-tag" "kernel.private" create
-builtins get num-tags get tail define-union-class
-
 ! Empty class with no instances
 "null" "kernel" create
 [ f { } f union-class define-class ]

core/classes/algebra/algebra-docs.factor

@@ -17,7 +17,6 @@ ARTICLE: "class-operations" "Class operations"
     flatten-class
     flatten-builtin-class
     class-types
-    class-tags
 } ;
 
 ARTICLE: "class-linearization" "Class linearization"

core/classes/algebra/algebra-tests.factor

@@ -95,8 +95,6 @@ UNION: z1 b1 c1 ;
 
 [ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
 
-[ f ] [ growable \ hi-tag classes-intersect? ] unit-test
-
 [ t ] [
     growable tuple sequence class-and class<=
 ] unit-test

core/classes/algebra/algebra.factor

@@ -237,11 +237,5 @@ M: anonymous-union (flatten-class)
     flatten-builtin-class keys
     [ "type" word-prop ] map natural-sort ;
 
-: class-tags ( class -- seq )
+: class-type ( class -- tag/f )
-    class-types [
+    class-types dup length 1 = [ first ] [ drop f ] if ;
-        dup num-tags get >=
-        [ drop \ hi-tag tag-number ] when
-    ] map prune ;
-
-: class-tag ( class -- tag/f )
-    class-tags dup length 1 = [ first ] [ drop f ] if ;

core/classes/builtin/builtin.factor

@@ -12,34 +12,20 @@ PREDICATE: builtin-class < class
 
 : class>type ( class -- n ) "type" word-prop ; foldable
 
-PREDICATE: lo-tag-class < builtin-class class>type 7 <= ;
-
-PREDICATE: hi-tag-class < builtin-class class>type 7 > ;
-
 : type>class ( n -- class ) builtins get-global nth ;
 
 : bootstrap-type>class ( n -- class ) builtins get nth ;
 
-M: hi-tag class hi-tag type>class ; inline
-
 M: object class tag type>class ; inline
 
 M: builtin-class rank-class drop 0 ;
 
 GENERIC: define-builtin-predicate ( class -- )
 
-M: lo-tag-class define-builtin-predicate
+M: builtin-class define-builtin-predicate
     dup class>type [ eq? ] curry [ tag ] prepend define-predicate ;
 
-M: hi-tag-class define-builtin-predicate
+M: builtin-class instance? [ tag ] [ class>type ] bi* eq? ;
-    dup class>type [ eq? ] curry [ hi-tag ] prepend 1quotation
-    [ dup tag 6 eq? ] [ [ drop f ] if ] surround
-    define-predicate ;
-
-M: lo-tag-class instance? [ tag ] [ class>type ] bi* eq? ;
-
-M: hi-tag-class instance?
-    over tag 6 eq? [ [ hi-tag ] [ class>type ] bi* eq? ] [ 2drop f ] if ;
 
 M: builtin-class (flatten-class) dup set ;
 

core/classes/classes-tests.factor

@@ -11,7 +11,6 @@ IN: classes.tests
 [ f ] [ 3 float instance? ] unit-test
 [ t ] [ 3 number instance? ] unit-test
 [ f ] [ 3 null instance? ] unit-test
-[ t ] [ "hi" \ hi-tag instance? ] unit-test
 
 ! Regression
 GENERIC: method-forget-test ( obj -- obj )

core/generic/single/single.factor

@@ -112,15 +112,6 @@ TUPLE: tuple-dispatch-engine echelons ;
     tuple bootstrap-word
     \ <tuple-dispatch-engine> convert-methods ;
 
-! 2.2 Convert hi-tag methods
-TUPLE: hi-tag-dispatch-engine methods ;
-
-C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
-
-: convert-hi-tag-methods ( assoc -- assoc' )
-    \ hi-tag bootstrap-word
-    \ <hi-tag-dispatch-engine> convert-methods ;
-
 ! 3 Tag methods
 TUPLE: tag-dispatch-engine methods ;
 
@@ -129,7 +120,6 @@ C: <tag-dispatch-engine> tag-dispatch-engine
 : <engine> ( assoc -- engine )
     flatten-methods
     convert-tuple-methods
-    convert-hi-tag-methods
     <tag-dispatch-engine> ;
 
 ! ! ! Compile engine ! ! !
@@ -144,23 +134,12 @@ GENERIC: compile-engine ( engine -- obj )
 : direct-dispatch-table ( assoc n -- table )
     default get <array> [ <enum> swap update ] keep ;
 
-: lo-tag-number ( class -- n )
+: tag-number ( class -- n ) "type" word-prop ;
-    "type" word-prop dup num-tags get iota member?
-    [ drop object tag-number ] unless ;
 
 M: tag-dispatch-engine compile-engine
     methods>> compile-engines*
-    [ [ lo-tag-number ] dip ] assoc-map
+    [ [ tag-number ] dip ] assoc-map
-    num-tags get direct-dispatch-table ;
+    num-types get direct-dispatch-table ;
-
-: num-hi-tags ( -- n ) num-types get num-tags get - ;
-
-: hi-tag-number ( class -- n ) "type" word-prop ;
-
-M: hi-tag-dispatch-engine compile-engine
-    methods>> compile-engines*
-    [ [ hi-tag-number num-tags get - ] dip ] assoc-map
-    num-hi-tags direct-dispatch-table ;
 
 : build-fast-hash ( methods -- buckets )
     >alist V{ } clone [ hashcode 1array ] distribute-buckets

core/kernel/kernel-docs.factor

@@ -651,7 +651,7 @@ HELP: declare
 
 HELP: tag ( object -- n )
 { $values { "object" object } { "n" "a tag number" } }
-{ $description "Outputs an object's tag number, between zero and one less than " { $link num-tags } ". This is implementation detail and user code should call " { $link class } " instead." } ;
+{ $description "Outputs an object's tag number, between zero and one less than " { $link num-types } ". This is implementation detail and user code should call " { $link class } " instead." } ;
 
 HELP: getenv ( n -- obj )
 { $values { "n" "a non-negative integer" } { "obj" object } }

core/kernel/kernel.factor

@@ -230,8 +230,6 @@ ERROR: assert got expect ;
 
 : declare ( spec -- ) drop ;
 
-: hi-tag ( obj -- n ) { hi-tag } declare 0 slot ; inline
-
 : do-primitive ( number -- ) "Improper primitive call" throw ;
 
 PRIVATE>

core/layouts/layouts-docs.factor

@@ -7,18 +7,11 @@ HELP: tag-bits
 { $var-description "Number of least significant bits reserved for a type tag in a tagged pointer." }
 { $see-also tag } ;
 
-HELP: num-tags
-{ $var-description "Number of distinct pointer tags. This is one more than the maximum value from the " { $link tag } " primitive." } ;
-
 HELP: tag-mask
 { $var-description "Taking the bitwise and of a tagged pointer with this mask leaves the tag." } ;
 
 HELP: num-types
-{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link hi-tag } " primitive." } ;
+{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link tag } " primitive." } ;
-
-HELP: tag-number
-{ $values { "class" class } { "n" "an integer or " { $link f } } }
-{ $description "Outputs the pointer tag for pointers to instances of " { $link class } ". Will output " { $link f } " if instances of this class are not identified by a distinct pointer tag." } ;
 
 HELP: type-number
 { $values { "class" class } { "n" "an integer or " { $link f } } }
@@ -76,7 +69,7 @@ HELP: bootstrap-cell-bits
 
 ARTICLE: "layouts-types" "Type numbers"
 "Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:"
-{ $subsections hi-tag }
+{ $subsections tag }
 "Built-in type numbers can be converted to classes, and vice versa:"
 { $subsections
     type>class
@@ -88,14 +81,10 @@ ARTICLE: "layouts-types" "Type numbers"
 ARTICLE: "layouts-tags" "Tagged pointers"
 "Every pointer stored on the stack or in the heap has a " { $emphasis "tag" } ", which is a small integer identifying the type of the pointer. If the tag is not equal to one of the two special tags, the remaining bits contain the memory address of a heap-allocated object. The two special tags are the " { $link fixnum } " tag and the " { $link f } " tag."
 $nl
-"Getting the tag of an object:"
-{ $link tag }
 "Words for working with tagged pointers:"
 { $subsections
     tag-bits
-    num-tags
     tag-mask
-    tag-number
 }
 "The Factor VM does not actually expose any words for working with tagged pointers directly. The above words operate on integers; they are used in the bootstrap image generator and the optimizing compiler." ;
 

core/layouts/layouts.factor

@@ -8,14 +8,10 @@ SYMBOL: data-alignment
 
 SYMBOL: tag-mask
 
-SYMBOL: num-tags
-
 SYMBOL: tag-bits
 
 SYMBOL: num-types
 
-SYMBOL: tag-numbers
-
 SYMBOL: type-numbers
 
 SYMBOL: mega-cache-size
@@ -23,9 +19,6 @@ SYMBOL: mega-cache-size
 : type-number ( class -- n )
     type-numbers get at ;
 
-: tag-number ( class -- n )
-    type-number dup num-tags get >= [ drop object tag-number ] when ;
-
 : tag-fixnum ( n -- tagged )
     tag-bits get shift ;
 

vm/alien.cpp

@@ -14,7 +14,10 @@ char *factor_vm::pinned_alien_offset(cell obj)
 			alien *ptr = untag<alien>(obj);
 			if(to_boolean(ptr->expired))
 				general_error(ERROR_EXPIRED,obj,false_object,NULL);
-			return pinned_alien_offset(ptr->base) + ptr->displacement;
+			if(to_boolean(ptr->base))
+				type_error(ALIEN_TYPE,obj);
+			else
+				return (char *)ptr->address;
 		}
 	case F_TYPE:
 		return NULL;
@@ -41,6 +44,7 @@ cell factor_vm::allot_alien(cell delegate_, cell displacement)
 
 	new_alien->displacement = displacement;
 	new_alien->expired = false_object;
+	new_alien->update_address();
 
 	return new_alien.value();
 }
@@ -168,12 +172,7 @@ char *factor_vm::alien_offset(cell obj)
 	case BYTE_ARRAY_TYPE:
 		return untag<byte_array>(obj)->data<char>();
 	case ALIEN_TYPE:
-		{
+		return (char *)untag<alien>(obj)->address;
-			alien *ptr = untag<alien>(obj);
-			if(to_boolean(ptr->expired))
-				general_error(ERROR_EXPIRED,obj,false_object,NULL);
-			return alien_offset(ptr->base) + ptr->displacement;
-		}
 	case F_TYPE:
 		return NULL;
 	default:

vm/collector.hpp

@@ -111,9 +111,11 @@ template<typename TargetGeneration, typename Policy> struct collector {
 		workhorse.visit_handle(handle);
 	}
 
-	void trace_slots(object *ptr)
+	void trace_object(object *ptr)
 	{
 		workhorse.visit_slots(ptr);
+		if(ptr->h.hi_tag() == ALIEN_TYPE)
+			((alien *)ptr)->update_address();
 	}
 
 	void trace_roots()

vm/copying_collector.hpp

@@ -12,7 +12,7 @@ struct copying_collector : collector<TargetGeneration,Policy> {
 	{
 		while(scan && scan < this->target->here)
 		{
-			this->trace_slots((object *)scan);
+			this->trace_object((object *)scan);
 			scan = this->target->next_object_after(scan);
 		}
 	}

vm/cpu-ppc.S

@@ -37,7 +37,7 @@ DEF(void,primitive_fixnum_multiply,(void *vm)):
 	lwz r3,0(DS_REG)
 	lwz r4,-4(DS_REG)
 	subi DS_REG,DS_REG,4
-	srawi r3,r3,3
+	srawi r3,r3,4
 	mullwo. r6,r3,r4
 	bso multiply_overflow
 	stw r6,0(DS_REG)

vm/cpu-x86.S

@@ -25,7 +25,7 @@ DEF(void,primitive_fixnum_multiply,(void *myvm)):
 	mov (DS_REG),ARITH_TEMP_1
 	mov ARITH_TEMP_1,DIV_RESULT
 	mov -CELL_SIZE(DS_REG),ARITH_TEMP_2
-	sar $3,ARITH_TEMP_2
+	sar $4,ARITH_TEMP_2
 	sub $CELL_SIZE,DS_REG
 	imul ARITH_TEMP_2
 	jo multiply_overflow

vm/dispatch.cpp

@@ -70,16 +70,6 @@ cell factor_vm::lookup_tuple_method(cell obj, cell methods)
 	return false_object;
 }
 
-cell factor_vm::lookup_hi_tag_method(cell obj, cell methods)
-{
-	array *hi_tag_methods = untag<array>(methods);
-	cell tag = untag<object>(obj)->h.hi_tag() - HEADER_TYPE;
-#ifdef FACTOR_DEBUG
-	assert(tag < TYPE_COUNT - HEADER_TYPE);
-#endif
-	return array_nth(hi_tag_methods,tag);
-}
-
 cell factor_vm::lookup_method(cell obj, cell methods)
 {
 	cell tag = TAG(obj);
@@ -92,13 +82,6 @@ cell factor_vm::lookup_method(cell obj, cell methods)
 		else
 			return method;
 	}
-	else if(tag == OBJECT_TYPE)
-	{
-		if(TAG(method) == ARRAY_TYPE)
-			return lookup_hi_tag_method(obj,method);
-		else
-			return method;
-	}
 	else
 		return method;
 }
@@ -112,21 +95,17 @@ void factor_vm::primitive_lookup_method()
 
 cell factor_vm::object_class(cell obj)
 {
-	switch(TAG(obj))
+	cell tag = TAG(obj);
-	{
+	if(tag == TUPLE_TYPE)
-	case TUPLE_TYPE:
 		return untag<tuple>(obj)->layout;
-	case OBJECT_TYPE:
+	else
-		return untag<object>(obj)->h.value;
+		return tag_fixnum(tag);
-	default:
-		return tag_fixnum(TAG(obj));
-	}
 }
 
 cell factor_vm::method_cache_hashcode(cell klass, array *array)
 {
 	cell capacity = (array_capacity(array) >> 1) - 1;
-	return (((klass >> 3) + (klass >> 8) + (klass >> 13)) & capacity) << 1;
+	return ((klass >> TAG_BITS) & capacity) << 1;
 }
 
 void factor_vm::update_method_cache(cell cache, cell klass, cell method)
@@ -174,7 +153,7 @@ void quotation_jit::emit_mega_cache_lookup(cell methods_, fixnum index, cell cac
 	gc_root<array> cache(cache_,parent);
 
 	/* Generate machine code to determine the object's class. */
-	emit_class_lookup(index,PIC_HI_TAG_TUPLE);
+	emit_class_lookup(index,PIC_TUPLE);
 
 	/* Do a cache lookup. */
 	emit_with(parent->special_objects[MEGA_LOOKUP],cache.value());

vm/full_collector.cpp

@@ -52,7 +52,7 @@ void factor_vm::collect_mark_impl(bool trace_contexts_p)
 	{
 		object *obj = mark_stack->back();
 		mark_stack->pop_back();
-		collector.trace_slots(obj);
+		collector.trace_object(obj);
 		code_marker.visit_object_code_block(obj);
 	}
 

vm/image.cpp

@@ -90,9 +90,12 @@ void factor_vm::fixup_quotation(quotation *quot, cell code_relocation_base)
 		quot->xt = (void *)lazy_jit_compile;
 }
 
-void factor_vm::fixup_alien(alien *d)
+void factor_vm::fixup_alien(alien *ptr)
 {
-	if(!to_boolean(d->base)) d->expired = true_object;
+	if(!to_boolean(ptr->base))
+		ptr->expired = true_object;
+	else
+		ptr->update_address();
 }
 
 struct stack_frame_fixupper {

vm/inline_cache.cpp

@@ -9,7 +9,8 @@ void factor_vm::init_inline_caching(int max_size)
 	cold_call_to_ic_transitions = 0;
 	ic_to_pic_transitions = 0;
 	pic_to_mega_transitions = 0;
-	for(int i = 0; i < 4; i++) pic_counts[i] = 0;
+	pic_counts[0] = 0;
+	pic_counts[1] = 0;
 }
 
 void factor_vm::deallocate_inline_cache(cell return_address)
@@ -29,39 +30,20 @@ void factor_vm::deallocate_inline_cache(cell return_address)
 it contains */
 cell factor_vm::determine_inline_cache_type(array *cache_entries)
 {
-	bool seen_hi_tag = false, seen_tuple = false;
+	bool seen_tuple = false;
 
 	cell i;
 	for(i = 0; i < array_capacity(cache_entries); i += 2)
 	{
-		cell klass = array_nth(cache_entries,i);
-
 		/* Is it a tuple layout? */
-		switch(TAG(klass))
+		if(TAG(array_nth(cache_entries,i)) == ARRAY_TYPE)
 		{
-		case FIXNUM_TYPE:
-			{
-				fixnum type = untag_fixnum(klass);
-				if(type >= HEADER_TYPE)
-					seen_hi_tag = true;
-			}
-			break;
-		case ARRAY_TYPE:
 			seen_tuple = true;
 			break;
-		default:
-			critical_error("Expected a fixnum or array",klass);
-			break;
 		}
 	}
 
-	if(seen_hi_tag && seen_tuple) return PIC_HI_TAG_TUPLE;
+	return seen_tuple ? PIC_TUPLE : PIC_TAG;
-	if(seen_hi_tag && !seen_tuple) return PIC_HI_TAG;
-	if(!seen_hi_tag && seen_tuple) return PIC_TUPLE;
-	if(!seen_hi_tag && !seen_tuple) return PIC_TAG;
-
-	critical_error("Oops",0);
-	return 0;
 }
 
 void factor_vm::update_pic_count(cell type)
@@ -85,10 +67,10 @@ struct inline_cache_jit : public jit {
 void inline_cache_jit::emit_check(cell klass)
 {
 	cell code_template;
-	if(TAG(klass) == FIXNUM_TYPE && untag_fixnum(klass) < HEADER_TYPE)
+	if(TAG(klass) == FIXNUM_TYPE)
 		code_template = parent->special_objects[PIC_CHECK_TAG];
 	else
-		code_template = parent->special_objects[PIC_CHECK];
+		code_template = parent->special_objects[PIC_CHECK_TUPLE];
 
 	emit_with(code_template,klass);
 }
@@ -250,8 +232,8 @@ VM_C_API void *inline_cache_miss(cell return_address, factor_vm *parent)
 void factor_vm::primitive_reset_inline_cache_stats()
 {
 	cold_call_to_ic_transitions = ic_to_pic_transitions = pic_to_mega_transitions = 0;
-	cell i;
+	pic_counts[0] = 0;
-	for(i = 0; i < 4; i++) pic_counts[i] = 0;
+	pic_counts[1] = 0;
 }
 
 void factor_vm::primitive_inline_cache_stats()
@@ -260,9 +242,8 @@ void factor_vm::primitive_inline_cache_stats()
 	stats.add(allot_cell(cold_call_to_ic_transitions));
 	stats.add(allot_cell(ic_to_pic_transitions));
 	stats.add(allot_cell(pic_to_mega_transitions));
-	cell i;
+	stats.add(allot_cell(pic_counts[0]));
-	for(i = 0; i < 4; i++)
+	stats.add(allot_cell(pic_counts[1]));
-		stats.add(allot_cell(pic_counts[i]));
 	stats.trim();
 	dpush(stats.elements.value());
 }

vm/layouts.hpp

@@ -27,8 +27,8 @@ static const cell data_alignment = 16;
 
 #define WORD_SIZE (signed)(sizeof(cell)*8)
 
-#define TAG_MASK 7
+#define TAG_MASK 15
-#define TAG_BITS 3
+#define TAG_BITS 4
 #define TAG(x) ((cell)(x) & TAG_MASK)
 #define UNTAG(x) ((cell)(x) & ~TAG_MASK)
 #define RETAG(x,tag) (UNTAG(x) | (tag))
@@ -40,23 +40,18 @@ static const cell data_alignment = 16;
 #define FLOAT_TYPE 3
 #define QUOTATION_TYPE 4
 #define F_TYPE 5
-#define OBJECT_TYPE 6
+#define ALIEN_TYPE 6
 #define TUPLE_TYPE 7
-
-#define HEADER_TYPE 8 /* anything less than this is a tag */
-
-#define GC_COLLECTED 5 /* can be anything other than FIXNUM_TYPE */
-
-/*** Header types ***/
 #define WRAPPER_TYPE 8
 #define BYTE_ARRAY_TYPE 9
 #define CALLSTACK_TYPE 10
 #define STRING_TYPE 11
 #define WORD_TYPE 12
 #define DLL_TYPE 13
-#define ALIEN_TYPE 14
 
-#define TYPE_COUNT 15
+#define TYPE_COUNT 14
+
+#define GC_COLLECTED 5 /* can be anything other than FIXNUM_TYPE */
 
 enum code_block_type
 {
@@ -97,11 +92,6 @@ inline static cell tag_fixnum(fixnum untagged)
 	return RETAG(untagged << TAG_BITS,FIXNUM_TYPE);
 }
 
-inline static cell tag_for(cell type)
-{
-	return type < HEADER_TYPE ? type : OBJECT_TYPE;
-}
-
 struct object;
 
 struct header {
@@ -334,6 +324,16 @@ struct alien : public object {
 	cell expired;
 	/* untagged */
 	cell displacement;
+	/* untagged */
+	cell address;
+
+	void update_address()
+	{
+		if(base == false_object)
+			address = displacement;
+		else
+			address = UNTAG(base) + sizeof(byte_array) + displacement;
+	}
 };
 
 struct dll : public object {

vm/run.hpp

@@ -65,11 +65,9 @@ enum special_object {
 	/* Polymorphic inline cache generation in inline_cache.c */
 	PIC_LOAD            = 47,
 	PIC_TAG,
-	PIC_HI_TAG,
 	PIC_TUPLE,
-	PIC_HI_TAG_TUPLE,
 	PIC_CHECK_TAG,
-	PIC_CHECK,
+	PIC_CHECK_TUPLE,
 	PIC_HIT,
 	PIC_MISS_WORD,
 	PIC_MISS_TAIL_WORD,

vm/tagged.hpp

@@ -3,12 +3,12 @@ namespace factor
 
 template<typename Type> cell tag(Type *value)
 {
-	return RETAG(value,tag_for(Type::type_number));
+	return RETAG(value,Type::type_number);
 }
 
 inline static cell tag_dynamic(object *value)
 {
-	return RETAG(value,tag_for(value->h.hi_tag()));
+	return RETAG(value,value->h.hi_tag());
 }
 
 template<typename Type>
@@ -17,11 +17,7 @@ struct tagged
 	cell value_;
 
 	cell type() const {
-		cell tag = TAG(value_);
+		return TAG(value_);
-		if(tag == OBJECT_TYPE)
-			return ((object *)UNTAG(value_))->h.hi_tag();
-		else
-			return tag;
 	}
 
 	bool type_p(cell type_) const

vm/to_tenured_collector.cpp

@@ -16,7 +16,7 @@ void to_tenured_collector::tenure_reachable_objects()
 	{
 		object *obj = mark_stack->back();
 		mark_stack->pop_back();
-		this->trace_slots(obj);
+		this->trace_object(obj);
 	}
 }
 

vm/vm.hpp

@@ -83,8 +83,8 @@ struct factor_vm
 	cell cold_call_to_ic_transitions;
 	cell ic_to_pic_transitions;
 	cell pic_to_mega_transitions;
-	/* Indexed by PIC_TAG, PIC_HI_TAG, PIC_TUPLE, PIC_HI_TAG_TUPLE */
+	/* Indexed by PIC_TAG, PIC_TUPLE */
-	cell pic_counts[4];
+	cell pic_counts[2];
 
 	/* Number of entries in a polymorphic inline cache */
 	cell max_pic_size;
@@ -619,7 +619,6 @@ struct factor_vm
 	cell nth_superclass(tuple_layout *layout, fixnum echelon);
 	cell nth_hashcode(tuple_layout *layout, fixnum echelon);
 	cell lookup_tuple_method(cell obj, cell methods);
-	cell lookup_hi_tag_method(cell obj, cell methods);
 	cell lookup_method(cell obj, cell methods);
 	void primitive_lookup_method();
 	cell object_class(cell obj);