Merge branch 'master' into simd-cleanup

Conflicts:
	basis/math/vectors/simd/functor/functor.factor

Makefile

@@ -41,22 +41,23 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
 	vm/callstack.o \
 	vm/code_block.o \
 	vm/code_heap.o \
+	vm/compaction.o \
 	vm/contexts.o \
 	vm/data_heap.o \
 	vm/debug.o \
 	vm/dispatch.o \
 	vm/errors.o \
 	vm/factor.o \
+	vm/free_list.o \
 	vm/full_collector.o \
 	vm/gc.o \
-	vm/heap.o \
 	vm/image.o \
 	vm/inline_cache.o \
 	vm/io.o \
 	vm/jit.o \
 	vm/math.o \
 	vm/nursery_collector.o \
-	vm/old_space.o \
+	vm/object_start_map.o \
 	vm/primitives.o \
 	vm/profiler.o \
 	vm/quotations.o \

basis/alien/c-types/c-types.factor

@@ -230,6 +230,10 @@ M: byte-array byte-length length ; inline
 
 M: f byte-length drop 0 ; inline
 
+: >c-bool ( ? -- int ) 1 0 ? ; inline
+
+: c-bool> ( int -- ? ) 0 = not ; inline
+
 MIXIN: value-type
 
 : c-getter ( name -- quot )
@@ -256,6 +260,7 @@ PREDICATE: typedef-word < c-type-word
     "c-type" word-prop c-type-name? ;
 
 M: string typedef ( old new -- ) c-types get set-at ;
+
 M: word typedef ( old new -- )
     {
         [ nip define-symbol ]
@@ -292,7 +297,7 @@ M: long-long-type box-return ( c-type -- )
 
 : define-out ( name -- )
     [ "alien.c-types" constructor-word ]
-    [ dup c-setter '[ _ heap-size <byte-array> [ 0 @ ] keep ] ] bi
+    [ dup c-setter '[ _ heap-size (byte-array) [ 0 @ ] keep ] ] bi
     (( value -- c-ptr )) define-inline ;
 
 : define-primitive-type ( c-type name -- )
@@ -338,7 +343,7 @@ SYMBOLS:
         [ alien-signed-8 ] >>getter
         [ set-alien-signed-8 ] >>setter
         8 >>size
-        8 >>align
+        cpu x86.32? os windows? not and 4 8 ? >>align
         "box_signed_8" >>boxer
         "to_signed_8" >>unboxer
     \ longlong define-primitive-type
@@ -349,7 +354,7 @@ SYMBOLS:
         [ alien-unsigned-8 ] >>getter
         [ set-alien-unsigned-8 ] >>setter
         8 >>size
-        8 >>align
+        cpu x86.32? os windows? not and 4 8 ? >>align
         "box_unsigned_8" >>boxer
         "to_unsigned_8" >>unboxer
     \ ulonglong define-primitive-type
@@ -442,14 +447,24 @@ SYMBOLS:
         "to_cell" >>unboxer
     \ uchar define-primitive-type
 
+    cpu ppc? [
         <c-type>
-        [ alien-unsigned-1 0 = not ] >>getter
+            [ alien-unsigned-4 c-bool> ] >>getter
-        [ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter
+            [ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
+            4 >>size
+            4 >>align
+            "box_boolean" >>boxer
+            "to_boolean" >>unboxer
+    ] [
+        <c-type>
+            [ alien-unsigned-1 c-bool> ] >>getter
+            [ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
             1 >>size
             1 >>align
             "box_boolean" >>boxer
             "to_boolean" >>unboxer
         \ bool define-primitive-type
+    ] if
 
     <c-type>
         math:float >>class
@@ -470,17 +485,24 @@ SYMBOLS:
         [ alien-double ] >>getter
         [ [ >float ] 2dip set-alien-double ] >>setter
         8 >>size
-        8 >>align
+        cpu x86.32? os windows? not and 4 8 ? >>align
         "box_double" >>boxer
         "to_double" >>unboxer
         double-rep >>rep
         [ >float ] >>unboxer-quot
     \ double define-primitive-type
 
+    cpu x86.64? os windows? and [
+        \ longlong c-type \ ptrdiff_t typedef
+        \ longlong c-type \ intptr_t typedef
+        \ ulonglong c-type \ uintptr_t typedef
+        \ ulonglong c-type \ size_t typedef
+    ] [
         \ long c-type \ ptrdiff_t typedef
         \ long c-type \ intptr_t typedef
         \ ulong c-type \ uintptr_t typedef
         \ ulong c-type \ size_t typedef
+    ] if
 ] with-compilation-unit
 
 M: char-16-rep rep-component-type drop char ;

basis/alien/data/data.factor

@@ -65,10 +65,6 @@ M: memory-stream stream-read
 : byte-array>memory ( byte-array base -- )
     swap dup byte-length memcpy ; inline
 
-: >c-bool ( ? -- int ) 1 0 ? ; inline
-
-: c-bool> ( int -- ? ) 0 = not ; inline
-
 M: value-type c-type-rep drop int-rep ;
 
 M: value-type c-type-getter
@@ -77,5 +73,3 @@ M: value-type c-type-getter
 M: value-type c-type-setter ( type -- quot )
     [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
     '[ @ swap @ _ memcpy ] ;
-
-

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
@@ -217,13 +215,18 @@ USERENV: undefined-quot 60
 
 : here-as ( tag -- pointer ) here bitor ;
 
+: (align-here) ( alignment -- )
+    [ here neg ] dip rem
+    [ bootstrap-cell /i [ 0 emit ] times ] unless-zero ;
+
 : align-here ( -- )
-    here 8 mod 4 = [ 0 emit ] when ;
+    data-alignment get (align-here) ;
 
 : 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.
@@ -292,7 +295,7 @@ M: fake-bignum ' n>> tag-fixnum ;
 M: float '
     [
         float [
-            align-here double>bits emit-64
+            8 (align-here) double>bits emit-64
         ] emit-object
     ] cache-eql-object ;
 
@@ -304,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 ;
@@ -410,6 +413,7 @@ M: byte-array '
     [
         byte-array [
             dup length emit-fixnum
+            bootstrap-cell 4 = [ 0 emit 0 emit ] when
             pad-bytes emit-bytes
         ] emit-object
     ] cache-eq-object ;

basis/bootstrap/tools/tools.factor

@@ -12,6 +12,7 @@ IN: bootstrap.tools
     "tools.deploy"
     "tools.destructors"
     "tools.disassembler"
+    "tools.dispatch"
     "tools.memory"
     "tools.profiler"
     "tools.test"

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/def-use/def-use.factor

@@ -11,6 +11,10 @@ GENERIC: defs-vreg ( insn -- vreg/f )
 GENERIC: temp-vregs ( insn -- seq )
 GENERIC: uses-vregs ( insn -- seq )
 
+M: insn defs-vreg drop f ;
+M: insn temp-vregs drop { } ;
+M: insn uses-vregs drop { } ;
+
 M: ##phi uses-vregs inputs>> values ;
 
 <PRIVATE
@@ -24,19 +28,25 @@ M: ##phi uses-vregs inputs>> values ;
     } case ;
 
 : define-defs-vreg-method ( insn -- )
+    dup insn-def-slot dup [
         [ \ defs-vreg create-method ]
-    [ insn-def-slot [ name>> reader-word 1quotation ] [ [ drop f ] ] if* ] bi
+        [ name>> reader-word 1quotation ] bi*
-    define ;
+        define
+    ] [ 2drop ] if ;
 
 : define-uses-vregs-method ( insn -- )
+    dup insn-use-slots [ drop ] [
         [ \ uses-vregs create-method ]
-    [ insn-use-slots [ name>> ] map slot-array-quot ] bi
+        [ [ name>> ] map slot-array-quot ] bi*
-    define ;
+        define
+    ] if-empty ;
 
 : define-temp-vregs-method ( insn -- )
+    dup insn-temp-slots [ drop ] [
         [ \ temp-vregs create-method ]
-    [ insn-temp-slots [ name>> ] map slot-array-quot ] bi
+        [ [ name>> ] map slot-array-quot ] bi*
-    define ;
+        define
+    ] if-empty ;
 
 PRIVATE>
 

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

@@ -1,7 +1,7 @@
 ! 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
+cpu.architecture layouts namespaces
 compiler.cfg.rpo
 compiler.cfg.registers
 compiler.cfg.instructions
@@ -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 get 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

@@ -512,13 +512,12 @@ temp: temp/int-rep ;
 PURE-INSN: ##box-displaced-alien
 def: dst/int-rep
 use: displacement/int-rep base/int-rep
-temp: temp1/int-rep temp2/int-rep
+temp: temp/int-rep
 literal: base-class ;
 
 PURE-INSN: ##unbox-any-c-ptr
 def: dst/int-rep
-use: src/int-rep
+use: src/int-rep ;
-temp: temp/int-rep ;
 
 : ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
 : ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
@@ -527,12 +526,12 @@ PURE-INSN: ##unbox-alien
 def: dst/int-rep
 use: src/int-rep ;
 
-: ##unbox-c-ptr ( dst src class temp -- )
+: ##unbox-c-ptr ( dst src class -- )
     {
-        { [ over \ f class<= ] [ 2drop ##unbox-f ] }
+        { [ dup \ f class<= ] [ drop ##unbox-f ] }
-        { [ over simple-alien class<= ] [ 2drop ##unbox-alien ] }
+        { [ dup alien class<= ] [ drop ##unbox-alien ] }
-        { [ over byte-array class<= ] [ 2drop ##unbox-byte-array ] }
+        { [ dup byte-array class<= ] [ drop ##unbox-byte-array ] }
-        [ nip ##unbox-any-c-ptr ]
+        [ drop ##unbox-any-c-ptr ]
     } cond ;
 
 ! Alien accessors

basis/compiler/cfg/intrinsics/alien/alien.factor

@@ -33,7 +33,7 @@ IN: compiler.cfg.intrinsics.alien
     bi and ;
 
 : ^^unbox-c-ptr ( src class -- dst )
-    [ next-vreg dup ] 2dip next-vreg ##unbox-c-ptr ;
+    [ next-vreg dup ] 2dip ##unbox-c-ptr ;
 
 : prepare-alien-accessor ( info -- ptr-vreg offset )
     class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add 0 ;

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 ;
@@ -62,7 +62,7 @@ IN: compiler.cfg.intrinsics.allot
 : bytes>cells ( m -- n ) cell align cell /i ;
 
 : ^^allot-byte-array ( n -- dst )
-    2 cells + byte-array ^^allot ;
+    16 + byte-array ^^allot ;
 
 : emit-allot-byte-array ( len -- dst )
     ds-drop

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>> class-type ; inline
 
 : ^^tag-offset>slot ( slot tag -- vreg' )
     [ ^^offset>slot ] dip ^^sub-imm ;

basis/compiler/cfg/renaming/functor/functor.factor

@@ -20,15 +20,19 @@ WHERE
 
 GENERIC: rename-insn-defs ( insn -- )
 
-insn-classes get [
+M: insn rename-insn-defs drop ;
+
+insn-classes get [ insn-def-slot ] filter [
     [ \ rename-insn-defs create-method-in ]
-    [ insn-def-slot dup [ name>> 1array ] when DEF-QUOT slot-change-quot ] bi
+    [ insn-def-slot name>> 1array DEF-QUOT slot-change-quot ] bi
     define
 ] each
 
 GENERIC: rename-insn-uses ( insn -- )
 
-insn-classes get { ##phi } diff [
+M: insn rename-insn-uses drop ;
+
+insn-classes get { ##phi } diff [ insn-use-slots empty? not ] filter [
     [ \ rename-insn-uses create-method-in ]
     [ insn-use-slots [ name>> ] map USE-QUOT slot-change-quot ] bi
     define
@@ -39,7 +43,9 @@ M: ##phi rename-insn-uses
 
 GENERIC: rename-insn-temps ( insn -- )
 
-insn-classes get [
+M: insn rename-insn-temps drop ;
+
+insn-classes get [ insn-temp-slots empty? not ] filter [
     [ \ rename-insn-temps create-method-in ]
     [ insn-temp-slots [ name>> ] map TEMP-QUOT slot-change-quot ] bi
     define

basis/compiler/cfg/representations/preferred/preferred.factor

@@ -11,6 +11,10 @@ GENERIC: defs-vreg-rep ( insn -- rep/f )
 GENERIC: temp-vreg-reps ( insn -- reps )
 GENERIC: uses-vreg-reps ( insn -- reps )
 
+M: insn defs-vreg-rep drop f ;
+M: insn temp-vreg-reps drop { } ;
+M: insn uses-vreg-reps drop { } ;
+
 <PRIVATE
 
 : rep-getter-quot ( rep -- quot )
@@ -21,9 +25,11 @@ GENERIC: uses-vreg-reps ( insn -- reps )
     } case ;
 
 : define-defs-vreg-rep-method ( insn -- )
+    dup insn-def-slot dup [
         [ \ defs-vreg-rep create-method ]
-    [ insn-def-slot [ rep>> rep-getter-quot ] [ [ drop f ] ] if* ]
+        [ rep>> rep-getter-quot ]
-    bi define ;
+        bi* define
+    ] [ 2drop ] if ;
 
 : reps-getter-quot ( reps -- quot )
     dup [ rep>> { f scalar-rep } member-eq? not ] all? [
@@ -38,14 +44,18 @@ GENERIC: uses-vreg-reps ( insn -- reps )
     ] if ;
 
 : define-uses-vreg-reps-method ( insn -- )
+    dup insn-use-slots [ drop ] [
         [ \ uses-vreg-reps create-method ]
-    [ insn-use-slots reps-getter-quot ]
+        [ reps-getter-quot ]
-    bi define ;
+        bi* define
+    ] if-empty ;
 
 : define-temp-vreg-reps-method ( insn -- )
+    dup insn-temp-slots [ drop ] [
         [ \ temp-vreg-reps create-method ]
-    [ insn-temp-slots reps-getter-quot ]
+        [ reps-getter-quot ]
-    bi define ;
+        bi* define
+    ] if-empty ;
 
 PRIVATE>
 

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' )
@@ -440,7 +440,7 @@ M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ;
 :: rewrite-unbox-displaced-alien ( insn expr -- insns )
     [
         next-vreg :> temp
-        temp expr base>> vn>vreg expr base-class>> insn temp>> ##unbox-c-ptr
+        temp expr base>> vn>vreg expr base-class>> ##unbox-c-ptr
         insn dst>> temp expr displacement>> vn>vreg ##add
     ] { } make ;
 

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

@@ -82,7 +82,7 @@ IN: compiler.cfg.value-numbering.tests
         T{ ##load-reference f 1 + }
         T{ ##peek f 2 D 0 }
         T{ ##compare f 4 2 1 cc> }
-        T{ ##compare-imm f 6 4 5 cc/= }
+        T{ ##compare-imm f 6 4 $[ \ f type-number ] cc/= }
         T{ ##replace f 6 D 0 }
     } value-numbering-step trim-temps
 ] unit-test
@@ -100,7 +100,7 @@ IN: compiler.cfg.value-numbering.tests
         T{ ##load-reference f 1 + }
         T{ ##peek f 2 D 0 }
         T{ ##compare f 4 2 1 cc<= }
-        T{ ##compare-imm f 6 4 5 cc= }
+        T{ ##compare-imm f 6 4 $[ \ f type-number ] cc= }
         T{ ##replace f 6 D 0 }
     } value-numbering-step trim-temps
 ] unit-test
@@ -118,7 +118,7 @@ IN: compiler.cfg.value-numbering.tests
         T{ ##peek f 8 D 0 }
         T{ ##peek f 9 D -1 }
         T{ ##compare-float-unordered f 12 8 9 cc< }
-        T{ ##compare-imm f 14 12 5 cc= }
+        T{ ##compare-imm f 14 12 $[ \ f type-number ] cc= }
         T{ ##replace f 14 D 0 }
     } value-numbering-step trim-temps
 ] unit-test
@@ -135,7 +135,7 @@ IN: compiler.cfg.value-numbering.tests
         T{ ##peek f 29 D -1 }
         T{ ##peek f 30 D -2 }
         T{ ##compare f 33 29 30 cc<= }
-        T{ ##compare-imm-branch f 33 5 cc/= }
+        T{ ##compare-imm-branch f 33 $[ \ f type-number ] cc/= }
     } value-numbering-step trim-temps
 ] unit-test
 
@@ -149,7 +149,7 @@ IN: compiler.cfg.value-numbering.tests
     {
         T{ ##peek f 1 D -1 }
         T{ ##test-vector f 2 1 f float-4-rep vcc-any }
-        T{ ##compare-imm-branch f 2 5 cc/= }
+        T{ ##compare-imm-branch f 2 $[ \ f type-number ] cc/= }
     } value-numbering-step trim-temps
 ] unit-test
 
@@ -1071,14 +1071,14 @@ cell 8 = [
 ! Branch folding
 [
     {
-        T{ ##load-immediate f 1 1 }
+        T{ ##load-immediate f 1 10 }
-        T{ ##load-immediate f 2 2 }
+        T{ ##load-immediate f 2 20 }
-        T{ ##load-immediate f 3 5 }
+        T{ ##load-immediate f 3 $[ \ f type-number ] }
     }
 ] [
     {
-        T{ ##load-immediate f 1 1 }
+        T{ ##load-immediate f 1 10 }
-        T{ ##load-immediate f 2 2 }
+        T{ ##load-immediate f 2 20 }
         T{ ##compare f 3 1 2 cc= }
     } value-numbering-step
 ] unit-test
@@ -1113,14 +1113,14 @@ cell 8 = [
 
 [
     {
-        T{ ##load-immediate f 1 1 }
+        T{ ##load-immediate f 1 10 }
-        T{ ##load-immediate f 2 2 }
+        T{ ##load-immediate f 2 20 }
-        T{ ##load-immediate f 3 5 }
+        T{ ##load-immediate f 3 $[ \ f type-number ] }
     }
 ] [
     {
-        T{ ##load-immediate f 1 1 }
+        T{ ##load-immediate f 1 10 }
-        T{ ##load-immediate f 2 2 }
+        T{ ##load-immediate f 2 20 }
         T{ ##compare f 3 2 1 cc< }
     } value-numbering-step
 ] unit-test
@@ -1128,7 +1128,7 @@ cell 8 = [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 5 }
+        T{ ##load-immediate f 1 $[ \ f type-number ] }
     }
 ] [
     {
@@ -1152,7 +1152,7 @@ cell 8 = [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 5 }
+        T{ ##load-immediate f 1 $[ \ f type-number ] }
     }
 ] [
     {
@@ -1176,7 +1176,7 @@ cell 8 = [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 5 }
+        T{ ##load-immediate f 1 $[ \ f type-number ] }
     }
 ] [
     {
@@ -1557,7 +1557,7 @@ cell 8 = [
     {
         T{ ##peek f 0 D 0 }
         T{ ##compare f 1 0 0 cc<= }
-        T{ ##compare-imm-branch f 1 5 cc/= }
+        T{ ##compare-imm-branch f 1 $[ \ f type-number ] cc/= }
     } test-branch-folding
 ] unit-test
 
@@ -1659,7 +1659,7 @@ V{
     T{ ##copy { dst 21 } { src 20 } { rep any-rep } }
     T{ ##compare-imm-branch
         { src1 21 }
-        { src2 5 }
+        { src2 $[ \ f type-number ] }
         { cc cc/= }
     }
 } 1 test-bb

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 ) 2 byte-array tag-number slot-offset ; 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

@@ -244,20 +244,20 @@ IN: compiler.tests.intrinsics
 [ -4294967296 ] [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
 
 [ HEX: 10000000 ] [ HEX: 1000000 HEX: 10 [ fixnum* ] compile-call ] unit-test
-[ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
+[ HEX: 8000000 ] [ HEX: -8000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
-[ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test
+[ HEX: 8000000 ] [ HEX: -7ffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test
 
-[ t ] [ 1 27 fixnum-shift dup [ fixnum+ ] compile-call 1 28 fixnum-shift = ] unit-test
+[ t ] [ 1 26 fixnum-shift dup [ fixnum+ ] compile-call 1 27 fixnum-shift = ] unit-test
-[ -268435457 ] [ 1 28 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
+[ -134217729 ] [ 1 27 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
 
 [ t ] [ 1 20 shift 1 20 shift [ fixnum* ] compile-call 1 40 shift = ] unit-test
 [ t ] [ 1 20 shift neg 1 20 shift [ fixnum* ] compile-call 1 40 shift neg = ] unit-test
 [ t ] [ 1 20 shift neg 1 20 shift neg [ fixnum* ] compile-call 1 40 shift = ] unit-test
 [ -351382792 ] [ -43922849 [ 3 fixnum-shift ] compile-call ] unit-test
 
-[ 268435456 ] [ -268435456 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
+[ 134217728 ] [ -134217728 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
 
-[ 268435456 0 ] [ -268435456 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
+[ 134217728 0 ] [ -134217728 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
 
 [ t ] [ f [ f eq? ] compile-call ] unit-test
 
@@ -285,8 +285,8 @@ cell 8 = [
 
 ! 64-bit overflow
 cell 8 = [
-    [ t ] [ 1 59 fixnum-shift dup [ fixnum+ ] compile-call 1 60 fixnum-shift = ] unit-test
+    [ t ] [ 1 58 fixnum-shift dup [ fixnum+ ] compile-call 1 59 fixnum-shift = ] unit-test
-    [ -1152921504606846977 ] [ 1 60 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
+    [ -576460752303423489 ] [ 1 59 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
     
     [ t ] [ 1 40 shift 1 40 shift [ fixnum* ] compile-call 1 80 shift = ] unit-test
     [ t ] [ 1 40 shift neg 1 40 shift [ fixnum* ] compile-call 1 80 shift neg = ] unit-test
@@ -301,9 +301,9 @@ cell 8 = [
     [ -18446744073709551616 ] [ -1 [ 64 fixnum-shift ] compile-call ] unit-test
     [ -18446744073709551616 ] [ -1 [ 32 fixnum-shift 32 fixnum-shift ] compile-call ] unit-test
     
-    [ 1152921504606846976 ] [ -1152921504606846976 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
+    [ 576460752303423488 ] [ -576460752303423488 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
 
-    [ 1152921504606846976 0 ] [ -1152921504606846976 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
+    [ 576460752303423488 0 ] [ -576460752303423488 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
 
     [ -268435457 ] [ 28 2^ [ fixnum-bitnot ] compile-call ] unit-test
 ] when
@@ -311,12 +311,14 @@ cell 8 = [
 ! Some randomized tests
 : compiled-fixnum* ( a b -- c ) fixnum* ;
 
+ERROR: bug-in-fixnum* x y a b ;
+
 [ ] [
     10000 [ 
-        32 random-bits >fixnum 32 random-bits >fixnum
+        32 random-bits >fixnum
-        2dup
+        32 random-bits >fixnum
-        [ fixnum* ] 2keep compiled-fixnum* =
+        2dup [ fixnum* ] [ compiled-fixnum* ] 2bi 2dup =
-        [ 2drop ] [ "Oops" throw ] if
+        [ 2drop 2drop ] [ bug-in-fixnum* ] if
     ] times
 ] unit-test
 
@@ -419,7 +421,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

@@ -36,7 +36,7 @@ IN: compiler.tests.low-level-ir
 ! loading immediates
 [ f ] [
     V{
-        T{ ##load-immediate f 0 5 }
+        T{ ##load-immediate f 0 $[ \ f type-number ] }
     } compile-test-bb
 ] unit-test
 
@@ -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,12 +75,12 @@ 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
 
-[ 8 ] [
+[ 4 ] [
     V{
         T{ ##load-immediate f 0 4 }
         T{ ##shl f 0 0 0 }
@@ -90,16 +90,16 @@ IN: compiler.tests.low-level-ir
 [ 4 ] [
     V{
         T{ ##load-immediate f 0 4 }
-        T{ ##shl-imm f 0 0 3 }
+        T{ ##shl-imm f 0 0 4 }
     } compile-test-bb
 ] unit-test
 
 [ 31 ] [
     V{
         T{ ##load-reference f 1 B{ 31 67 52 } }
-        T{ ##unbox-any-c-ptr f 0 1 2 }
+        T{ ##unbox-any-c-ptr f 0 1 }
         T{ ##alien-unsigned-1 f 0 0 0 }
-        T{ ##shl-imm f 0 0 3 }
+        T{ ##shl-imm f 0 0 4 }
     } compile-test-bb
 ] unit-test
 
@@ -108,13 +108,13 @@ IN: compiler.tests.low-level-ir
         T{ ##load-reference f 0 "hello world" }
         T{ ##load-immediate f 1 3 }
         T{ ##string-nth f 0 0 1 2 }
-        T{ ##shl-imm f 0 0 3 }
+        T{ ##shl-imm f 0 0 4 }
     } compile-test-bb
 ] unit-test
 
 [ 1 ] [
     V{
-        T{ ##load-immediate f 0 16 }
+        T{ ##load-immediate f 0 32 }
-        T{ ##add-imm f 0 0 -8 }
+        T{ ##add-imm f 0 0 -16 }
     } compile-test-bb
 ] unit-test

basis/compiler/tests/optimizer.factor

@@ -202,7 +202,7 @@ USE: binary-search.private
     dup length 1 <= [
         from>>
     ] [
-        [ midpoint swap call ] 3keep roll dup zero?
+        [ midpoint swap call ] 3keep [ rot ] dip swap dup zero?
         [ drop dup from>> swap midpoint@ + ]
         [ drop dup midpoint@ head-slice old-binsearch ] if
     ] if ; inline recursive

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

@@ -278,7 +278,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/architecture/architecture.factor

@@ -386,9 +386,9 @@ M: object %horizontal-shl-vector-imm-reps { } ;
 M: object %horizontal-shr-vector-imm-reps { } ;
 
 HOOK: %unbox-alien cpu ( dst src -- )
-HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
+HOOK: %unbox-any-c-ptr cpu ( dst src -- )
 HOOK: %box-alien cpu ( dst src temp -- )
-HOOK: %box-displaced-alien cpu ( dst displacement base temp1 temp2 base-class -- )
+HOOK: %box-displaced-alien cpu ( dst displacement base temp base-class -- )
 
 HOOK: %alien-unsigned-1 cpu ( dst src offset -- )
 HOOK: %alien-unsigned-2 cpu ( dst src offset -- )

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
 
@@ -224,8 +199,13 @@ CONSTANT: rs-reg 14
 [
     ! cache = ...
     0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
-    ! key = class
+    ! key = hashcode(class)
-    5 4 MR
+    5 4 3 SRAWI
+    6 4 8 SRAWI
+    5 5 6 ADD
+    6 4 13 SRAWI
+    5 5 6 ADD
+    5 5 3 SLWI
     ! key &= cache.length - 1
     5 5 mega-cache-size get 1 - bootstrap-cell * ANDI
     ! cache += array-start-offset
@@ -278,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
@@ -399,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 -- )
@@ -418,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 ;
@@ -374,7 +369,7 @@ M: ppc %set-alien-double -rot STFD ;
     [ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ;
 
 :: inc-allot-ptr ( nursery-ptr allot-ptr n -- )
-    scratch-reg allot-ptr n 8 align ADDI
+    scratch-reg allot-ptr n data-alignment get align ADDI
     scratch-reg nursery-ptr 0 STW ;
 
 :: store-header ( dst class -- )
@@ -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
@@ -742,14 +737,3 @@ USE: vocabs.loader
 } cond
 
 "complex-double" c-type t >>return-in-registers? drop
-
-[
-    <c-type>
-        [ alien-unsigned-4 c-bool> ] >>getter
-        [ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
-        4 >>size
-        4 >>align
-        "box_boolean" >>boxer
-        "to_boolean" >>unboxer
-    bool define-primitive-type
-] with-compilation-unit

basis/cpu/x86/32/32.factor

@@ -11,9 +11,6 @@ cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
 cpu.architecture ;
 IN: cpu.x86.32
 
-! We implement the FFI for Linux, OS X and Windows all at once.
-! OS X requires that the stack be 16-byte aligned.
-
 M: x86.32 machine-registers
     {
         { int-regs { EAX ECX EDX EBP EBX } }
@@ -327,10 +324,4 @@ M: x86.32 dummy-fp-params? f ;
 ! Dreadful
 M: object flatten-value-type (flatten-int-type) ;
 
-os windows? [
-    cell longlong c-type (>>align)
-    cell ulonglong c-type (>>align)
-    4 double c-type (>>align)
-] unless
-
 check-sse

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/64/winnt/winnt.factor

@@ -24,9 +24,3 @@ M: x86.64 dummy-fp-params? t ;
 
 M: x86.64 temp-reg RAX ;
 
-<<
-longlong ptrdiff_t typedef
-longlong intptr_t  typedef
-int  c-type long  define-primitive-type
-uint c-type ulong define-primitive-type
->>

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
 
@@ -222,9 +196,9 @@ big-endian off
 [
     ! cache = ...
     temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
-    ! key = class
+    ! key = hashcode(class)
     temp2 temp1 MOV
-    bootstrap-cell 8 = [ temp2 1 SHL ] when
+    bootstrap-cell 4 = [ temp2 1 SHR ] when
     ! key &= cache.length - 1
     temp2 mega-cache-size get 1 - bootstrap-cell * AND
     ! cache += array-start-offset
@@ -410,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
@@ -540,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

@@ -45,8 +45,7 @@ HOOK: extra-stack-space cpu ( stack-frame -- n )
 : incr-stack-reg ( n -- )
     dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
 
-: align-stack ( n -- n' )
+: align-stack ( n -- n' ) 16 align ;
-    os macosx? cpu x86.64? or [ 16 align ] when ;
 
 M: x86 stack-frame-size ( stack-frame -- i )
     [ (stack-frame-size) ]
@@ -141,8 +140,10 @@ M: x86 %not     int-rep one-operand NOT ;
 M: x86 %neg     int-rep one-operand NEG ;
 M: x86 %log2    BSR ;
 
+! A bit of logic to avoid using MOVSS/MOVSD for reg-reg moves
+! since this induces partial register stalls
 GENERIC: copy-register* ( dst src rep -- )
-GENERIC: copy-unaligned* ( dst src rep -- )
+GENERIC: copy-memory* ( dst src rep -- )
 
 M: int-rep copy-register* drop MOV ;
 M: tagged-rep copy-register* drop MOV ;
@@ -152,17 +153,14 @@ M: float-4-rep copy-register* drop MOVAPS ;
 M: double-2-rep copy-register* drop MOVAPS ;
 M: vector-rep copy-register* drop MOVDQA ;
 
-M: object copy-unaligned* copy-register* ;
+M: object copy-memory* copy-register* ;
-M: float-rep copy-unaligned* drop MOVSS ;
+M: float-rep copy-memory* drop MOVSS ;
-M: double-rep copy-unaligned* drop MOVSD ;
+M: double-rep copy-memory* drop MOVSD ;
-M: float-4-rep copy-unaligned* drop MOVUPS ;
-M: double-2-rep copy-unaligned* drop MOVUPS ;
-M: vector-rep copy-unaligned* drop MOVDQU ;
 
 M: x86 %copy ( dst src rep -- )
     2over eq? [ 3drop ] [
         [ [ dup spill-slot? [ n>> spill@ ] when ] bi@ ] dip
-        2over [ register? ] both? [ copy-register* ] [ copy-unaligned* ] if
+        2over [ register? ] both? [ copy-register* ] [ copy-memory* ] if
     ] if ;
 
 M: x86 %fixnum-add ( label dst src1 src2 -- )
@@ -177,76 +175,109 @@ M: x86 %fixnum-mul ( label dst src1 src2 -- )
 M: x86 %unbox-alien ( dst src -- )
     alien-offset [+] MOV ;
 
-M:: x86 %unbox-any-c-ptr ( dst src temp -- )
+M:: x86 %unbox-any-c-ptr ( dst src -- )
     [
-        { "is-byte-array" "end" "start" } [ define-label ] each
+        "end" define-label
-        dst 0 MOV
+        dst dst XOR
-        temp src MOV
-        ! We come back here with displaced aliens
-        "start" resolve-label
         ! Is the object f?
-        temp \ f tag-number CMP
+        src \ f type-number CMP
         "end" get JE
+        ! Compute tag in dst register
+        dst src MOV
+        dst tag-mask get AND
         ! Is the object an alien?
-        temp header-offset [+] alien type-number tag-fixnum CMP
+        dst alien type-number 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
+        "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
+        src src TEST
         "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@ src MOV ! displacement
+        dst 4 alien@ src MOV ! address
         "end" resolve-label
     ] with-scope ;
 
-M:: x86 %box-displaced-alien ( dst displacement base displacement' base' base-class -- )
+M:: x86 %box-displaced-alien ( dst displacement base temp base-class -- )
+    ! This is ridiculous
     [
         "end" define-label
-        "ok" define-label
+        "not-f" define-label
+        "not-alien" define-label
+
         ! If displacement is zero, return the base
         dst base MOV
-        displacement 0 CMP
+        displacement displacement TEST
         "end" get JE
-        ! Quickly use displacement' before its needed for real, as allot temporary
+
-        dst 4 cells alien displacement' %allot
+        ! Displacement is non-zero, we're going to be allocating a new
-        ! If base is already a displaced alien, unpack it
+        ! object
-        base' base MOV
+        dst 5 cells alien temp %allot
-        displacement' displacement MOV
+
-        base \ f tag-number CMP
+        ! Set expired to f
-        "ok" get JE
+        dst 2 alien@ \ f type-number MOV
-        base header-offset [+] alien type-number tag-fixnum CMP
+
-        "ok" get JNE
+        ! Is base f?
-        ! displacement += base.displacement
+        base \ f type-number CMP
-        displacement' base 3 alien@ ADD
+        "not-f" get JNE
-        ! base = base.base
+
-        base' base 1 alien@ MOV
+        ! Yes, it is f. Fill in new object
-        "ok" resolve-label
+        dst 1 alien@ base MOV
-        dst 1 alien@ base' MOV ! alien
+        dst 3 alien@ displacement MOV
-        dst 2 alien@ \ f tag-number MOV ! expired
+        dst 4 alien@ displacement MOV
-        dst 3 alien@ displacement' MOV ! displacement
+
+        "end" get JMP
+
+        "not-f" resolve-label
+
+        ! Check base type
+        temp base MOV
+        temp tag-mask get AND
+
+        ! Is base an alien?
+        temp alien type-number CMP
+        "not-alien" get JNE
+
+        ! Yes, it is an alien. Set new alien's base to base.base
+        temp base 1 alien@ MOV
+        dst 1 alien@ temp MOV
+
+        ! Compute displacement
+        temp base 3 alien@ MOV
+        temp displacement ADD
+        dst 3 alien@ temp MOV
+
+        ! Compute address
+        temp base 4 alien@ MOV
+        temp displacement ADD
+        dst 4 alien@ temp MOV
+
+        ! We are done
+        "end" get JMP
+
+        ! Is base a byte array? It has to be, by now...
+        "not-alien" resolve-label
+
+        dst 1 alien@ base MOV
+        dst 3 alien@ displacement MOV
+        temp base MOV
+        temp byte-array-offset ADD
+        temp displacement ADD
+        dst 4 alien@ temp MOV
+
         "end" resolve-label
     ] with-scope ;
 
@@ -396,13 +427,13 @@ M: x86 %vm-field-ptr ( dst field -- )
     [ drop "nursery" %vm-field-ptr ] [ swap [] MOV ] 2bi ;
 
 : inc-allot-ptr ( nursery-ptr n -- )
-    [ [] ] dip 8 align ADD ;
+    [ [] ] dip data-alignment get align ADD ;
 
 : store-header ( temp class -- )
     [ [] ] [ 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 +475,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/game/input/dinput/keys-array/keys-array.factor

@@ -1,5 +1,5 @@
 USING: sequences sequences.private math
-accessors alien.data ;
+accessors alien.c-types ;
 IN: game.input.dinput.keys-array
 
 TUPLE: keys-array

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/io/encodings/8-bit/8-bit.factor

@@ -27,6 +27,7 @@ CONSTANT: mappings {
     { "latin9" "ISO-8859-15" "8859-15" }
     { "latin10" "ISO-8859-16" "8859-16" }
     { "koi8-r" "KOI8-R" "KOI8-R" }
+    { "windows-1250" "windows-1250" "CP1250" }
     { "windows-1252" "windows-1252" "CP1252" }
     { "ebcdic" "IBM037" "CP037" }
     { "mac-roman" "macintosh" "ROMAN" }

basis/io/encodings/8-bit/CP1250.TXT

@@ -0,0 +1,274 @@
+#
+#    Name:     cp1250 to Unicode table
+#    Unicode version: 2.0
+#    Table version: 2.01
+#    Table format:  Format A
+#    Date:          04/15/98
+#
+#    Contact:       Shawn.Steele@microsoft.com
+#
+#    General notes: none
+#
+#    Format: Three tab-separated columns
+#        Column #1 is the cp1250 code (in hex)
+#        Column #2 is the Unicode (in hex as 0xXXXX)
+#        Column #3 is the Unicode name (follows a comment sign, '#')
+#
+#    The entries are in cp1250 order
+#
+0x00	0x0000	#NULL
+0x01	0x0001	#START OF HEADING
+0x02	0x0002	#START OF TEXT
+0x03	0x0003	#END OF TEXT
+0x04	0x0004	#END OF TRANSMISSION
+0x05	0x0005	#ENQUIRY
+0x06	0x0006	#ACKNOWLEDGE
+0x07	0x0007	#BELL
+0x08	0x0008	#BACKSPACE
+0x09	0x0009	#HORIZONTAL TABULATION
+0x0A	0x000A	#LINE FEED
+0x0B	0x000B	#VERTICAL TABULATION
+0x0C	0x000C	#FORM FEED
+0x0D	0x000D	#CARRIAGE RETURN
+0x0E	0x000E	#SHIFT OUT
+0x0F	0x000F	#SHIFT IN
+0x10	0x0010	#DATA LINK ESCAPE
+0x11	0x0011	#DEVICE CONTROL ONE
+0x12	0x0012	#DEVICE CONTROL TWO
+0x13	0x0013	#DEVICE CONTROL THREE
+0x14	0x0014	#DEVICE CONTROL FOUR
+0x15	0x0015	#NEGATIVE ACKNOWLEDGE
+0x16	0x0016	#SYNCHRONOUS IDLE
+0x17	0x0017	#END OF TRANSMISSION BLOCK
+0x18	0x0018	#CANCEL
+0x19	0x0019	#END OF MEDIUM
+0x1A	0x001A	#SUBSTITUTE
+0x1B	0x001B	#ESCAPE
+0x1C	0x001C	#FILE SEPARATOR
+0x1D	0x001D	#GROUP SEPARATOR
+0x1E	0x001E	#RECORD SEPARATOR
+0x1F	0x001F	#UNIT SEPARATOR
+0x20	0x0020	#SPACE
+0x21	0x0021	#EXCLAMATION MARK
+0x22	0x0022	#QUOTATION MARK
+0x23	0x0023	#NUMBER SIGN
+0x24	0x0024	#DOLLAR SIGN
+0x25	0x0025	#PERCENT SIGN
+0x26	0x0026	#AMPERSAND
+0x27	0x0027	#APOSTROPHE
+0x28	0x0028	#LEFT PARENTHESIS
+0x29	0x0029	#RIGHT PARENTHESIS
+0x2A	0x002A	#ASTERISK
+0x2B	0x002B	#PLUS SIGN
+0x2C	0x002C	#COMMA
+0x2D	0x002D	#HYPHEN-MINUS
+0x2E	0x002E	#FULL STOP
+0x2F	0x002F	#SOLIDUS
+0x30	0x0030	#DIGIT ZERO
+0x31	0x0031	#DIGIT ONE
+0x32	0x0032	#DIGIT TWO
+0x33	0x0033	#DIGIT THREE
+0x34	0x0034	#DIGIT FOUR
+0x35	0x0035	#DIGIT FIVE
+0x36	0x0036	#DIGIT SIX
+0x37	0x0037	#DIGIT SEVEN
+0x38	0x0038	#DIGIT EIGHT
+0x39	0x0039	#DIGIT NINE
+0x3A	0x003A	#COLON
+0x3B	0x003B	#SEMICOLON
+0x3C	0x003C	#LESS-THAN SIGN
+0x3D	0x003D	#EQUALS SIGN
+0x3E	0x003E	#GREATER-THAN SIGN
+0x3F	0x003F	#QUESTION MARK
+0x40	0x0040	#COMMERCIAL AT
+0x41	0x0041	#LATIN CAPITAL LETTER A
+0x42	0x0042	#LATIN CAPITAL LETTER B
+0x43	0x0043	#LATIN CAPITAL LETTER C
+0x44	0x0044	#LATIN CAPITAL LETTER D
+0x45	0x0045	#LATIN CAPITAL LETTER E
+0x46	0x0046	#LATIN CAPITAL LETTER F
+0x47	0x0047	#LATIN CAPITAL LETTER G
+0x48	0x0048	#LATIN CAPITAL LETTER H
+0x49	0x0049	#LATIN CAPITAL LETTER I
+0x4A	0x004A	#LATIN CAPITAL LETTER J
+0x4B	0x004B	#LATIN CAPITAL LETTER K
+0x4C	0x004C	#LATIN CAPITAL LETTER L
+0x4D	0x004D	#LATIN CAPITAL LETTER M
+0x4E	0x004E	#LATIN CAPITAL LETTER N
+0x4F	0x004F	#LATIN CAPITAL LETTER O
+0x50	0x0050	#LATIN CAPITAL LETTER P
+0x51	0x0051	#LATIN CAPITAL LETTER Q
+0x52	0x0052	#LATIN CAPITAL LETTER R
+0x53	0x0053	#LATIN CAPITAL LETTER S
+0x54	0x0054	#LATIN CAPITAL LETTER T
+0x55	0x0055	#LATIN CAPITAL LETTER U
+0x56	0x0056	#LATIN CAPITAL LETTER V
+0x57	0x0057	#LATIN CAPITAL LETTER W
+0x58	0x0058	#LATIN CAPITAL LETTER X
+0x59	0x0059	#LATIN CAPITAL LETTER Y
+0x5A	0x005A	#LATIN CAPITAL LETTER Z
+0x5B	0x005B	#LEFT SQUARE BRACKET
+0x5C	0x005C	#REVERSE SOLIDUS
+0x5D	0x005D	#RIGHT SQUARE BRACKET
+0x5E	0x005E	#CIRCUMFLEX ACCENT
+0x5F	0x005F	#LOW LINE
+0x60	0x0060	#GRAVE ACCENT
+0x61	0x0061	#LATIN SMALL LETTER A
+0x62	0x0062	#LATIN SMALL LETTER B
+0x63	0x0063	#LATIN SMALL LETTER C
+0x64	0x0064	#LATIN SMALL LETTER D
+0x65	0x0065	#LATIN SMALL LETTER E
+0x66	0x0066	#LATIN SMALL LETTER F
+0x67	0x0067	#LATIN SMALL LETTER G
+0x68	0x0068	#LATIN SMALL LETTER H
+0x69	0x0069	#LATIN SMALL LETTER I
+0x6A	0x006A	#LATIN SMALL LETTER J
+0x6B	0x006B	#LATIN SMALL LETTER K
+0x6C	0x006C	#LATIN SMALL LETTER L
+0x6D	0x006D	#LATIN SMALL LETTER M
+0x6E	0x006E	#LATIN SMALL LETTER N
+0x6F	0x006F	#LATIN SMALL LETTER O
+0x70	0x0070	#LATIN SMALL LETTER P
+0x71	0x0071	#LATIN SMALL LETTER Q
+0x72	0x0072	#LATIN SMALL LETTER R
+0x73	0x0073	#LATIN SMALL LETTER S
+0x74	0x0074	#LATIN SMALL LETTER T
+0x75	0x0075	#LATIN SMALL LETTER U
+0x76	0x0076	#LATIN SMALL LETTER V
+0x77	0x0077	#LATIN SMALL LETTER W
+0x78	0x0078	#LATIN SMALL LETTER X
+0x79	0x0079	#LATIN SMALL LETTER Y
+0x7A	0x007A	#LATIN SMALL LETTER Z
+0x7B	0x007B	#LEFT CURLY BRACKET
+0x7C	0x007C	#VERTICAL LINE
+0x7D	0x007D	#RIGHT CURLY BRACKET
+0x7E	0x007E	#TILDE
+0x7F	0x007F	#DELETE
+0x80	0x20AC	#EURO SIGN
+0x81	      	#UNDEFINED
+0x82	0x201A	#SINGLE LOW-9 QUOTATION MARK
+0x83	      	#UNDEFINED
+0x84	0x201E	#DOUBLE LOW-9 QUOTATION MARK
+0x85	0x2026	#HORIZONTAL ELLIPSIS
+0x86	0x2020	#DAGGER
+0x87	0x2021	#DOUBLE DAGGER
+0x88	      	#UNDEFINED
+0x89	0x2030	#PER MILLE SIGN
+0x8A	0x0160	#LATIN CAPITAL LETTER S WITH CARON
+0x8B	0x2039	#SINGLE LEFT-POINTING ANGLE QUOTATION MARK
+0x8C	0x015A	#LATIN CAPITAL LETTER S WITH ACUTE
+0x8D	0x0164	#LATIN CAPITAL LETTER T WITH CARON
+0x8E	0x017D	#LATIN CAPITAL LETTER Z WITH CARON
+0x8F	0x0179	#LATIN CAPITAL LETTER Z WITH ACUTE
+0x90	      	#UNDEFINED
+0x91	0x2018	#LEFT SINGLE QUOTATION MARK
+0x92	0x2019	#RIGHT SINGLE QUOTATION MARK
+0x93	0x201C	#LEFT DOUBLE QUOTATION MARK
+0x94	0x201D	#RIGHT DOUBLE QUOTATION MARK
+0x95	0x2022	#BULLET
+0x96	0x2013	#EN DASH
+0x97	0x2014	#EM DASH
+0x98	      	#UNDEFINED
+0x99	0x2122	#TRADE MARK SIGN
+0x9A	0x0161	#LATIN SMALL LETTER S WITH CARON
+0x9B	0x203A	#SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
+0x9C	0x015B	#LATIN SMALL LETTER S WITH ACUTE
+0x9D	0x0165	#LATIN SMALL LETTER T WITH CARON
+0x9E	0x017E	#LATIN SMALL LETTER Z WITH CARON
+0x9F	0x017A	#LATIN SMALL LETTER Z WITH ACUTE
+0xA0	0x00A0	#NO-BREAK SPACE
+0xA1	0x02C7	#CARON
+0xA2	0x02D8	#BREVE
+0xA3	0x0141	#LATIN CAPITAL LETTER L WITH STROKE
+0xA4	0x00A4	#CURRENCY SIGN
+0xA5	0x0104	#LATIN CAPITAL LETTER A WITH OGONEK
+0xA6	0x00A6	#BROKEN BAR
+0xA7	0x00A7	#SECTION SIGN
+0xA8	0x00A8	#DIAERESIS
+0xA9	0x00A9	#COPYRIGHT SIGN
+0xAA	0x015E	#LATIN CAPITAL LETTER S WITH CEDILLA
+0xAB	0x00AB	#LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xAC	0x00AC	#NOT SIGN
+0xAD	0x00AD	#SOFT HYPHEN
+0xAE	0x00AE	#REGISTERED SIGN
+0xAF	0x017B	#LATIN CAPITAL LETTER Z WITH DOT ABOVE
+0xB0	0x00B0	#DEGREE SIGN
+0xB1	0x00B1	#PLUS-MINUS SIGN
+0xB2	0x02DB	#OGONEK
+0xB3	0x0142	#LATIN SMALL LETTER L WITH STROKE
+0xB4	0x00B4	#ACUTE ACCENT
+0xB5	0x00B5	#MICRO SIGN
+0xB6	0x00B6	#PILCROW SIGN
+0xB7	0x00B7	#MIDDLE DOT
+0xB8	0x00B8	#CEDILLA
+0xB9	0x0105	#LATIN SMALL LETTER A WITH OGONEK
+0xBA	0x015F	#LATIN SMALL LETTER S WITH CEDILLA
+0xBB	0x00BB	#RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xBC	0x013D	#LATIN CAPITAL LETTER L WITH CARON
+0xBD	0x02DD	#DOUBLE ACUTE ACCENT
+0xBE	0x013E	#LATIN SMALL LETTER L WITH CARON
+0xBF	0x017C	#LATIN SMALL LETTER Z WITH DOT ABOVE
+0xC0	0x0154	#LATIN CAPITAL LETTER R WITH ACUTE
+0xC1	0x00C1	#LATIN CAPITAL LETTER A WITH ACUTE
+0xC2	0x00C2	#LATIN CAPITAL LETTER A WITH CIRCUMFLEX
+0xC3	0x0102	#LATIN CAPITAL LETTER A WITH BREVE
+0xC4	0x00C4	#LATIN CAPITAL LETTER A WITH DIAERESIS
+0xC5	0x0139	#LATIN CAPITAL LETTER L WITH ACUTE
+0xC6	0x0106	#LATIN CAPITAL LETTER C WITH ACUTE
+0xC7	0x00C7	#LATIN CAPITAL LETTER C WITH CEDILLA
+0xC8	0x010C	#LATIN CAPITAL LETTER C WITH CARON
+0xC9	0x00C9	#LATIN CAPITAL LETTER E WITH ACUTE
+0xCA	0x0118	#LATIN CAPITAL LETTER E WITH OGONEK
+0xCB	0x00CB	#LATIN CAPITAL LETTER E WITH DIAERESIS
+0xCC	0x011A	#LATIN CAPITAL LETTER E WITH CARON
+0xCD	0x00CD	#LATIN CAPITAL LETTER I WITH ACUTE
+0xCE	0x00CE	#LATIN CAPITAL LETTER I WITH CIRCUMFLEX
+0xCF	0x010E	#LATIN CAPITAL LETTER D WITH CARON
+0xD0	0x0110	#LATIN CAPITAL LETTER D WITH STROKE
+0xD1	0x0143	#LATIN CAPITAL LETTER N WITH ACUTE
+0xD2	0x0147	#LATIN CAPITAL LETTER N WITH CARON
+0xD3	0x00D3	#LATIN CAPITAL LETTER O WITH ACUTE
+0xD4	0x00D4	#LATIN CAPITAL LETTER O WITH CIRCUMFLEX
+0xD5	0x0150	#LATIN CAPITAL LETTER O WITH DOUBLE ACUTE
+0xD6	0x00D6	#LATIN CAPITAL LETTER O WITH DIAERESIS
+0xD7	0x00D7	#MULTIPLICATION SIGN
+0xD8	0x0158	#LATIN CAPITAL LETTER R WITH CARON
+0xD9	0x016E	#LATIN CAPITAL LETTER U WITH RING ABOVE
+0xDA	0x00DA	#LATIN CAPITAL LETTER U WITH ACUTE
+0xDB	0x0170	#LATIN CAPITAL LETTER U WITH DOUBLE ACUTE
+0xDC	0x00DC	#LATIN CAPITAL LETTER U WITH DIAERESIS
+0xDD	0x00DD	#LATIN CAPITAL LETTER Y WITH ACUTE
+0xDE	0x0162	#LATIN CAPITAL LETTER T WITH CEDILLA
+0xDF	0x00DF	#LATIN SMALL LETTER SHARP S
+0xE0	0x0155	#LATIN SMALL LETTER R WITH ACUTE
+0xE1	0x00E1	#LATIN SMALL LETTER A WITH ACUTE
+0xE2	0x00E2	#LATIN SMALL LETTER A WITH CIRCUMFLEX
+0xE3	0x0103	#LATIN SMALL LETTER A WITH BREVE
+0xE4	0x00E4	#LATIN SMALL LETTER A WITH DIAERESIS
+0xE5	0x013A	#LATIN SMALL LETTER L WITH ACUTE
+0xE6	0x0107	#LATIN SMALL LETTER C WITH ACUTE
+0xE7	0x00E7	#LATIN SMALL LETTER C WITH CEDILLA
+0xE8	0x010D	#LATIN SMALL LETTER C WITH CARON
+0xE9	0x00E9	#LATIN SMALL LETTER E WITH ACUTE
+0xEA	0x0119	#LATIN SMALL LETTER E WITH OGONEK
+0xEB	0x00EB	#LATIN SMALL LETTER E WITH DIAERESIS
+0xEC	0x011B	#LATIN SMALL LETTER E WITH CARON
+0xED	0x00ED	#LATIN SMALL LETTER I WITH ACUTE
+0xEE	0x00EE	#LATIN SMALL LETTER I WITH CIRCUMFLEX
+0xEF	0x010F	#LATIN SMALL LETTER D WITH CARON
+0xF0	0x0111	#LATIN SMALL LETTER D WITH STROKE
+0xF1	0x0144	#LATIN SMALL LETTER N WITH ACUTE
+0xF2	0x0148	#LATIN SMALL LETTER N WITH CARON
+0xF3	0x00F3	#LATIN SMALL LETTER O WITH ACUTE
+0xF4	0x00F4	#LATIN SMALL LETTER O WITH CIRCUMFLEX
+0xF5	0x0151	#LATIN SMALL LETTER O WITH DOUBLE ACUTE
+0xF6	0x00F6	#LATIN SMALL LETTER O WITH DIAERESIS
+0xF7	0x00F7	#DIVISION SIGN
+0xF8	0x0159	#LATIN SMALL LETTER R WITH CARON
+0xF9	0x016F	#LATIN SMALL LETTER U WITH RING ABOVE
+0xFA	0x00FA	#LATIN SMALL LETTER U WITH ACUTE
+0xFB	0x0171	#LATIN SMALL LETTER U WITH DOUBLE ACUTE
+0xFC	0x00FC	#LATIN SMALL LETTER U WITH DIAERESIS
+0xFD	0x00FD	#LATIN SMALL LETTER Y WITH ACUTE
+0xFE	0x0163	#LATIN SMALL LETTER T WITH CEDILLA
+0xFF	0x02D9	#DOT ABOVE

basis/listener/listener.factor

@@ -163,8 +163,10 @@ SYMBOL: interactive-vocabs
     "syntax"
     "tools.annotations"
     "tools.crossref"
+    "tools.deprecation"
     "tools.destructors"
     "tools.disassembler"
+    "tools.dispatch"
     "tools.errors"
     "tools.memory"
     "tools.profiler"

basis/math/vectors/simd/simd-tests.factor

@@ -582,3 +582,20 @@ STRUCT: simd-struct
     float-4{ 1.0 0.0 1.0 0.0 } pi [ broken 3array ]
     [ compile-call ] [ call ] 3bi =
 ] unit-test
+
+! Spilling SIMD values -- this basically just tests that the
+! stack was aligned properly by the runtime
+
+: simd-spill-test-1 ( a b c -- v )
+    { float-4 float-4 float } declare 
+    [ v+ ] dip sin v*n ;
+
+[ float-4{ 0 0 0 0 } ]
+[ float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-1 ] unit-test
+
+: simd-spill-test-2 ( a b d c -- v )
+    { float float-4 float-4 float } declare 
+    [ [ 3.0 + ] 2dip v+ ] dip sin v*n n*v ;
+
+[ float-4{ 0 0 0 0 } ]
+[ 5.0 float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-2 ] unit-test

basis/prettyprint/prettyprint.factor

@@ -110,3 +110,7 @@ SYMBOL: pprint-string-cells?
             ] with-row
         ] each
     ] tabular-output nl ;
+
+: object-table. ( obj alist -- )
+    [ [ nip first ] [ second call( obj -- str ) ] 2bi 2array ] with map
+    simple-table. ;

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

@@ -13,7 +13,7 @@ words.private definitions assocs summary compiler.units
 system.private combinators combinators.short-circuit locals
 locals.backend locals.types combinators.private
 stack-checker.values generic.single generic.single.private
-alien.libraries
+alien.libraries tools.dispatch.private tools.profiler.private
 stack-checker.alien
 stack-checker.state
 stack-checker.errors
@@ -501,16 +501,14 @@ M: bad-executable summary
 
 \ compact-gc { } { } define-primitive
 
-\ gc-stats { } { array } define-primitive
-
 \ (save-image) { byte-array } { } define-primitive
 
 \ (save-image-and-exit) { byte-array } { } define-primitive
 
-\ data-room { } { integer integer array } define-primitive
+\ data-room { } { byte-array } define-primitive
 \ data-room make-flushable
 
-\ code-room { } { integer integer integer integer } define-primitive
+\ code-room { } { byte-array } define-primitive
 \ code-room  make-flushable
 
 \ micros { } { integer } define-primitive
@@ -594,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
@@ -701,21 +699,20 @@ M: bad-executable summary
 
 \ unimplemented { } { } define-primitive
 
-\ gc-reset { } { } define-primitive
-
-\ gc-stats { } { array } define-primitive
-
 \ jit-compile { quotation } { } define-primitive
 
 \ lookup-method { object array } { word } define-primitive
 
 \ reset-dispatch-stats { } { } define-primitive
 \ dispatch-stats { } { array } define-primitive
-\ reset-inline-cache-stats { } { } define-primitive
-\ inline-cache-stats { } { array } define-primitive
 
 \ optimized? { word } { object } define-primitive
 
 \ strip-stack-traces { } { } define-primitive
 
 \ <callback> { word } { alien } define-primitive
+
+\ enable-gc-events { } { } define-primitive
+\ disable-gc-events { } { object } define-primitive
+
+\ profiling { object } { } define-primitive

basis/tools/dispatch/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/tools/dispatch/dispatch-docs.factor

@@ -0,0 +1,8 @@
+IN: tools.dispatch
+USING: help.markup help.syntax vm quotations ;
+
+HELP: last-dispatch-stats
+{ $var-description "A " { $link dispatch-statistics } " instance, set by " { $link collect-dispatch-stats } "." } ;
+
+HELP: dispatch-stats.
+{ $description "Prints method dispatch statistics from the last call to " { $link collect-dispatch-stats } "." } ;

basis/tools/dispatch/dispatch.factor

@@ -0,0 +1,24 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces prettyprint classes.struct
+vm tools.dispatch.private ;
+IN: tools.dispatch
+
+SYMBOL: last-dispatch-stats
+
+: dispatch-stats. ( -- )
+    last-dispatch-stats get {
+        { "Megamorphic hits" [ megamorphic-cache-hits>> ] }
+        { "Megamorphic misses" [ megamorphic-cache-misses>> ] }
+        { "Cold to monomorphic" [ cold-call-to-ic-transitions>> ] }
+        { "Mono to polymorphic" [ ic-to-pic-transitions>> ] }
+        { "Poly to megamorphic" [ pic-to-mega-transitions>> ] }
+        { "Tag check count" [ pic-tag-count>> ] }
+        { "Tuple check count" [ pic-tuple-count>> ] }
+    } object-table. ;
+
+: collect-dispatch-stats ( quot -- )
+    reset-dispatch-stats
+    call
+    dispatch-stats dispatch-statistics memory>struct
+    last-dispatch-stats set ; inline

basis/tools/memory/memory-docs.factor

@@ -1,4 +1,4 @@
-USING: help.markup help.syntax memory sequences ;
+USING: help.markup help.syntax memory sequences vm ;
 IN: tools.memory
 
 ARTICLE: "tools.memory" "Object memory tools"
@@ -39,3 +39,15 @@ HELP: heap-stats.
 { $description "For each class, prints the number of instances and total memory consumed by those instances." } ;
 
 { heap-stats heap-stats. } related-words
+
+HELP: gc-events.
+{ $description "Prints all garbage collection events that took place during the last call to " { $link collect-gc-events } "." } ;
+
+HELP: gc-stats.
+{ $description "Prints a breakdown of different garbage collection events that took place during the last call to " { $link collect-gc-events } "." } ;
+
+HELP: gc-summary.
+{ $description "Prints aggregate garbage collection statistics from the last call to " { $link collect-gc-events } "." } ;
+
+HELP: gc-events
+{ $var-description "A sequence of " { $link gc-event } " instances, set by " { $link collect-gc-events } ". Can be inspected directly, or with the " { $link gc-events. } ", " { $link gc-stats. } " and " { $link gc-summary. } " words." } ;

basis/tools/memory/memory-tests.factor

@@ -1,5 +1,9 @@
-USING: tools.test tools.memory ;
+USING: tools.test tools.memory memory ;
 IN: tools.memory.tests
 
 [ ] [ room. ] unit-test
 [ ] [ heap-stats. ] unit-test
+[ ] [ [ gc gc ] collect-gc-events ] unit-test
+[ ] [ gc-events. ] unit-test
+[ ] [ gc-stats. ] unit-test
+[ ] [ gc-summary. ] unit-test

basis/tools/memory/memory.factor

@@ -1,55 +1,78 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences arrays generic assocs io math
+USING: accessors arrays assocs classes classes.struct
-namespaces parser prettyprint strings io.styles words
+combinators combinators.smart continuations fry generalizations
-system sorting splitting grouping math.parser classes memory
+generic grouping io io.styles kernel make math math.parser
-combinators fry ;
+math.statistics memory namespaces parser prettyprint sequences
+sorting specialized-arrays splitting strings system vm words ;
+SPECIALIZED-ARRAY: gc-event
 IN: tools.memory
 
 <PRIVATE
 
-: write-size ( n -- )
+: commas ( n -- str )
+    dup 0 < [ neg commas "-" prepend ] [
         number>string
-    dup length 4 > [ 3 cut* "," glue ] when
+        reverse 3 group "," join reverse
-    " KB" append write-cell ;
+    ] if ;
 
-: write-total/used/free ( free total str -- )
+: kilobytes ( n -- str )
-    [
+    1024 /i commas " KB" append ;
-        write-cell
-        dup write-size
-        over - write-size
-        write-size
-    ] with-row ;
 
-: write-total ( n str -- )
+: micros>string ( n -- str )
-    [
+    commas " µs" append ;
-        write-cell
-        write-size
-        [ ] with-cell
-        [ ] with-cell
-    ] with-row ;
 
-: write-headings ( seq -- )
+: copying-room. ( copying-sizes -- )
-    [ [ write-cell ] each ] with-row ;
+    {
+        { "Size:" [ size>> kilobytes ] }
+        { "Occupied:" [ occupied>> kilobytes ] }
+        { "Free:" [ free>> kilobytes ] }
+    } object-table. ;
 
-: (data-room.) ( -- )
+: nursery-room. ( data-room -- )
-    data-room 2 <groups> [
+    "- Nursery space" print nursery>> copying-room. ;
-        [ first2 ] [ number>string "Generation " prepend ] bi*
-        write-total/used/free
-    ] each-index
-    "Decks" write-total
-    "Cards" write-total ;
 
-: write-labeled-size ( n string -- )
+: aging-room. ( data-room -- )
-    [ write-cell write-size ] with-row ;
+    "- Aging space" print aging>> copying-room. ;
 
-: (code-room.) ( -- )
+: mark-sweep-table. ( mark-sweep-sizes -- )
-    code-room {
+    {
-        [ "Size:" write-labeled-size ]
+        { "Size:" [ size>> kilobytes ] }
-        [ "Used:" write-labeled-size ]
+        { "Occupied:" [ occupied>> kilobytes ] }
-        [ "Total free space:" write-labeled-size ]
+        { "Total free:" [ total-free>> kilobytes ] }
-        [ "Largest free block:" write-labeled-size ]
+        { "Contiguous free:" [ contiguous-free>> kilobytes ] }
-    } spread ;
+        { "Free block count:" [ free-block-count>> number>string ] }
+    } object-table. ;
+
+: tenured-room. ( data-room -- )
+    "- Tenured space" print tenured>> mark-sweep-table. ;
+
+: misc-room. ( data-room -- )
+    "- Miscellaneous buffers" print
+    {
+        { "Card array:" [ cards>> kilobytes ] }
+        { "Deck array:" [ decks>> kilobytes ] }
+        { "Mark stack:" [ mark-stack>> kilobytes ] }
+    } object-table. ;
+
+: data-room. ( -- )
+    "== Data heap ==" print nl
+    data-room data-heap-room memory>struct {
+        [ nursery-room. nl ]
+        [ aging-room. nl ]
+        [ tenured-room. nl ]
+        [ misc-room. ]
+    } cleave ;
+
+: code-room. ( -- )
+    "== Code heap ==" print nl
+    code-room mark-sweep-sizes memory>struct mark-sweep-table. ;
+
+PRIVATE>
+
+: room. ( -- ) data-room. nl code-room. ;
+
+<PRIVATE
 
 : heap-stat-step ( obj counts sizes -- )
     [ [ class ] dip inc-at ]
@@ -57,26 +80,13 @@ IN: tools.memory
 
 PRIVATE>
 
-: room. ( -- )
-    "==== DATA HEAP" print
-    standard-table-style [
-        { "" "Total" "Used" "Free" } write-headings
-        (data-room.)
-    ] tabular-output
-    nl nl
-    "==== CODE HEAP" print
-    standard-table-style [
-        (code-room.)
-    ] tabular-output
-    nl ;
-
 : heap-stats ( -- counts sizes )
     [ ] instances H{ } clone H{ } clone
     [ '[ _ _ heap-stat-step ] each ] 2keep ;
 
 : heap-stats. ( -- )
     heap-stats dup keys natural-sort standard-table-style [
-        { "Class" "Bytes" "Instances" } write-headings
+        [ { "Class" "Bytes" "Instances" } [ write-cell ] each ] with-row
         [
             [
                 dup pprint-cell
@@ -85,3 +95,104 @@ PRIVATE>
             ] with-row
         ] each 2drop
     ] tabular-output nl ;
+
+SYMBOL: gc-events
+
+: collect-gc-events ( quot -- )
+    enable-gc-events
+    [ ] [ disable-gc-events drop ] cleanup
+    disable-gc-events byte-array>gc-event-array gc-events set ; inline
+
+<PRIVATE
+
+: gc-op-string ( op -- string )
+    {
+        { collect-nursery-op      [ "Copying from nursery" ] }
+        { collect-aging-op        [ "Copying from aging"   ] }
+        { collect-to-tenured-op   [ "Copying to tenured"   ] }
+        { collect-full-op         [ "Mark and sweep"       ] }
+        { collect-compact-op      [ "Mark and compact"     ] }
+        { collect-growing-heap-op [ "Grow heap"            ] }
+    } case ;
+
+: (space-occupied) ( data-heap-room code-heap-room -- n )
+    [
+        [ [ nursery>> ] [ aging>> ] [ tenured>> ] tri [ occupied>> ] tri@ ]
+        [ occupied>> ]
+        bi*
+    ] sum-outputs ;
+
+: space-occupied-before ( event -- bytes )
+    [ data-heap-before>> ] [ code-heap-before>> ] bi (space-occupied) ;
+
+: space-occupied-after ( event -- bytes )
+    [ data-heap-after>> ] [ code-heap-after>> ] bi (space-occupied) ;
+
+: space-reclaimed ( event -- bytes )
+    [ space-occupied-before ] [ space-occupied-after ] bi - ;
+
+TUPLE: gc-stats collections times ;
+
+: <gc-stats> ( -- stats )
+    gc-stats new
+        0 >>collections
+        V{ } clone >>times ; inline
+
+: compute-gc-stats ( events -- stats )
+    V{ } clone [
+        '[
+            dup op>> _ [ drop <gc-stats> ] cache
+            [ 1 + ] change-collections
+            [ total-time>> ] dip times>> push
+        ] each
+    ] keep sort-keys ;
+
+: gc-stats-table-row ( pair -- row )
+    [
+        [ first gc-op-string ] [
+            second
+            [ collections>> ]
+            [
+                times>> {
+                    [ sum micros>string ]
+                    [ mean >integer micros>string ]
+                    [ median >integer micros>string ]
+                    [ infimum micros>string ]
+                    [ supremum micros>string ]
+                } cleave
+            ] bi
+        ] bi
+    ] output>array ;
+
+: gc-stats-table ( stats -- table )
+    [ gc-stats-table-row ] map
+    { "" "Number" "Total" "Mean" "Median" "Min" "Max" } prefix ;
+
+PRIVATE>
+
+: gc-event. ( event -- )
+    {
+        { "Event type:" [ op>> gc-op-string ] }
+        { "Total time:" [ total-time>> micros>string ] }
+        { "Space reclaimed:" [ space-reclaimed kilobytes ] }
+    } object-table. ;
+
+: gc-events. ( -- )
+    gc-events get [ gc-event. nl ] each ;
+
+: gc-stats. ( -- )
+    gc-events get compute-gc-stats gc-stats-table simple-table. ;
+
+: gc-summary. ( -- )
+    gc-events get {
+        { "Collections:" [ length commas ] }
+        { "Cards scanned:" [ [ cards-scanned>> ] map-sum commas ] }
+        { "Decks scanned:" [ [ decks-scanned>> ] map-sum commas ] }
+        { "Code blocks scanned:" [ [ code-blocks-scanned>> ] map-sum commas ] }
+        { "Total time:" [ [ total-time>> ] map-sum micros>string ] }
+        { "Card scan time:" [ [ card-scan-time>> ] map-sum micros>string ] }
+        { "Code block scan time:" [ [ code-scan-time>> ] map-sum micros>string ] }
+        { "Data heap sweep time:" [ [ data-sweep-time>> ] map-sum micros>string ] }
+        { "Code heap sweep time:" [ [ code-sweep-time>> ] map-sum micros>string ] }
+        { "Compaction time:" [ [ compaction-time>> ] map-sum micros>string ] }
+    } object-table. ;

basis/tools/profiler/profiler-docs.factor

@@ -25,7 +25,7 @@ $nl
     method-profile.
     "profiler-limitations"
 }
-{ $see-also "ui.tools.profiler" } ;
+{ $see-also "ui.tools.profiler" "tools.annotations" "timing" } ;
 
 ABOUT: "profiling"
 

basis/tools/time/time-docs.factor

@@ -1,28 +1,38 @@
-USING: help.markup help.syntax memory system ;
+USING: help.markup help.syntax memory system tools.dispatch
+tools.memory quotations vm ;
 IN: tools.time
 
-ARTICLE: "timing" "Timing code"
+ARTICLE: "timing" "Timing code and collecting statistics"
 "You can time the execution of a quotation in the listener:"
 { $subsections time }
+"This word also collects statistics about method dispatch and garbage collection:"
+{ $subsections dispatch-stats. gc-events. gc-stats. gc-summary. }
 "A lower-level word puts timings on the stack, intead of printing:"
 { $subsections benchmark }
-"You can also read the system clock and garbage collection statistics directly:"
+"You can also read the system clock directly:"
-{ $subsections
+{ $subsections micros }
-    micros
+{ $see-also "profiling" "calendar" } ;
-    gc-stats
-}
-{ $see-also "profiling" } ;
 
 ABOUT: "timing"
 
 HELP: benchmark
-{ $values { "quot" "a quotation" }
+{ $values { "quot" quotation }
           { "runtime" "the runtime in microseconds" } }
       { $description "Runs a quotation, measuring the total wall clock time." }
 { $notes "A nicer word for interactive use is " { $link time } "." } ;
 
 HELP: time
-{ $values { "quot" "a quotation" } }
+{ $values { "quot" quotation } }
-{ $description "Runs a quotation and then prints the total run time and some garbage collection statistics." } ;
+{ $description "Runs a quotation, gathering statistics about method dispatch and garbage collection, and then prints the total run time." } ;
 
 { benchmark micros time } related-words
+
+HELP: collect-gc-events
+{ $values { "quot" quotation } }
+{ $description "Calls the quotation, storing an array of " { $link gc-event } " instances in the " { $link gc-events } " variable." }
+{ $notes "The " { $link time } " combinator automatically calls this combinator." } ;
+
+HELP: collect-dispatch-stats
+{ $values { "quot" quotation } }
+{ $description "Calls the quotation, collecting method dispatch statistics and storing them in the " { $link last-dispatch-stats } " variable. " }
+{ $notes "The " { $link time } " combinator automatically calls this combinator." } ;

basis/tools/time/time.factor

@@ -1,74 +1,22 @@
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math memory io io.styles prettyprint
+USING: system kernel math io prettyprint tools.memory
-namespaces system sequences splitting grouping assocs strings
+tools.dispatch ;
-generic.single combinators ;
 IN: tools.time
 
 : benchmark ( quot -- runtime )
     micros [ call micros ] dip - ; inline
 
 : time. ( time -- )
-    "== Running time ==" print nl 1000000 /f pprint " seconds" print ;
+    "Running time: " write 1000000 /f pprint " seconds" print ;
 
-: gc-stats. ( stats -- )
+: time-banner. ( -- )
-    5 cut*
+    "Additional information was collected." print
-    "== Garbage collection ==" print nl
+    "dispatch-stats.  - Print method dispatch statistics" print
-    "Times are in microseconds." print nl
+    "gc-events.       - Print all garbage collection events" print
-    [
+    "gc-stats.        - Print breakdown of different garbage collection events" print
-        6 group
+    "gc-summary.      - Print aggregate garbage collection statistics" print ;
-        {
-            "GC count:"
-            "Total GC time:"
-            "Longest GC pause:"
-            "Average GC pause:"
-            "Objects copied:"
-            "Bytes copied:"
-        } prefix
-        flip
-        { "" "Nursery" "Aging" "Tenured" } prefix
-        simple-table.
-    ]
-    [
-        nl
-        {
-            "Total GC time:"
-            "Cards scanned:"
-            "Decks scanned:"
-            "Card scan time:"
-            "Code heap literal scans:"
-        } swap zip simple-table.
-    ] bi* ;
-
-: dispatch-stats. ( stats -- )
-    "== Megamorphic caches ==" print nl
-    { "Hits" "Misses" } swap zip simple-table. ;
-
-: inline-cache-stats. ( stats -- )
-    nl "== Polymorphic inline caches ==" print nl
-    3 cut
-    [
-        "Transitions:" print
-        { "Cold to monomorphic" "Mono to polymorphic" "Poly to megamorphic" } swap zip
-        simple-table. nl
-    ] [
-        "Type check stubs:" print
-        { "Tag only" "Hi-tag" "Tuple" "Hi-tag and tuple" } swap zip
-        simple-table.
-    ] bi* ;
 
 : time ( quot -- )
-    gc-reset
+    [ [ benchmark ] collect-dispatch-stats ] collect-gc-events
-    reset-dispatch-stats
+    time. nl time-banner. ; inline
-    reset-inline-cache-stats
-    benchmark gc-stats dispatch-stats inline-cache-stats
-    H{ { table-gap { 20 20 } } } [
-        [
-            [ [ time. ] 3dip ] with-cell
-            [ ] with-cell
-        ] with-row
-        [
-            [ [ gc-stats. ] 2dip ] with-cell
-            [ [ dispatch-stats. ] [ inline-cache-stats. ] bi* ] with-cell
-        ] with-row
-    ] tabular-output nl ; inline

basis/vm/vm.factor

@@ -3,7 +3,7 @@
 USING: classes.struct alien.c-types alien.syntax ;
 IN: vm
 
-TYPEDEF: void* cell
+TYPEDEF: intptr_t cell
 C-TYPE: context
 
 STRUCT: zone
@@ -20,3 +20,60 @@ STRUCT: vm
 { userenv cell[70] } ;
 
 : vm-field-offset ( field -- offset ) vm offset-of ; inline
+
+C-ENUM:
+collect-nursery-op
+collect-aging-op
+collect-to-tenured-op
+collect-full-op
+collect-compact-op
+collect-growing-heap-op ;
+
+STRUCT: copying-sizes
+{ size cell }
+{ occupied cell }
+{ free cell } ;
+
+STRUCT: mark-sweep-sizes
+{ size cell }
+{ occupied cell }
+{ total-free cell }
+{ contiguous-free cell }
+{ free-block-count cell } ;
+
+STRUCT: data-heap-room
+{ nursery copying-sizes }
+{ aging copying-sizes }
+{ tenured mark-sweep-sizes }
+{ cards cell }
+{ decks cell }
+{ mark-stack cell } ;
+
+STRUCT: gc-event
+{ op uint }
+{ data-heap-before data-heap-room }
+{ code-heap-before mark-sweep-sizes }
+{ data-heap-after data-heap-room }
+{ code-heap-after mark-sweep-sizes }
+{ cards-scanned cell }
+{ decks-scanned cell }
+{ code-blocks-scanned cell }
+{ start-time ulonglong }
+{ total-time cell }
+{ card-scan-time cell }
+{ code-scan-time cell }
+{ data-sweep-time cell }
+{ code-sweep-time cell }
+{ compaction-time cell }
+{ temp-time cell } ;
+
+STRUCT: dispatch-statistics
+{ megamorphic-cache-hits cell }
+{ megamorphic-cache-misses cell }
+
+{ cold-call-to-ic-transitions cell }
+{ ic-to-pic-transitions cell }
+{ pic-to-mega-transitions cell }
+
+{ pic-tag-count cell }
+{ pic-tuple-count cell } ;

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
@@ -49,7 +39,8 @@ M: alien equal?
         2drop f
     ] if ;
 
-M: simple-alien hashcode* nip dup expired>> [ drop 1234 ] [ alien-address ] if ;
+M: pinned-alien hashcode*
+    nip dup expired>> [ drop 1234 ] [ alien-address ] if ;
 
 ERROR: alien-callback-error ;
 

core/bootstrap/layouts/layouts.factor

@@ -5,32 +5,28 @@ hashtables vectors strings sbufs arrays
 quotations assocs layouts classes.tuple.private
 kernel.private ;
 
-BIN: 111 tag-mask set
+16 data-alignment set
-8 num-tags set
-3 tag-bits set
 
-15 num-types set
+BIN: 1111 tag-mask set
+4 tag-bits set
+
+14 num-types set
 
 32 mega-cache-size set
 
 H{
-    { fixnum      BIN: 000 }
+    { fixnum 0 }
-    { bignum      BIN: 001 }
+    { POSTPONE: f 1 }
-    { array       BIN: 010 }
+    { array 2 }
-    { float       BIN: 011 }
+    { float 3 }
-    { quotation   BIN: 100 }
+    { quotation 4 }
-    { POSTPONE: f BIN: 101 }
+    { bignum 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

@@ -99,6 +99,7 @@ bootstrapping? on
     "system"
     "system.private"
     "threads.private"
+    "tools.dispatch.private"
     "tools.profiler.private"
     "words"
     "words.private"
@@ -177,10 +178,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 ]
@@ -423,7 +420,6 @@ tuple
     { "minor-gc" "memory" (( -- )) }
     { "gc" "memory" (( -- )) }
     { "compact-gc" "memory" (( -- )) }
-    { "gc-stats" "memory" f }
     { "(save-image)" "memory.private" (( path -- )) }
     { "(save-image-and-exit)" "memory.private" (( path -- )) }
     { "datastack" "kernel" (( -- ds )) }
@@ -433,8 +429,8 @@ tuple
     { "set-retainstack" "kernel" (( rs -- )) }
     { "set-callstack" "kernel" (( cs -- )) }
     { "exit" "system" (( n -- )) }
-    { "data-room" "memory" (( -- cards decks generations )) }
+    { "data-room" "memory" (( -- data-room )) }
-    { "code-room" "memory" (( -- code-total code-used code-free largest-free-block )) }
+    { "code-room" "memory" (( -- code-room )) }
     { "micros" "system" (( -- us )) }
     { "modify-code-heap" "compiler.units" (( alist -- )) }
     { "(dlopen)" "alien.libraries" (( path -- dll )) }
@@ -509,7 +505,6 @@ tuple
     { "resize-byte-array" "byte-arrays" (( n byte-array -- newbyte-array )) }
     { "dll-valid?" "alien.libraries" (( dll -- ? )) }
     { "unimplemented" "kernel.private" (( -- * )) }
-    { "gc-reset" "memory" (( -- )) }
     { "jit-compile" "quotations" (( quot -- )) }
     { "load-locals" "locals.backend" (( ... n -- )) }
     { "check-datastack" "kernel.private" (( array in# out# -- ? )) }
@@ -517,15 +512,15 @@ tuple
     { "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" "generic.single" (( -- )) }
+    { "reset-dispatch-stats" "tools.dispatch.private" (( -- )) }
-    { "dispatch-stats" "generic.single" (( -- stats )) }
+    { "dispatch-stats" "tools.dispatch.private" (( -- stats )) }
-    { "reset-inline-cache-stats" "generic.single" (( -- )) }
-    { "inline-cache-stats" "generic.single" (( -- stats )) }
     { "optimized?" "words" (( word -- ? )) }
     { "quot-compiled?" "quotations" (( quot -- ? )) }
     { "vm-ptr" "vm" (( -- ptr )) }
     { "strip-stack-traces" "kernel.private" (( -- )) }
     { "<callback>" "alien" (( word -- alien )) }
+    { "enable-gc-events" "memory" (( -- )) }
+    { "disable-gc-events" "memory" (( -- events )) }
 } [ [ first3 ] dip swap make-primitive ] each-index
 
 ! Bump build number

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

@@ -4,16 +4,14 @@ USING: namespaces math words kernel assocs classes
 math.order kernel.private ;
 IN: layouts
 
-SYMBOL: tag-mask
+SYMBOL: data-alignment
 
-SYMBOL: num-tags
+SYMBOL: tag-mask
 
 SYMBOL: tag-bits
 
 SYMBOL: num-types
 
-SYMBOL: tag-numbers
-
 SYMBOL: type-numbers
 
 SYMBOL: mega-cache-size
@@ -21,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 ;
 
@@ -58,7 +53,7 @@ SYMBOL: mega-cache-size
     first-bignum neg >fixnum ; inline
 
 : (max-array-capacity) ( b -- n )
-    5 - 2^ 1 - ; inline
+    6 - 2^ 1 - ; inline
 
 : max-array-capacity ( -- n )
     cell-bits (max-array-capacity) ; inline

core/slots/slots-docs.factor

@@ -71,7 +71,7 @@ $nl
     { { { $link float } } { $snippet "0.0" } }
     { { { $link string } } { $snippet "\"\"" } }
     { { { $link byte-array } } { $snippet "B{ }" } }
-    { { { $link simple-alien } } { $snippet "BAD-ALIEN" } }
+    { { { $link pinned-alien } } { $snippet "BAD-ALIEN" } }
 }
 "All other classes are handled with one of two cases:"
 { $list

core/slots/slots.factor

@@ -173,7 +173,7 @@ M: class initial-value* no-initial-value ;
         { [ string bootstrap-word over class<= ] [ "" ] }
         { [ array bootstrap-word over class<= ] [ { } ] }
         { [ byte-array bootstrap-word over class<= ] [ B{ } ] }
-        { [ simple-alien bootstrap-word over class<= ] [ <bad-alien> ] }
+        { [ pinned-alien bootstrap-word over class<= ] [ <bad-alien> ] }
         { [ quotation bootstrap-word over class<= ] [ [ ] ] }
         [ dup initial-value* ]
     } cond nip ;