Merge branch 'master' into startup

Conflicts: core/bootstrap/primitives.factor vm/run.hpp
2009-11-15 02:52:50 -06:00 · 2009-11-15 02:52:50 -06:00 · cc194416f9
parent b34bfe563e 6f38690050
commit cc194416f9
1229 changed files with 14931 additions and 8413 deletions
--- a/7
+++ b/7
@ -41,22 +41,25 @@ 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/data_heap_checker.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/objects.o \
 	vm/primitives.o \
 	vm/profiler.o \
 	vm/quotations.o \
--- a/basis/alarms/alarms-docs.factor
+++ b/basis/alarms/alarms-docs.factor
@ -1,16 +1,23 @@
-IN: alarms
 USING: help.markup help.syntax calendar quotations ;
+IN: alarms

 HELP: alarm
 { $class-description "An alarm. Can be passed to " { $link cancel-alarm } "." } ;

 HELP: add-alarm
 { $values { "quot" quotation } { "time" timestamp } { "frequency" { $maybe duration } } { "alarm" alarm } }
-{ $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ;
+{ $description "Creates and registers an alarm to start at " { $snippet "time" } ". If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ;

 HELP: later
 { $values { "quot" quotation } { "duration" duration } { "alarm" alarm } }
-{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } " from now." } ;
+{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } " from now." }
+{ $examples
+    { $unchecked-example
+        "USING: alarms io calendar ;"
+        """[ "GET BACK TO WORK, Guy." print flush ] 10 minutes later drop"""
+        ""
+    }
+} ;

 HELP: cancel-alarm
 { $values { "alarm" alarm } }
@ -20,16 +27,29 @@ HELP: every
 { $values
     { "quot" quotation } { "duration" duration }
     { "alarm" alarm } }
-{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency." } ;
+{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency." }
+{ $examples
+    { $unchecked-example
+        "USING: alarms io calendar ;"
+        """[ "Hi Buddy." print flush ] 10 seconds every drop"""
+        ""
+    }
+} ;

 ARTICLE: "alarms" "Alarms"
-"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks without spawning a new thread."
+"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks without spawning a new thread." $nl
+"The alarm class:"
 { $subsections
    alarm
-    add-alarm
-    later
-    cancel-alarm
 }
+"Register a recurring alarm:"
+{ $subsections every }
+"Register a one-time alarm:"
+{ $subsections later }
+"Low-level interface to add alarms:"
+{ $subsections add-alarm }
+"Cancelling an alarm:"
+{ $subsections cancel-alarm }
 "Alarms do not persist across image saves. Saving and restoring an image has the effect of calling " { $link cancel-alarm } " on all " { $link alarm } " instances." ;

 ABOUT: "alarms"
--- a/basis/alien/arrays/arrays.factor
+++ b/basis/alien/arrays/arrays.factor
@ -20,6 +20,8 @@ M: array heap-size unclip [ array-length ] [ heap-size ] bi* * ;

 M: array c-type-align first c-type-align ;

+M: array c-type-align-first first c-type-align-first ;
+
 M: array c-type-stack-align? drop f ;

 M: array unbox-parameter drop void* unbox-parameter ;
@ -55,6 +57,9 @@ M: string-type heap-size
 M: string-type c-type-align
    drop void* c-type-align ;

+M: string-type c-type-align-first
+    drop void* c-type-align-first ;
+
 M: string-type c-type-stack-align?
    drop void* c-type-stack-align? ;

@ -97,5 +102,5 @@ M: string-type c-type-setter
 { char* utf8 } char* typedef
 char* uchar* typedef

-char  char*  "pointer-c-type" set-word-prop
+char char* "pointer-c-type" set-word-prop
 uchar uchar* "pointer-c-type" set-word-prop
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@ -30,8 +30,9 @@ TUPLE: abstract-c-type
 { unboxer-quot callable }
 { getter callable }
 { setter callable }
-size
-align ;
+{ size integer }
+{ align integer }
+{ align-first integer } ;

 TUPLE: c-type < abstract-c-type
 boxer
@ -104,10 +105,9 @@ M: word c-type

 GENERIC: c-struct? ( c-type -- ? )

-M: object c-struct?
-    drop f ;
-M: c-type-name c-struct?
-    dup void? [ drop f ] [ c-type c-struct? ] if ;
+M: object c-struct? drop f ;
+
+M: c-type-name c-struct? dup void? [ drop f ] [ c-type c-struct? ] if ;

 ! These words being foldable means that words need to be
 ! recompiled if a C type is redefined. Even so, folding the
@ -172,6 +172,12 @@ M: abstract-c-type c-type-align align>> ;

 M: c-type-name c-type-align c-type c-type-align ;

+GENERIC: c-type-align-first ( name -- n )
+
+M: c-type-name c-type-align-first c-type c-type-align-first ;
+
+M: abstract-c-type c-type-align-first align-first>> ;
+
 GENERIC: c-type-stack-align? ( name -- ? )

 M: c-type c-type-stack-align? stack-align?>> ;
@ -230,6 +236,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 +266,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 +303,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 -- )
@ -319,6 +330,13 @@ SYMBOLS:
    ptrdiff_t intptr_t uintptr_t size_t
    char* uchar* ;

+: 8-byte-alignment ( c-type -- c-type )
+    {
+        { [ cpu ppc? os macosx? and ] [ 4 >>align 8 >>align-first ] }
+        { [ cpu x86.32? os windows? not and ] [ 4 >>align 4 >>align-first ] }
+        [ 8 >>align 8 >>align-first ]
+    } cond ;
+
 [
    <c-type>
        c-ptr >>class
@ -327,6 +345,7 @@ SYMBOLS:
        [ [ >c-ptr ] 2dip set-alien-cell ] >>setter
        bootstrap-cell >>size
        bootstrap-cell >>align
+        bootstrap-cell >>align-first
        [ >c-ptr ] >>unboxer-quot
        "box_alien" >>boxer
        "alien_offset" >>unboxer
@ -338,7 +357,7 @@ SYMBOLS:
        [ alien-signed-8 ] >>getter
        [ set-alien-signed-8 ] >>setter
        8 >>size
-        8 >>align
+        8-byte-alignment
        "box_signed_8" >>boxer
        "to_signed_8" >>unboxer
    \ longlong define-primitive-type
@ -349,7 +368,7 @@ SYMBOLS:
        [ alien-unsigned-8 ] >>getter
        [ set-alien-unsigned-8 ] >>setter
        8 >>size
-        8 >>align
+        8-byte-alignment
        "box_unsigned_8" >>boxer
        "to_unsigned_8" >>unboxer
    \ ulonglong define-primitive-type
@ -361,6 +380,7 @@ SYMBOLS:
        [ set-alien-signed-cell ] >>setter
        bootstrap-cell >>size
        bootstrap-cell >>align
+        bootstrap-cell >>align-first
        "box_signed_cell" >>boxer
        "to_fixnum" >>unboxer
    \ long define-primitive-type
@ -372,6 +392,7 @@ SYMBOLS:
        [ set-alien-unsigned-cell ] >>setter
        bootstrap-cell >>size
        bootstrap-cell >>align
+        bootstrap-cell >>align-first
        "box_unsigned_cell" >>boxer
        "to_cell" >>unboxer
    \ ulong define-primitive-type
@ -383,6 +404,7 @@ SYMBOLS:
        [ set-alien-signed-4 ] >>setter
        4 >>size
        4 >>align
+        4 >>align-first
        "box_signed_4" >>boxer
        "to_fixnum" >>unboxer
    \ int define-primitive-type
@ -394,6 +416,7 @@ SYMBOLS:
        [ set-alien-unsigned-4 ] >>setter
        4 >>size
        4 >>align
+        4 >>align-first
        "box_unsigned_4" >>boxer
        "to_cell" >>unboxer
    \ uint define-primitive-type
@ -405,6 +428,7 @@ SYMBOLS:
        [ set-alien-signed-2 ] >>setter
        2 >>size
        2 >>align
+        2 >>align-first
        "box_signed_2" >>boxer
        "to_fixnum" >>unboxer
    \ short define-primitive-type
@ -416,6 +440,7 @@ SYMBOLS:
        [ set-alien-unsigned-2 ] >>setter
        2 >>size
        2 >>align
+        2 >>align-first
        "box_unsigned_2" >>boxer
        "to_cell" >>unboxer
    \ ushort define-primitive-type
@ -427,6 +452,7 @@ SYMBOLS:
        [ set-alien-signed-1 ] >>setter
        1 >>size
        1 >>align
+        1 >>align-first
        "box_signed_1" >>boxer
        "to_fixnum" >>unboxer
    \ char define-primitive-type
@ -438,17 +464,30 @@ SYMBOLS:
        [ set-alien-unsigned-1 ] >>setter
        1 >>size
        1 >>align
+        1 >>align-first
        "box_unsigned_1" >>boxer
        "to_cell" >>unboxer
    \ uchar define-primitive-type

-    <c-type>
-        [ alien-unsigned-1 0 = not ] >>getter
-        [ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter
-        1 >>size
-        1 >>align
-        "box_boolean" >>boxer
-        "to_boolean" >>unboxer
+    cpu ppc? [
+        <c-type>
+            [ alien-unsigned-4 c-bool> ] >>getter
+            [ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
+            4 >>size
+            4 >>align
+            4 >>align-first
+            "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
+            1 >>align-first
+            "box_boolean" >>boxer
+            "to_boolean" >>unboxer
+    ] if
    \ bool define-primitive-type

    <c-type>
@ -458,6 +497,7 @@ SYMBOLS:
        [ [ >float ] 2dip set-alien-float ] >>setter
        4 >>size
        4 >>align
+        4 >>align-first
        "box_float" >>boxer
        "to_float" >>unboxer
        float-rep >>rep
@ -470,17 +510,24 @@ SYMBOLS:
        [ alien-double ] >>getter
        [ [ >float ] 2dip set-alien-double ] >>setter
        8 >>size
-        8 >>align
+        8-byte-alignment
        "box_double" >>boxer
        "to_double" >>unboxer
        double-rep >>rep
        [ >float ] >>unboxer-quot
    \ double define-primitive-type

-    \ long c-type \ ptrdiff_t typedef
-    \ long c-type \ intptr_t typedef
-    \ ulong c-type \ uintptr_t typedef
-    \ ulong c-type \ size_t typedef
+    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 ;
@ -501,9 +548,9 @@ M: double-2-rep rep-component-type drop double ;

 : c-type-interval ( c-type -- from to )
    {
-        { [ dup { float double } memq? ] [ drop -1/0. 1/0. ] }
-        { [ dup { char short int long longlong } memq? ] [ signed-interval ] }
-        { [ dup { uchar ushort uint ulong ulonglong } memq? ] [ unsigned-interval ] }
+        { [ dup { float double } member-eq? ] [ drop -1/0. 1/0. ] }
+        { [ dup { char short int long longlong } member-eq? ] [ signed-interval ] }
+        { [ dup { uchar ushort uint ulong ulonglong } member-eq? ] [ unsigned-interval ] }
    } cond ; foldable

 : c-type-clamp ( value c-type -- value' ) c-type-interval clamp ; inline
--- a/basis/alien/data/data.factor
+++ b/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 ] ;
-
-
--- a/basis/alien/fortran/fortran.factor
+++ b/basis/alien/fortran/fortran.factor
@ -205,9 +205,6 @@ M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ;
 M: real-type (fortran-ret-type>c-type)
    drop real-functions-return-double? [ "double" ] [ "float" ] if ;

-: suffix! ( seq   elt   -- seq   ) over push     ; inline
-: append! ( seq-a seq-b -- seq-a ) over push-all ; inline
-
 GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot )

 : args?dims ( type quot -- main-quot added-quot )
@ -333,7 +330,7 @@ M: character-type (<fortran-result>)
    ] if-empty ;

 :: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot ) 
-    return parameters fortran-sig>c-sig :> c-parameters :> c-return
+    return parameters fortran-sig>c-sig :> ( c-return c-parameters )
    function fortran-name>symbol-name :> c-function
    [args>args] 
    c-return library c-function c-parameters \ alien-invoke
--- a/basis/alien/parser/parser.factor
+++ b/basis/alien/parser/parser.factor
@ -98,7 +98,7 @@ IN: alien.parser
    type-name current-vocab create :> type-word 
    type-word [ reset-generic ] [ reset-c-type ] bi
    void* type-word typedef
-    parameters return parse-arglist :> callback-effect :> types
+    parameters return parse-arglist :> ( types callback-effect )
    type-word callback-effect "callback-effect" set-word-prop
    type-word lib "callback-library" set-word-prop
    type-word return types lib library-abi callback-quot (( quot -- alien )) ;
--- a/basis/alien/syntax/syntax.factor
+++ b/basis/alien/syntax/syntax.factor
@ -7,11 +7,11 @@ effects assocs combinators lexer strings.parser alien.parser
 fry vocabs.parser words.constant alien.libraries ;
 IN: alien.syntax

-SYNTAX: DLL" lexer get skip-blank parse-string dlopen parsed ;
+SYNTAX: DLL" lexer get skip-blank parse-string dlopen suffix! ;

-SYNTAX: ALIEN: 16 scan-base <alien> parsed ;
+SYNTAX: ALIEN: 16 scan-base <alien> suffix! ;

-SYNTAX: BAD-ALIEN <bad-alien> parsed ;
+SYNTAX: BAD-ALIEN <bad-alien> suffix! ;

 SYNTAX: LIBRARY: scan "c-library" set ;

@ -37,7 +37,7 @@ ERROR: no-such-symbol name library ;
    2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;

 SYNTAX: &:
-    scan "c-library" get '[ _ _ address-of ] over push-all ;
+    scan "c-library" get '[ _ _ address-of ] append! ;

 : global-quot ( type word -- quot )
    name>> "c-library" get '[ _ _ address-of 0 ]
--- a/basis/binary-search/binary-search-docs.factor
+++ b/basis/binary-search/binary-search-docs.factor
@ -25,11 +25,11 @@ HELP: sorted-member?

 { member? sorted-member? } related-words

-HELP: sorted-memq?
+HELP: sorted-member-eq?
 { $values { "obj" object } { "seq" "a sorted sequence" } { "?" "a boolean" } }
 { $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link eq? } "." } ;

-{ memq? sorted-memq? } related-words
+{ member-eq? sorted-member-eq? } related-words

 ARTICLE: "binary-search" "Binary search"
 "The " { $emphasis "binary search" } " algorithm allows elements to be located in sorted sequence in " { $snippet "O(log n)" } " time."
@ -38,7 +38,7 @@ ARTICLE: "binary-search" "Binary search"
 { $subsections
    sorted-index
    sorted-member?
-    sorted-memq?
+    sorted-member-eq?
 }
 { $see-also "order-specifiers" "sequences-sorting" } ;

--- a/basis/binary-search/binary-search.factor
+++ b/basis/binary-search/binary-search.factor
@ -49,5 +49,5 @@ HINTS: natural-search array ;
 : sorted-member? ( obj seq -- ? )
    dupd natural-search nip = ;

-: sorted-memq? ( obj seq -- ? )
+: sorted-member-eq? ( obj seq -- ? )
    dupd natural-search nip eq? ;
--- a/basis/bit-arrays/bit-arrays-docs.factor
+++ b/basis/bit-arrays/bit-arrays-docs.factor
@ -55,7 +55,7 @@ HELP: clear-bits
 { $values { "bit-array" bit-array } }
 { $description "Sets all elements of the bit array to " { $link f } "." }
 { $notes "Calling this word is more efficient than the following:"
-    { $code "[ drop f ] change-each" }
+    { $code "[ drop f ] map! drop" }
 }
 { $side-effects "bit-array" } ;

@ -63,7 +63,7 @@ HELP: set-bits
 { $values { "bit-array" bit-array } }
 { $description "Sets all elements of the bit array to " { $link t } "." }
 { $notes "Calling this word is more efficient than the following:"
-    { $code "[ drop t ] change-each" }
+    { $code "[ drop t ] map! drop" }
 }
 { $side-effects "bit-array" } ;

--- a/basis/bit-arrays/bit-arrays-tests.factor
+++ b/basis/bit-arrays/bit-arrays-tests.factor
@ -20,7 +20,7 @@ IN: bit-arrays.tests
 [
    { t f t } { f t f }
 ] [
-    { t f t } >bit-array dup clone dup [ not ] change-each
+    { t f t } >bit-array dup clone [ not ] map!
    [ >array ] bi@
 ] unit-test

--- a/basis/bitstreams/bitstreams.factor
+++ b/basis/bitstreams/bitstreams.factor
@ -113,7 +113,7 @@ PRIVATE>
 M:: lsb0-bit-writer poke ( value n bs -- )
    value n <widthed> :> widthed
    widthed
-    bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte
+    bs widthed>> #bits>> 8 swap - split-widthed :> ( byte remainder )
    byte bs widthed>> |widthed :> new-byte
    new-byte #bits>> 8 = [
        new-byte bits>> bs bytes>> push
@ -143,7 +143,7 @@ ERROR: not-enough-bits n bit-reader ;
    neg shift n bits ;

 :: adjust-bits ( n bs -- )
-    n 8 /mod :> #bits :> #bytes
+    n 8 /mod :> ( #bytes #bits )
    bs [ #bytes + ] change-byte-pos
    bit-pos>> #bits + dup 8 >= [
        8 - bs (>>bit-pos)
--- a/basis/bootstrap/compiler/compiler.factor
+++ b/basis/bootstrap/compiler/compiler.factor
@ -49,7 +49,7 @@ gc
    {
        not ?

-        2over roll -roll
+        2over

        array? hashtable? vector?
        tuple? sbuf? tombstone?
@ -94,7 +94,7 @@ gc
    "." write flush

    {
-        memq? split harvest sift cut cut-slice start index clone
+        member-eq? split harvest sift cut cut-slice start index clone
        set-at reverse push-all class number>string string>number
        like clone-like
    } compile-unoptimized
@ -118,4 +118,4 @@ gc

    " done" print flush

-] unless
+] unless
--- a/basis/bootstrap/image/image.factor
+++ b/basis/bootstrap/image/image.factor
@ -1,14 +1,16 @@
 ! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays byte-arrays generic hashtables hashtables.private
-io io.binary io.files io.encodings.binary io.pathnames kernel
-kernel.private math namespaces make parser prettyprint sequences
-strings sbufs vectors words quotations assocs system layouts splitting
-grouping growable classes classes.builtin classes.tuple
-classes.tuple.private vocabs vocabs.loader source-files definitions
-debugger quotations.private combinators math.order math.private
-accessors slots.private generic.single.private compiler.units
-compiler.constants fry bootstrap.image.syntax ;
+USING: alien arrays byte-arrays generic hashtables
+hashtables.private io io.binary io.files io.encodings.binary
+io.pathnames kernel kernel.private math namespaces make parser
+prettyprint sequences strings sbufs vectors words quotations
+assocs system layouts splitting grouping growable classes
+classes.builtin classes.tuple classes.tuple.private vocabs
+vocabs.loader source-files definitions debugger
+quotations.private combinators combinators.short-circuit
+math.order math.private accessors slots.private
+generic.single.private compiler.units compiler.constants fry
+bootstrap.image.syntax ;
 IN: bootstrap.image

 : arch ( os cpu -- arch )
@ -38,7 +40,7 @@ IN: bootstrap.image

 ! Object cache; we only consider numbers equal if they have the
 ! same type
-TUPLE: eql-wrapper obj ;
+TUPLE: eql-wrapper { obj read-only } ;

 C: <eql-wrapper> eql-wrapper

@ -47,31 +49,31 @@ M: eql-wrapper hashcode* obj>> hashcode* ;
 GENERIC: (eql?) ( obj1 obj2 -- ? )

 : eql? ( obj1 obj2 -- ? )
-    [ (eql?) ] [ [ class ] bi@ = ] 2bi and ;
+    { [ [ class ] bi@ = ] [ (eql?) ] } 2&& ;

-M: integer (eql?) = ;
+M: fixnum (eql?) eq? ;

-M: float (eql?)
-    over float? [ fp-bitwise= ] [ 2drop f ] if ;
+M: bignum (eql?) = ;

-M: sequence (eql?)
-    over sequence? [
-        2dup [ length ] bi@ =
-        [ [ eql? ] 2all? ] [ 2drop f ] if
-    ] [ 2drop f ] if ;
+M: float (eql?) fp-bitwise= ;
+
+M: sequence (eql?) 2dup [ length ] bi@ = [ [ eql? ] 2all? ] [ 2drop f ] if ;

 M: object (eql?) = ;

 M: eql-wrapper equal?
    over eql-wrapper? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;

-TUPLE: eq-wrapper obj ;
+TUPLE: eq-wrapper { obj read-only } ;

 C: <eq-wrapper> eq-wrapper

 M: eq-wrapper equal?
    over eq-wrapper? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;

+M: eq-wrapper hashcode*
+    nip obj>> identity-hashcode ;
+
 SYMBOL: objects

 : cache-eql-object ( obj quot -- value )
@ -177,14 +179,12 @@ USERENV: callback-stub 45
 ! PIC stubs
 USERENV: pic-load 47
 USERENV: pic-tag 48
-USERENV: pic-hi-tag 49
-USERENV: pic-tuple 50
-USERENV: pic-hi-tag-tuple 51
-USERENV: pic-check-tag 52
-USERENV: pic-check 53
-USERENV: pic-hit 54
-USERENV: pic-miss-word 55
-USERENV: pic-miss-tail-word 56
+USERENV: pic-tuple 49
+USERENV: pic-check-tag 50
+USERENV: pic-check-tuple 51
+USERENV: pic-hit 52
+USERENV: pic-miss-word 53
+USERENV: pic-miss-tail-word 54

 ! Megamorphic dispatch
 USERENV: mega-lookup 57
@ -218,13 +218,20 @@ 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-header ( n -- ) tag-header 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 emit-header call align-here ] dip ;
    inline

 ! Write an object to the image.
@ -232,7 +239,7 @@ GENERIC: ' ( obj -- ptr )

 ! Image header

-: emit-header ( -- )
+: emit-image-header ( -- )
    image-magic emit
    image-version emit
    data-base emit ! relocation base at end of header
@ -293,7 +300,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 ;

@ -305,7 +312,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 ;
@ -351,7 +358,7 @@ M: f '
    [ ] [ "Not in image: " word-error ] ?if ;

 : fixup-words ( -- )
-    image get [ dup word? [ fixup-word ] when ] change-each ;
+    image get [ dup word? [ fixup-word ] when ] map! drop ;

 M: word ' ;

@ -411,6 +418,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 ;
@ -515,7 +523,7 @@ M: quotation '
 : build-image ( -- image )
    800000 <vector> image set
    20000 <hashtable> objects set
-    emit-header t, 0, 1, -1,
+    emit-image-header t, 0, 1, -1,
    "Building generic words..." print flush
    remake-generics
    "Serializing words..." print flush
--- a/basis/bootstrap/stage2.factor
+++ b/basis/bootstrap/stage2.factor
@ -78,8 +78,6 @@ SYMBOL: bootstrap-time
        "stage2: deployment mode" print
    ] [
        "debugger" require
-        "inspector" require
-        "tools.errors" require
        "listener" require
        "none" require
    ] if
--- a/basis/bootstrap/tools/tools.factor
+++ b/basis/bootstrap/tools/tools.factor
@ -2,14 +2,17 @@ USING: vocabs.loader sequences ;
 IN: bootstrap.tools

 {
+    "editors"
    "inspector"
    "bootstrap.image"
+    "see"
    "tools.annotations"
    "tools.crossref"
    "tools.errors"
    "tools.deploy"
    "tools.destructors"
    "tools.disassembler"
+    "tools.dispatch"
    "tools.memory"
    "tools.profiler"
    "tools.test"
@ -19,5 +22,4 @@ IN: bootstrap.tools
    "vocabs.hierarchy"
    "vocabs.refresh"
    "vocabs.refresh.monitor"
-    "editors"
 } [ require ] each
--- a/basis/byte-arrays/hex/hex.factor
+++ b/basis/byte-arrays/hex/hex.factor
@ -7,4 +7,4 @@ SYNTAX: HEX{
    "}" parse-tokens "" join
    [ blank? not ] filter
    2 group [ hex> ] B{ } map-as
-    parsed ;
+    suffix! ;
--- a/basis/calendar/calendar-docs.factor
+++ b/basis/calendar/calendar-docs.factor
@ -32,7 +32,7 @@ HELP: month-names
 { $warning "Do not use this array for looking up a month name directly. Use month-name instead." } ;

 HELP: month-name
-{ $values { "n" integer } { "string" string } }
+{ $values { "obj" { $or integer timestamp } } { "string" string } }
 { $description "Looks up the month name and returns it as a string.  January has an index of 1 instead of zero." } ;

 HELP: month-abbreviations
@ -46,11 +46,11 @@ HELP: month-abbreviation


 HELP: day-names
-{ $values { "array" array } }
+{ $values { "value" array } }
 { $description "Returns an array with the English names of the days of the week." } ;

 HELP: day-name
-{ $values { "n" integer } { "string" string } }
+{ $values { "obj" { $or integer timestamp } } { "string" string } }
 { $description "Looks up the day name and returns it as a string." } ;

 HELP: day-abbreviations2
--- a/basis/calendar/calendar-tests.factor
+++ b/basis/calendar/calendar-tests.factor
@ -170,3 +170,8 @@ IN: calendar.tests
 [ f ] [ now dup midnight eq? ] unit-test
 [ f ] [ now dup easter eq? ] unit-test
 [ f ] [ now dup beginning-of-year eq? ] unit-test
+
+[ t ] [ 1325376000 unix-time>timestamp 2012 <year-gmt> = ] unit-test
+[ t ] [ 1356998399 unix-time>timestamp 2013 <year-gmt> 1 seconds time- = ] unit-test
+
+[ t ] [ 1500000000 random [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test
--- a/basis/calendar/calendar.factor
+++ b/basis/calendar/calendar.factor
@ -17,6 +17,8 @@ TUPLE: duration

 C: <duration> duration

+: instant ( -- duration ) 0 0 0 0 0 0 <duration> ;
+
 TUPLE: timestamp
    { year integer }
    { month integer }
@ -34,6 +36,15 @@ C: <timestamp> timestamp
 : <date> ( year month day -- timestamp )
    0 0 0 gmt-offset-duration <timestamp> ;

+: <date-gmt> ( year month day -- timestamp )
+    0 0 0 instant <timestamp> ;
+
+: <year> ( year -- timestamp )
+    1 1 <date> ;
+
+: <year-gmt> ( year -- timestamp )
+    1 1 <date-gmt> ;
+
 ERROR: not-a-month ;
 M: not-a-month summary
    drop "Months are indexed starting at 1" ;
@ -51,8 +62,16 @@ CONSTANT: month-names
        "July" "August" "September" "October" "November" "December"
    }

-: month-name ( n -- string )
-    check-month 1 - month-names nth ;
+<PRIVATE
+
+: (month-name) ( n -- string ) 1 - month-names nth ;
+
+PRIVATE>
+
+GENERIC: month-name ( obj -- string )
+
+M: integer month-name check-month 1 - month-names nth ;
+M: timestamp month-name month>> 1 - month-names nth ;

 CONSTANT: month-abbreviations
    {
@ -65,12 +84,8 @@ CONSTANT: month-abbreviations

 CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }

-: day-names ( -- array )
-    {
-        "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"
-    } ;
-
-: day-name ( n -- string ) day-names nth ;
+CONSTANT: day-names
+    { "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" }

 CONSTANT: day-abbreviations2
    { "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" }
@ -119,16 +134,16 @@ GENERIC: easter ( obj -- obj' )

 :: easter-month-day ( year -- month day )
    year 19 mod :> a
-    year 100 /mod :> c :> b
-    b 4 /mod :> e :> d
+    year 100 /mod :> ( b c )
+    b 4 /mod :> ( d e )
    b 8 + 25 /i :> f
    b f - 1 + 3 /i :> g
    19 a * b + d - g - 15 + 30 mod :> h
-    c 4 /mod :> k :> i
+    c 4 /mod :> ( i k )
    32 2 e * + 2 i * + h - k - 7 mod :> l
    a 11 h * + 22 l * + 451 /i :> m

-    h l + 7 m * - 114 + 31 /mod 1 + :> day :> month
+    h l + 7 m * - 114 + 31 /mod 1 + :> ( month day )
    month day ;

 M: integer easter ( year -- timestamp )
@ -145,7 +160,6 @@ M: timestamp easter ( timestamp -- timestamp )
 : >time< ( timestamp -- hour minute second )
    [ hour>> ] [ minute>> ] [ second>> ] tri ;

-: instant ( -- duration ) 0 0 0 0 0 0 <duration> ;
 : years ( x -- duration ) instant clone swap >>year ;
 : months ( x -- duration ) instant clone swap >>month ;
 : days ( x -- duration ) instant clone swap >>day ;
@ -157,6 +171,18 @@ M: timestamp easter ( timestamp -- timestamp )
 : microseconds ( x -- duration ) 1000000 / seconds ;
 : nanoseconds ( x -- duration ) 1000000000 / seconds ;

+GENERIC: year ( obj -- n )
+M: integer year ;
+M: timestamp year year>> ;
+
+GENERIC: month ( obj -- n )
+M: integer month ;
+M: timestamp month month>> ;
+
+GENERIC: day ( obj -- n )
+M: integer day ;
+M: timestamp day day>> ;
+
 GENERIC: leap-year? ( obj -- ? )

 M: integer leap-year? ( year -- ? )
@ -305,6 +331,9 @@ GENERIC: time- ( time1 time2 -- time3 )
 M: timestamp <=> ( ts1 ts2 -- n )
    [ >gmt tuple-slots ] compare ;

+: same-day? ( ts1 ts2 -- ? )
+    [ >gmt >date< <date> ] bi@ = ;
+
 : (time-) ( timestamp timestamp -- n )
    [ >gmt ] bi@
    [ [ >date< julian-day-number ] bi@ - 86400 * ] 2keep
@ -387,6 +416,10 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
 : day-of-week ( timestamp -- n )
    >date< zeller-congruence ;

+GENERIC: day-name ( obj -- string )
+M: integer day-name day-names nth ;
+M: timestamp day-name day-of-week day-names nth ;
+
 :: (day-of-year) ( year month day -- n )
    day-counts month head-slice sum day +
    year leap-year? [
@ -398,22 +431,6 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
 : day-of-year ( timestamp -- n )
    >date< (day-of-year) ;

-<PRIVATE
-: day-offset ( timestamp m -- timestamp n )
-    over day-of-week - ; inline
-
-: day-this-week ( timestamp n -- timestamp )
-    day-offset days time+ ;
-PRIVATE>
-
-: sunday ( timestamp -- new-timestamp ) 0 day-this-week ;
-: monday ( timestamp -- new-timestamp ) 1 day-this-week ;
-: tuesday ( timestamp -- new-timestamp ) 2 day-this-week ;
-: wednesday ( timestamp -- new-timestamp ) 3 day-this-week ;
-: thursday ( timestamp -- new-timestamp ) 4 day-this-week ;
-: friday ( timestamp -- new-timestamp ) 5 day-this-week ;
-: saturday ( timestamp -- new-timestamp ) 6 day-this-week ;
-
 : midnight ( timestamp -- new-timestamp )
    clone 0 >>hour 0 >>minute 0 >>second ; inline

@ -423,11 +440,108 @@ PRIVATE>
 : beginning-of-month ( timestamp -- new-timestamp )
    midnight 1 >>day ;

+: end-of-month ( timestamp -- new-timestamp )
+    [ midnight ] [ days-in-month ] bi >>day ;
+
+<PRIVATE
+
+: day-offset ( timestamp m -- new-timestamp n )
+    over day-of-week - ; inline
+
+: day-this-week ( timestamp n -- new-timestamp )
+    day-offset days time+ ;
+
+:: nth-day-this-month ( timestamp n day -- new-timestamp )
+    timestamp beginning-of-month day day-this-week
+    dup timestamp [ month>> ] bi@ = [ 1 weeks time+ ] unless
+    n 1 - [ weeks time+ ] unless-zero ;
+
+: last-day-this-month ( timestamp day -- new-timestamp )
+    [ 1 months time+ 1 ] dip nth-day-this-month 1 weeks time- ;
+
+PRIVATE>
+
+GENERIC: january ( obj -- timestamp )
+GENERIC: february ( obj -- timestamp )
+GENERIC: march ( obj -- timestamp )
+GENERIC: april ( obj -- timestamp )
+GENERIC: may ( obj -- timestamp )
+GENERIC: june ( obj -- timestamp )
+GENERIC: july ( obj -- timestamp )
+GENERIC: august ( obj -- timestamp )
+GENERIC: september ( obj -- timestamp )
+GENERIC: october ( obj -- timestamp )
+GENERIC: november ( obj -- timestamp )
+GENERIC: december ( obj -- timestamp )
+
+M: integer january 1 1 <date> ;
+M: integer february 2 1 <date> ;
+M: integer march 3 1 <date> ;
+M: integer april 4 1 <date> ;
+M: integer may 5 1 <date> ;
+M: integer june 6 1 <date> ;
+M: integer july 7 1 <date> ;
+M: integer august 8 1 <date> ;
+M: integer september 9 1 <date> ;
+M: integer october 10 1 <date> ;
+M: integer november 11 1 <date> ;
+M: integer december 12 1 <date> ;
+
+M: timestamp january clone 1 >>month ;
+M: timestamp february clone 2 >>month ;
+M: timestamp march clone 3 >>month ;
+M: timestamp april clone 4 >>month ;
+M: timestamp may clone 5 >>month ;
+M: timestamp june clone 6 >>month ;
+M: timestamp july clone 7 >>month ;
+M: timestamp august clone 8 >>month ;
+M: timestamp september clone 9 >>month ;
+M: timestamp october clone 10 >>month ;
+M: timestamp november clone 11 >>month ;
+M: timestamp december clone 12 >>month ;
+
+: sunday ( timestamp -- new-timestamp ) 0 day-this-week ;
+: monday ( timestamp -- new-timestamp ) 1 day-this-week ;
+: tuesday ( timestamp -- new-timestamp ) 2 day-this-week ;
+: wednesday ( timestamp -- new-timestamp ) 3 day-this-week ;
+: thursday ( timestamp -- new-timestamp ) 4 day-this-week ;
+: friday ( timestamp -- new-timestamp ) 5 day-this-week ;
+: saturday ( timestamp -- new-timestamp ) 6 day-this-week ;
+
+: sunday? ( timestamp -- ? ) day-of-week 0 = ;
+: monday? ( timestamp -- ? ) day-of-week 1 = ;
+: tuesday? ( timestamp -- ? ) day-of-week 2 = ;
+: wednesday? ( timestamp -- ? ) day-of-week 3 = ;
+: thursday? ( timestamp -- ? ) day-of-week 4 = ;
+: friday? ( timestamp -- ? ) day-of-week 5 = ;
+: saturday? ( timestamp -- ? ) day-of-week 6 = ;
+
+: sunday-of-month ( timestamp n -- new-timestamp ) 0 nth-day-this-month ;
+: monday-of-month ( timestamp n -- new-timestamp ) 1 nth-day-this-month ;
+: tuesday-of-month ( timestamp n -- new-timestamp ) 2 nth-day-this-month ;
+: wednesday-of-month ( timestamp n -- new-timestamp ) 3 nth-day-this-month ;
+: thursday-of-month ( timestamp n -- new-timestamp ) 4 nth-day-this-month ;
+: friday-of-month ( timestamp n -- new-timestamp ) 5 nth-day-this-month ;
+: saturday-of-month ( timestamp n -- new-timestamp ) 6 nth-day-this-month ;
+
+: last-sunday-of-month ( timestamp -- new-timestamp ) 0 last-day-this-month ;
+: last-monday-of-month ( timestamp -- new-timestamp ) 1 last-day-this-month ;
+: last-tuesday-of-month ( timestamp -- new-timestamp ) 2 last-day-this-month ;
+: last-wednesday-of-month ( timestamp -- new-timestamp ) 3 last-day-this-month ;
+: last-thursday-of-month ( timestamp -- new-timestamp ) 4 last-day-this-month ;
+: last-friday-of-month ( timestamp -- new-timestamp ) 5 last-day-this-month ;
+: last-saturday-of-month ( timestamp -- new-timestamp ) 6 last-day-this-month ;
+
 : beginning-of-week ( timestamp -- new-timestamp )
    midnight sunday ;

-: beginning-of-year ( timestamp -- new-timestamp )
-    beginning-of-month 1 >>month ;
+GENERIC: beginning-of-year ( object -- new-timestamp )
+M: timestamp beginning-of-year beginning-of-month 1 >>month ;
+M: integer beginning-of-year <year> ;
+
+GENERIC: end-of-year ( object -- new-timestamp )
+M: timestamp end-of-year 12 >>month 31 >>day ;
+M: integer end-of-year 12 31 <date> ;

 : time-since-midnight ( timestamp -- duration )
    dup midnight time- ;
@ -435,6 +549,12 @@ PRIVATE>
 : since-1970 ( duration -- timestamp )
    unix-1970 time+ >local-time ;

+: timestamp>unix-time ( timestamp -- seconds )
+    unix-1970 time- second>> ;
+
+: unix-time>timestamp ( seconds -- timestamp )
+    seconds unix-1970 time+ ;
+
 M: timestamp sleep-until timestamp>micros sleep-until ;

 M: duration sleep hence sleep-until ;
--- a/basis/calendar/unix/unix.factor
+++ b/basis/calendar/unix/unix.factor
@ -14,6 +14,9 @@ IN: calendar.unix
 : timespec>seconds ( timespec -- seconds )
    [ sec>> seconds ] [ nsec>> nanoseconds ] bi time+ ;

+: timespec>nanoseconds ( timespec -- seconds )
+    [ sec>> 1000000000 * ] [ nsec>> ] bi + ;
+
 : timespec>unix-time ( timespec -- timestamp )
    timespec>seconds since-1970 ;

--- a/basis/channels/examples/examples.factor
+++ b/basis/channels/examples/examples.factor
@ -25,12 +25,11 @@ IN: channels.examples
    ] 3keep filter ;

 :: (sieve) ( prime c -- )
-    [let | p [ c from ] 
-           newc [ <channel> ] |
-        p prime to
-        [ newc p c filter ] "Filter" spawn drop
-        prime newc (sieve)
-    ] ;
+    c from :> p
+    <channel> :> newc
+    p prime to
+    [ newc p c filter ] "Filter" spawn drop
+    prime newc (sieve) ;

 : sieve ( prime -- ) 
    #! Send prime numbers to 'prime' channel
--- a/basis/channels/remote/remote-docs.factor
+++ b/basis/channels/remote/remote-docs.factor
@ -53,11 +53,11 @@ $nl
 " to be accessed remotely. " { $link publish } " returns an id which a remote node "
 "needs to know to access the channel."
 $nl
-{ $snippet "channel [ from . ] spawn drop dup publish" }
+{ $snippet "<channel> dup [ from . flush ] curry \"test\" spawn drop publish" }
 $nl
-"Given the id from the snippet above, a remote node can put items in the channel."
+"Given the id from the snippet above, a remote node can put items in the channel (where 123456 is the id):"
 $nl
-{ $snippet "\"myhost.com\" 9001 <node> \"ID123456\" <remote-channel>\n\"hello\" over to" } 
+{ $snippet "\"myhost.com\" 9001 <node> 123456 <remote-channel>\n\"hello\" over to" } 
 ;

 ABOUT: { "remote-channels" "remote-channels" }
--- a/basis/channels/remote/remote.factor
+++ b/basis/channels/remote/remote.factor
@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 !
 ! Remote Channels
-USING: kernel init namespaces make assocs arrays random
+USING: kernel init namespaces assocs arrays random
 sequences channels match concurrency.messaging
 concurrency.distributed threads accessors ;
 IN: channels.remote
@ -27,39 +27,44 @@ PRIVATE>
 MATCH-VARS: ?from ?tag ?id ?value ;

 SYMBOL: no-channel
+TUPLE: to-message id value ;
+TUPLE: from-message id ;

-: channel-process ( -- )
+: channel-thread ( -- )
    [
        {
-            { { to ?id ?value  }
+            { T{ to-message f ?id ?value  }
            [ ?value ?id get-channel dup [ to f ] [ 2drop no-channel ] if ] }
-            { { from ?id }
+            { T{ from-message f ?id }
            [ ?id get-channel [ from ] [ no-channel ] if* ] }
        } match-cond
    ] handle-synchronous ;

-PRIVATE>
-
 : start-channel-node ( -- )
-    "remote-channels" get-process [
-        "remote-channels" 
-        [ channel-process t ] "Remote channels" spawn-server
-        register-process 
+    "remote-channels" get-remote-thread [
+        [ channel-thread t ] "Remote channels" spawn-server
+        "remote-channels" register-remote-thread 
    ] unless ;

+PRIVATE>
+
 TUPLE: remote-channel node id ;

 C: <remote-channel> remote-channel 

+<PRIVATE
+
+: send-message ( message remote-channel -- value )
+    node>> "remote-channels" <remote-thread> 
+    send-synchronous dup no-channel = [ no-channel throw ] when* ;
+    
+PRIVATE>
+
 M: remote-channel to ( value remote-channel -- )
-    [ [ \ to , id>> , , ] { } make ] keep
-    node>> "remote-channels" <remote-process> 
-    send-synchronous no-channel = [ no-channel throw ] when ;
+    [ id>> swap to-message boa ] keep send-message drop ;

 M: remote-channel from ( remote-channel -- value )
-    [ [ \ from , id>> , ] { } make ] keep
-    node>> "remote-channels" <remote-process> 
-    send-synchronous dup no-channel = [ no-channel throw ] when* ;
+    [ id>> from-message boa ] keep send-message ;

 [
    H{ } clone \ remote-channels set-global
--- a/basis/checksums/hmac/hmac.factor
+++ b/basis/checksums/hmac/hmac.factor
@ -24,7 +24,7 @@ PRIVATE>

 :: hmac-stream ( stream key checksum -- value )
    checksum initialize-checksum-state :> checksum-state
-    checksum key checksum-state init-key :> Ki :> Ko
+    checksum key checksum-state init-key :> ( Ko Ki )
    checksum-state Ki add-checksum-bytes
    stream add-checksum-stream get-checksum
    checksum initialize-checksum-state
--- a/basis/circular/circular.factor
+++ b/basis/circular/circular.factor
@ -21,7 +21,7 @@ M: circular length seq>> length ;

 M: circular virtual@ circular-wrap seq>> ;

-M: circular virtual-seq seq>> ;
+M: circular virtual-exemplar seq>> ;

 : change-circular-start ( n circular -- )
    #! change start to (start + n) mod length
--- a/basis/classes/struct/bit-accessors/bit-accessors.factor
+++ b/basis/classes/struct/bit-accessors/bit-accessors.factor
@ -10,7 +10,7 @@ IN: classes.struct.bit-accessors
    [ 2^ 1 - ] bi@ swap bitnot bitand ;

 :: manipulate-bits ( offset bits step-quot -- quot shift-amount offset' bits' )
-    offset 8 /mod :> start-bit :> i
+    offset 8 /mod :> ( i start-bit )
    start-bit bits + 8 min :> end-bit
    start-bit end-bit ones-between :> mask
    end-bit start-bit - :> used-bits
--- a/basis/classes/struct/struct-tests.factor
+++ b/basis/classes/struct/struct-tests.factor
@ -365,3 +365,18 @@ STRUCT: bit-field-test
 [ -2 ] [ bit-field-test <struct> 2 >>b b>> ] unit-test
 [ 1 ] [ bit-field-test <struct> 257 >>c c>> ] unit-test
 [ 3 ] [ bit-field-test heap-size ] unit-test
+
+cpu ppc? [
+    STRUCT: ppc-align-test-1
+        { x longlong }
+        { y int } ;
+
+    [ 16 ] [ ppc-align-test-1 heap-size ] unit-test
+
+    STRUCT: ppc-align-test-2
+        { y int }
+        { x longlong } ;
+
+    [ 12 ] [ ppc-align-test-2 heap-size ] unit-test
+    [ 4 ] [ "x" ppc-align-test-2 offset-of ] unit-test
+] when
--- a/basis/classes/struct/struct.factor
+++ b/basis/classes/struct/struct.factor
@ -211,27 +211,32 @@ M: struct-c-type c-struct? drop t ;
        slots >>fields
        size >>size
        align >>align
+        align >>align-first
        class (unboxer-quot) >>unboxer-quot
-        class (boxer-quot)   >>boxer-quot ;
-    
-GENERIC: align-offset ( offset class -- offset' )
+        class (boxer-quot) >>boxer-quot ;

-M: struct-slot-spec align-offset
-    [ type>> c-type-align 8 * align ] keep
+GENERIC: compute-slot-offset ( offset class -- offset' )
+
+: c-type-align-at ( class offset -- n )
+    0 = [ c-type-align-first ] [ c-type-align ] if ;
+
+M: struct-slot-spec compute-slot-offset
+    [ type>> over c-type-align-at 8 * align ] keep
    [ [ 8 /i ] dip (>>offset) ] [ type>> heap-size 8 * + ] 2bi ;

-M: struct-bit-slot-spec align-offset
+M: struct-bit-slot-spec compute-slot-offset
    [ (>>offset) ] [ bits>> + ] 2bi ;

-: struct-offsets ( slots -- size )
-    0 [ align-offset ] reduce 8 align 8 /i ;
+: compute-struct-offsets ( slots -- size )
+    0 [ compute-slot-offset ] reduce 8 align 8 /i ;

-: union-struct-offsets ( slots -- size )
+: compute-union-offsets ( slots -- size )
    1 [ 0 >>offset type>> heap-size max ] reduce ;

-: struct-align ( slots -- align )
+: struct-alignment ( slots -- align )
    [ struct-bit-slot-spec? not ] filter
-    1 [ type>> c-type-align max ] reduce ;
+    1 [ [ type>> ] [ offset>> ] bi c-type-align-at max ] reduce ;
+
 PRIVATE>

 M: struct byte-length class "struct-size" word-prop ; foldable
@ -243,10 +248,8 @@ GENERIC: binary-zero? ( value -- ? )

 M: object binary-zero? drop f ;
 M: f binary-zero? drop t ;
-M: number binary-zero? zero? ;
-M: struct binary-zero?
-    [ byte-length iota ] [ >c-ptr ] bi
-    [ <displaced-alien> *uchar zero? ] curry all? ;
+M: number binary-zero? 0 = ;
+M: struct binary-zero? >c-ptr [ 0 = ] all? ;

 : struct-needs-prototype? ( class -- ? )
    struct-slots [ initial>> binary-zero? ] all? not ;
@ -278,7 +281,7 @@ M: struct binary-zero?
    slots empty? [ struct-must-have-slots ] when
    class redefine-struct-tuple-class
    slots make-slots dup check-struct-slots :> slot-specs
-    slot-specs struct-align :> alignment
+    slot-specs struct-alignment :> alignment
    slot-specs offsets-quot call alignment align :> size

    class  slot-specs  size  alignment  c-type-for-class :> c-type
@ -291,10 +294,10 @@ M: struct binary-zero?
 PRIVATE>

 : define-struct-class ( class slots -- )
-    [ struct-offsets ] (define-struct-class) ;
+    [ compute-struct-offsets ] (define-struct-class) ;

 : define-union-struct-class ( class slots -- )
-    [ union-struct-offsets ] (define-struct-class) ;
+    [ compute-union-offsets ] (define-struct-class) ;

 M: struct-class reset-class
    [ call-next-method ] [ name>> c-types get delete-at ] bi ;
@ -350,7 +353,7 @@ PRIVATE>
 : parse-struct-slots ( slots -- slots' more? )
    scan {
        { ";" [ f ] }
-        { "{" [ parse-struct-slot over push t ] }
+        { "{" [ parse-struct-slot suffix! t ] }
        { f [ unexpected-eof ] }
        [ invalid-struct-slot ]
    } case ;
@ -365,10 +368,10 @@ SYNTAX: UNION-STRUCT:
    parse-struct-definition define-union-struct-class ;

 SYNTAX: S{
-    scan-word dup struct-slots parse-tuple-literal-slots parsed ;
+    scan-word dup struct-slots parse-tuple-literal-slots suffix! ;

 SYNTAX: S@
-    scan-word scan-object swap memory>struct parsed ;
+    scan-word scan-object swap memory>struct suffix! ;

 ! functor support

@ -378,7 +381,7 @@ SYNTAX: S@

 : parse-struct-slot` ( accum -- accum )
    scan-string-param scan-c-type` \ } parse-until
-    [ <struct-slot-spec> over push ] 3curry over push-all ;
+    [ <struct-slot-spec> suffix! ] 3curry append! ;

 : parse-struct-slots` ( accum -- accum more? )
    scan {
@ -389,10 +392,10 @@ SYNTAX: S@
 PRIVATE>

 FUNCTOR-SYNTAX: STRUCT:
-    scan-param parsed
-    [ 8 <vector> ] over push-all
+    scan-param suffix!
+    [ 8 <vector> ] append!
    [ parse-struct-slots` ] [ ] while
-    [ >array define-struct-class ] over push-all ;
+    [ >array define-struct-class ] append! ;

 USING: vocabs vocabs.loader ;

--- a/basis/cocoa/callbacks/callbacks.factor
+++ b/basis/cocoa/callbacks/callbacks.factor
@ -16,11 +16,11 @@ CLASS: {
    { +superclass+ "NSObject" }
 }

-{ "perform:" "void" { "id" "SEL" "id" }
+{ "perform:" void { id SEL id }
    [ 2drop callbacks get at try ]
 }

-{ "dealloc" "void" { "id" "SEL" }
+{ "dealloc" void { id SEL }
    [
        drop
        dup callbacks get delete-at
--- a/basis/cocoa/cocoa-tests.factor
+++ b/basis/cocoa/cocoa-tests.factor
@ -1,6 +1,7 @@
 USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
-compiler kernel namespaces cocoa.classes tools.test memory
-compiler.units math core-graphics.types ;
+compiler kernel namespaces cocoa.classes cocoa.runtime
+tools.test memory compiler.units math core-graphics.types ;
+FROM: alien.c-types => int void ;
 IN: cocoa.tests

 CLASS: {
@ -8,8 +9,8 @@ CLASS: {
    { +name+ "Foo" }
 } {
    "foo:"
-    "void"
-    { "id" "SEL" "NSRect" }
+    void
+    { id SEL NSRect }
    [ gc "x" set 2drop ]
 } ;

@ -30,8 +31,8 @@ CLASS: {
    { +name+ "Bar" }
 } {
    "bar"
-    "NSRect"
-    { "id" "SEL" }
+    NSRect
+    { id SEL }
    [ 2drop test-foo "x" get ]
 } ;

@ -52,13 +53,13 @@ CLASS: {
    { +name+ "Bar" }
 } {
    "bar"
-    "NSRect"
-    { "id" "SEL" }
+    NSRect
+    { id SEL }
    [ 2drop test-foo "x" get ]
 } {
    "babb"
-    "int"
-    { "id" "SEL" "int" }
+    int
+    { id SEL int }
    [ 2nip sq ]
 } ;

--- a/basis/cocoa/cocoa.factor
+++ b/basis/cocoa/cocoa.factor
@ -14,14 +14,14 @@ SYMBOL: sent-messages
 : remember-send ( selector -- )
    sent-messages (remember-send) ;

-SYNTAX: -> scan dup remember-send parsed \ send parsed ;
+SYNTAX: -> scan dup remember-send suffix! \ send suffix! ;

 SYMBOL: super-sent-messages

 : remember-super-send ( selector -- )
    super-sent-messages (remember-send) ;

-SYNTAX: SUPER-> scan dup remember-super-send parsed \ super-send parsed ;
+SYNTAX: SUPER-> scan dup remember-super-send suffix! \ super-send suffix! ;

 SYMBOL: frameworks

--- a/basis/cocoa/messages/messages-docs.factor
+++ b/basis/cocoa/messages/messages-docs.factor
@ -2,13 +2,13 @@ USING: help.markup help.syntax strings alien ;
 IN: cocoa.messages

 HELP: send
-{ $values { "args..." "method arguments" } { "receiver" alien } { "selector" string } { "return..." "value returned by method, if any" } }
+{ $values { "receiver" alien } { "args..." "method arguments" } { "selector" string } { "return..." "value returned by method, if any" } }
 { $description "Sends an Objective C message named by " { $snippet "selector" } " to " { $snippet "receiver" } ". The arguments must be on the stack in left-to-right order." }
 { $errors "Throws an error if the receiver does not recognize the message, or if the arguments have inappropriate types." }
 { $notes "This word uses a special fast code path if " { $snippet "selector" } " is a literal and the word containing the call to " { $link send } " is compiled." } ;

 HELP: super-send
-{ $values { "args..." "method arguments" } { "receiver" alien } { "selector" string } { "return..." "value returned by method, if any" } }
+{ $values { "receiver" alien } { "args..." "method arguments" } { "selector" string } { "return..." "value returned by method, if any" } }
 { $description "Sends an Objective C message named by " { $snippet "selector" } " to the super class of " { $snippet "receiver" } ". Otherwise behaves identically to " { $link send } "." } ;

 HELP: objc-class
--- a/basis/cocoa/messages/messages.factor
+++ b/basis/cocoa/messages/messages.factor
@ -2,10 +2,12 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types alien.strings arrays assocs
 classes.struct continuations combinators compiler compiler.alien
-stack-checker kernel math namespaces make quotations sequences
-strings words cocoa.runtime io macros memoize io.encodings.utf8
-effects libc libc.private lexer init core-foundation fry
-generalizations specialized-arrays ;
+core-graphics.types stack-checker kernel math namespaces make
+quotations sequences strings words cocoa.runtime cocoa.types io
+macros memoize io.encodings.utf8 effects layouts libc
+libc.private lexer init core-foundation fry generalizations
+specialized-arrays ;
+QUALIFIED-WITH: alien.c-types c
 IN: cocoa.messages

 SPECIALIZED-ARRAY: void*
@ -98,75 +100,84 @@ class-startup-hooks [ H{ } clone ] initialize
 SYMBOL: objc>alien-types

 H{
-    { "c" "char" }
-    { "i" "int" }
-    { "s" "short" }
-    { "C" "uchar" }
-    { "I" "uint" }
-    { "S" "ushort" }
-    { "f" "float" }
-    { "d" "double" }
-    { "B" "bool" }
-    { "v" "void" }
-    { "*" "char*" }
-    { "?" "unknown_type" }
-    { "@" "id" }
-    { "#" "Class" }
-    { ":" "SEL" }
+    { "c" c:char }
+    { "i" c:int }
+    { "s" c:short }
+    { "C" c:uchar }
+    { "I" c:uint }
+    { "S" c:ushort }
+    { "f" c:float }
+    { "d" c:double }
+    { "B" c:bool }
+    { "v" c:void }
+    { "*" c:char* }
+    { "?" unknown_type }
+    { "@" id }
+    { "#" Class }
+    { ":" SEL }
 }
-"ptrdiff_t" heap-size {
+cell {
    { 4 [ H{
-        { "l" "long" }
-        { "q" "longlong" }
-        { "L" "ulong" }
-        { "Q" "ulonglong" }
+        { "l" c:long }
+        { "q" c:longlong }
+        { "L" c:ulong }
+        { "Q" c:ulonglong }
    } ] }
    { 8 [ H{
-        { "l" "long32" }
-        { "q" "long" }
-        { "L" "ulong32" }
-        { "Q" "ulong" }
+        { "l" long32 }
+        { "q" long }
+        { "L" ulong32 }
+        { "Q" ulong }
    } ] }
 } case
 assoc-union objc>alien-types set-global

+SYMBOL: objc>struct-types
+
+H{
+    { "_NSPoint" NSPoint }
+    { "NSPoint"  NSPoint }
+    { "CGPoint"  NSPoint }
+    { "_NSRect"  NSRect  }
+    { "NSRect"   NSRect  }
+    { "CGRect"   NSRect  }
+    { "_NSSize"  NSSize  }
+    { "NSSize"   NSSize  }
+    { "CGSize"   NSSize  }
+    { "_NSRange" NSRange }
+    { "NSRange"  NSRange }
+} objc>struct-types set-global
+
 ! The transpose of the above map
 SYMBOL: alien>objc-types

 objc>alien-types get [ swap ] assoc-map
 ! A hack...
-"ptrdiff_t" heap-size {
+cell {
    { 4 [ H{
-        { "NSPoint"    "{_NSPoint=ff}" }
-        { "NSRect"     "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
-        { "NSSize"     "{_NSSize=ff}" }
-        { "NSRange"    "{_NSRange=II}" }
-        { "NSInteger"  "i" }
-        { "NSUInteger" "I" }
-        { "CGFloat"    "f" }
+        { NSPoint    "{_NSPoint=ff}" }
+        { NSRect     "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
+        { NSSize     "{_NSSize=ff}" }
+        { NSRange    "{_NSRange=II}" }
+        { NSInteger  "i" }
+        { NSUInteger "I" }
+        { CGFloat    "f" }
    } ] }
    { 8 [ H{
-        { "NSPoint"    "{CGPoint=dd}" }
-        { "NSRect"     "{CGRect={CGPoint=dd}{CGSize=dd}}" }
-        { "NSSize"     "{CGSize=dd}" }
-        { "NSRange"    "{_NSRange=QQ}" }
-        { "NSInteger"  "q" }
-        { "NSUInteger" "Q" }
-        { "CGFloat"    "d" }
+        { NSPoint    "{CGPoint=dd}" }
+        { NSRect     "{CGRect={CGPoint=dd}{CGSize=dd}}" }
+        { NSSize     "{CGSize=dd}" }
+        { NSRange    "{_NSRange=QQ}" }
+        { NSInteger  "q" }
+        { NSUInteger "Q" }
+        { CGFloat    "d" }
    } ] }
 } case
 assoc-union alien>objc-types set-global

-: internal-cocoa-type? ( c-type -- ? )
-    [ "?" = ] [ first CHAR: _ = ] bi or ;
-
-: warn-c-type ( c-type -- )
-    dup internal-cocoa-type?
-    [ drop ] [ "Warning: no such C type: " write print ] if ;
-
 : objc-struct-type ( i string -- ctype )
    [ CHAR: = ] 2keep index-from swap subseq
-    dup c-types get key? [ warn-c-type "void*" ] unless ;
+    objc>struct-types get at* [ drop void* ] unless ;

 ERROR: no-objc-type name ;

@ -177,9 +188,9 @@ ERROR: no-objc-type name ;
 : (parse-objc-type) ( i string -- ctype )
    [ [ 1 + ] dip ] [ nth ] 2bi {
        { [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
-        { [ dup CHAR: ^ = ] [ 3drop "void*" ] }
+        { [ dup CHAR: ^ = ] [ 3drop void* ] }
        { [ dup CHAR: { = ] [ drop objc-struct-type ] }
-        { [ dup CHAR: [ = ] [ 3drop "void*" ] }
+        { [ dup CHAR: [ = ] [ 3drop void* ] }
        [ 2nip decode-type ]
    } cond ;

--- a/basis/cocoa/subclassing/subclassing-docs.factor
+++ b/basis/cocoa/subclassing/subclassing-docs.factor
@ -2,7 +2,7 @@ USING: help.markup help.syntax strings alien hashtables ;
 IN: cocoa.subclassing

 HELP: define-objc-class
-{ $values { "hash" hashtable } { "imeth" "a sequence of instance method definitions" } }
+{ $values { "imeth" "a sequence of instance method definitions" } { "hash" hashtable } }
 { $description "Defines a new Objective C class. The hashtable can contain the following keys:"
    { $list
        { { $link +name+ } " - a string naming the new class. Required." }
--- a/basis/colors/constants/constants.factor
+++ b/basis/colors/constants/constants.factor
@ -30,4 +30,4 @@ ERROR: no-such-color name ;
 : named-color ( name -- color )
    dup colors at [ ] [ no-such-color ] ?if ;

-SYNTAX: COLOR: scan named-color parsed ;
+SYNTAX: COLOR: scan named-color suffix! ;
--- a/basis/columns/columns-tests.factor
+++ b/basis/columns/columns-tests.factor
@ -5,5 +5,5 @@ IN: columns.tests
 { { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set

 [ { 1 4 7 } ] [ "seq" get 0 <column> >array ] unit-test
-[ ] [ "seq" get 1 <column> [ sq ] change-each ] unit-test
+[ ] [ "seq" get 1 <column> [ sq ] map! drop ] unit-test
 [ { 4 25 64 } ] [ "seq" get 1 <column> >array ] unit-test
--- a/basis/columns/columns.factor
+++ b/basis/columns/columns.factor
@ -8,7 +8,7 @@ TUPLE: column seq col ;

 C: <column> column

-M: column virtual-seq seq>> ;
+M: column virtual-exemplar seq>> ;
 M: column virtual@ [ col>> swap ] [ seq>> ] bi nth bounds-check ;
 M: column length seq>> length ;

--- a/basis/combinators/smart/smart-tests.factor
+++ b/basis/combinators/smart/smart-tests.factor
@ -47,3 +47,9 @@ IN: combinators.smart.tests
 [ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test

 [ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test
+
+{ 2 3 } [ [ + ] preserving ] must-infer-as
+
+{ 2 0 } [ [ + ] nullary ] must-infer-as
+
+{ 2 2 } [ [ [ + ] nullary ] preserving ] must-infer-as
--- a/basis/combinators/smart/smart.factor
+++ b/basis/combinators/smart/smart.factor
@ -46,5 +46,8 @@ MACRO: append-outputs ( quot -- seq )
 MACRO: preserving ( quot -- )
    [ infer in>> length ] keep '[ _ ndup @ ] ;

+MACRO: nullary ( quot -- quot' )
+    dup infer out>> length '[ @ _ ndrop ] ;
+
 MACRO: smart-if ( pred true false -- )
    '[ _ preserving _ _ if ] ; inline
--- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor
+++ b/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 ;

--- a/basis/compiler/cfg/builder/builder-tests.factor
+++ b/basis/compiler/cfg/builder/builder-tests.factor
@ -6,6 +6,7 @@ compiler.cfg arrays locals byte-arrays kernel.private math
 slots.private vectors sbufs strings math.partial-dispatch
 hashtables assocs combinators.short-circuit
 strings.private accessors compiler.cfg.instructions ;
+FROM: alien.c-types => int ;
 IN: compiler.cfg.builder.tests

 ! Just ensure that various CFGs build correctly.
@ -66,9 +67,9 @@ IN: compiler.cfg.builder.tests
    [ [ t ] loop ]
    [ [ dup ] loop ]
    [ [ 2 ] [ 3 throw ] if 4 ]
-    [ "int" f "malloc" { "int" } alien-invoke ]
-    [ "int" { "int" } "cdecl" alien-indirect ]
-    [ "int" { "int" } "cdecl" [ ] alien-callback ]
+    [ int f "malloc" { int } alien-invoke ]
+    [ int { int } "cdecl" alien-indirect ]
+    [ int { int } "cdecl" [ ] alien-callback ]
    [ swap - + * ]
    [ swap slot ]
    [ blahblah ]
@ -118,7 +119,6 @@ IN: compiler.cfg.builder.tests

 {
    byte-array
-    simple-alien
    alien
    POSTPONE: f
 } [| class |
@ -161,7 +161,7 @@ IN: compiler.cfg.builder.tests

 : count-insns ( quot insn-check -- ? )
    [ test-mr [ instructions>> ] map ] dip
-    '[ _ count ] sigma ; inline
+    '[ _ count ] map-sum ; inline

 : contains-insn? ( quot insn-check -- ? )
    count-insns 0 > ; inline
@ -191,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
@ -204,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
@ -213,4 +213,4 @@ IN: compiler.cfg.builder.tests
 ] when

 ! Regression. Make sure everything is inlined correctly
-[ f ] [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test
+[ f ] [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/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
    {
--- a/basis/compiler/cfg/cfg.factor
+++ b/basis/compiler/cfg/cfg.factor
@ -4,20 +4,20 @@ USING: kernel math vectors arrays accessors namespaces ;
 IN: compiler.cfg

 TUPLE: basic-block < identity-tuple
-{ id integer }
+id
 number
 { instructions vector }
 { successors vector }
 { predecessors vector } ;

-M: basic-block hashcode* nip id>> ;
-
 : <basic-block> ( -- bb )
    basic-block new
+        \ basic-block counter >>id
        V{ } clone >>instructions
        V{ } clone >>successors
-        V{ } clone >>predecessors
-        \ basic-block counter >>id ;
+        V{ } clone >>predecessors ;
+
+M: basic-block hashcode* nip id>> ;

 TUPLE: cfg { entry basic-block } word label
 spill-area-size reps
--- a/basis/compiler/cfg/checker/checker.factor
+++ b/basis/compiler/cfg/checker/checker.factor
@ -49,7 +49,7 @@ ERROR: bad-kill-insn bb ;
 ERROR: bad-successors ;

 : check-successors ( bb -- )
-    dup successors>> [ predecessors>> memq? ] with all?
+    dup successors>> [ predecessors>> member-eq? ] with all?
    [ bad-successors ] unless ;

 : check-basic-block ( bb -- )
--- a/basis/compiler/cfg/comparisons/comparisons.factor
+++ b/basis/compiler/cfg/comparisons/comparisons.factor
@ -90,5 +90,5 @@ SYMBOLS:
        { cc/>   { +lt+ +eq+      +unordered+ } }
        { cc/<>  {      +eq+      +unordered+ } }
        { cc/<>= {                +unordered+ } }
-    } at memq? ;
+    } at member-eq? ;

--- a/basis/compiler/cfg/copy-prop/copy-prop.factor
+++ b/basis/compiler/cfg/copy-prop/copy-prop.factor
@ -63,7 +63,7 @@ M: insn update-insn rename-insn-uses t ;
    copies get dup assoc-empty? [ 2drop ] [
        renamings set
        [
-            instructions>> [ update-insn ] filter-here
+            instructions>> [ update-insn ] filter! drop
        ] each-basic-block
    ] if ;

--- a/basis/compiler/cfg/dce/dce.factor
+++ b/basis/compiler/cfg/dce/dce.factor
@ -117,5 +117,5 @@ M: insn live-insn? defs-vreg [ live-vreg? ] [ t ] if* ;
    dup
    [ [ instructions>> [ build-liveness-graph ] each ] each-basic-block ]
    [ [ instructions>> [ compute-live-vregs ] each ] each-basic-block ]
-    [ [ instructions>> [ live-insn? ] filter-here ] each-basic-block ]
+    [ [ instructions>> [ live-insn? ] filter! drop ] each-basic-block ]
    tri ;
--- a/basis/compiler/cfg/def-use/def-use.factor
+++ b/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 -- )
-    [ \ defs-vreg create-method ]
-    [ insn-def-slot [ name>> reader-word 1quotation ] [ [ drop f ] ] if* ] bi
-    define ;
+    dup insn-def-slot dup [
+        [ \ defs-vreg create-method ]
+        [ name>> reader-word 1quotation ] bi*
+        define
+    ] [ 2drop ] if ;

 : define-uses-vregs-method ( insn -- )
-    [ \ uses-vregs create-method ]
-    [ insn-use-slots [ name>> ] map slot-array-quot ] bi
-    define ;
+    dup insn-use-slots [ drop ] [
+        [ \ uses-vregs create-method ]
+        [ [ name>> ] map slot-array-quot ] bi*
+        define
+    ] if-empty ;

 : define-temp-vregs-method ( insn -- )
-    [ \ temp-vregs create-method ]
-    [ insn-temp-slots [ name>> ] map slot-array-quot ] bi
-    define ;
+    dup insn-temp-slots [ drop ] [
+        [ \ temp-vregs create-method ]
+        [ [ name>> ] map slot-array-quot ] bi*
+        define
+    ] if-empty ;

 PRIVATE>

--- a/basis/compiler/cfg/gc-checks/gc-checks.factor
+++ b/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
-cpu.architecture layouts
+USING: accessors kernel sequences assocs fry math
+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* ] sigma ;
+    instructions>>
+    [ ##allocation? ] filter
+    [ allocation-size* data-alignment get align ] map-sum ;

 : insert-gc-check ( bb -- )
    dup dup '[
@ -44,4 +46,4 @@ M: ##box-displaced-alien allocation-size* drop 4 cells ;
    dup blocks-with-gc [
        over compute-uninitialized-sets
        [ insert-gc-check ] each
-    ] unless-empty ;
+    ] unless-empty ;
--- a/basis/compiler/cfg/hats/hats.factor
+++ b/basis/compiler/cfg/hats/hats.factor
@ -26,7 +26,7 @@ IN: compiler.cfg.hats

 : hat-effect ( insn -- effect )
    "insn-slots" word-prop
-    [ type>> { def temp } memq? not ] filter [ name>> ] map
+    [ type>> { def temp } member-eq? not ] filter [ name>> ] map
    { "vreg" } <effect> ;

 : define-hat ( insn -- )
@ -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 ;
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@ -417,12 +417,12 @@ def: dst/scalar-rep
 use: src
 literal: rep ;

-PURE-INSN: ##horizontal-shl-vector
+PURE-INSN: ##horizontal-shl-vector-imm
 def: dst
 use: src1
 literal: src2 rep ;

-PURE-INSN: ##horizontal-shr-vector
+PURE-INSN: ##horizontal-shr-vector-imm
 def: dst
 use: src1
 literal: src2 rep ;
@ -462,6 +462,16 @@ def: dst
 use: src
 literal: rep ;

+PURE-INSN: ##shl-vector-imm
+def: dst
+use: src1
+literal: src2 rep ;
+
+PURE-INSN: ##shr-vector-imm
+def: dst
+use: src1
+literal: src2 rep ;
+
 PURE-INSN: ##shl-vector
 def: dst
 use: src1 src2/int-scalar-rep
@ -502,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
-temp: temp/int-rep ;
+use: src/int-rep ;

 : ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
 : ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
@ -517,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 ] }
-        { [ over simple-alien class<= ] [ 2drop ##unbox-alien ] }
-        { [ over byte-array class<= ] [ 2drop ##unbox-byte-array ] }
-        [ nip ##unbox-any-c-ptr ]
+        { [ dup \ f class<= ] [ drop ##unbox-f ] }
+        { [ dup alien class<= ] [ drop ##unbox-alien ] }
+        { [ dup byte-array class<= ] [ drop ##unbox-byte-array ] }
+        [ drop ##unbox-any-c-ptr ]
    } cond ;

 ! Alien accessors
@ -833,7 +842,7 @@ SYMBOL: vreg-insn
 [
    vreg-insn
    insn-classes get [
-        "insn-slots" word-prop [ type>> { def use temp } memq? ] any?
+        "insn-slots" word-prop [ type>> { def use temp } member-eq? ] any?
    ] filter
    define-union-class
 ] with-compilation-unit
--- a/basis/compiler/cfg/intrinsics/alien/alien.factor
+++ b/basis/compiler/cfg/intrinsics/alien/alien.factor
@ -22,12 +22,10 @@ IN: compiler.cfg.intrinsics.alien
    ] [ emit-primitive ] if ;

 :: inline-alien ( node quot test -- )
-    [let | infos [ node node-input-infos ] |
-        infos test call
-        [ infos quot call ]
-        [ node emit-primitive ]
-        if
-    ] ; inline
+    node node-input-infos :> infos
+    infos test call
+    [ infos quot call ]
+    [ node emit-primitive ] if ; inline

 : inline-alien-getter? ( infos -- ? )
    [ first class>> c-ptr class<= ]
@ -35,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 ;
--- a/basis/compiler/cfg/intrinsics/allot/allot.factor
+++ b/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 ;
@ -43,17 +43,15 @@ IN: compiler.cfg.intrinsics.allot
    2 + cells array ^^allot ;

 :: emit-<array> ( node -- )
-    [let | len [ node node-input-infos first literal>> ] |
-        len expand-<array>? [
-            [let | elt [ ds-pop ]
-                   reg [ len ^^allot-array ] |
-                ds-drop
-                len reg array store-length
-                len reg elt array store-initial-element
-                reg ds-push
-            ]
-        ] [ node emit-primitive ] if
-    ] ;
+    node node-input-infos first literal>> :> len
+    len expand-<array>? [
+        ds-pop :> elt
+        len ^^allot-array :> reg
+        ds-drop
+        len reg array store-length
+        len reg elt array store-initial-element
+        reg ds-push
+    ] [ node emit-primitive ] if ;

 : expand-(byte-array)? ( obj -- ? )
    dup integer? [ 0 1024 between? ] [ drop f ] if ;
@ -64,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
--- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
+++ b/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
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@ -33,6 +33,7 @@ IN: compiler.cfg.intrinsics
 {
    { kernel.private:tag [ drop emit-tag ] }
    { kernel.private:getenv [ emit-getenv ] }
+    { kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] }
    { math.private:both-fixnums? [ drop emit-both-fixnums? ] }
    { math.private:fixnum+ [ drop emit-fixnum+ ] }
    { math.private:fixnum- [ drop emit-fixnum- ] }
@ -163,8 +164,8 @@ IN: compiler.cfg.intrinsics
        { math.vectors.simd.intrinsics:(simd-v*) [ [ ^^mul-vector ] emit-binary-vector-op ] }
        { math.vectors.simd.intrinsics:(simd-vs*) [ [ ^^saturated-mul-vector ] emit-binary-vector-op ] }
        { math.vectors.simd.intrinsics:(simd-v/) [ [ ^^div-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vmin) [ [ ^^min-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vmax) [ [ ^^max-vector ] emit-binary-vector-op ] }
+        { math.vectors.simd.intrinsics:(simd-vmin) [ [ generate-min-vector ] emit-binary-vector-op ] }
+        { math.vectors.simd.intrinsics:(simd-vmax) [ [ generate-max-vector ] emit-binary-vector-op ] }
        { math.vectors.simd.intrinsics:(simd-v.) [ [ ^^dot-vector ] emit-binary-vector-op ] }
        { math.vectors.simd.intrinsics:(simd-vabs) [ [ generate-abs-vector ] emit-unary-vector-op ] }
        { math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-unary-vector-op ] }
@ -187,10 +188,10 @@ IN: compiler.cfg.intrinsics
        { math.vectors.simd.intrinsics:(simd-vany?) [ [ vcc-any ^^test-vector ] emit-unary-vector-op ] }
        { math.vectors.simd.intrinsics:(simd-vall?) [ [ vcc-all ^^test-vector ] emit-unary-vector-op ] }
        { math.vectors.simd.intrinsics:(simd-vnone?) [ [ vcc-none ^^test-vector ] emit-unary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vlshift) [ [ ^^shl-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vrshift) [ [ ^^shr-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-hlshift) [ [ ^^horizontal-shl-vector ] emit-horizontal-shift ] }
-        { math.vectors.simd.intrinsics:(simd-hrshift) [ [ ^^horizontal-shr-vector ] emit-horizontal-shift ] }
+        { math.vectors.simd.intrinsics:(simd-vlshift) [ [ ^^shl-vector-imm ] [ ^^shl-vector ] emit-shift-vector-op ] }
+        { math.vectors.simd.intrinsics:(simd-vrshift) [ [ ^^shr-vector-imm ] [ ^^shr-vector ] emit-shift-vector-op ] }
+        { math.vectors.simd.intrinsics:(simd-hlshift) [ [ ^^horizontal-shl-vector-imm ] emit-shift-vector-imm-op ] }
+        { math.vectors.simd.intrinsics:(simd-hrshift) [ [ ^^horizontal-shr-vector-imm ] emit-shift-vector-imm-op ] }
        { math.vectors.simd.intrinsics:(simd-with) [ [ ^^with-vector ] emit-unary-vector-op ] }
        { math.vectors.simd.intrinsics:(simd-gather-2) [ emit-gather-vector-2 ] }
        { math.vectors.simd.intrinsics:(simd-gather-4) [ emit-gather-vector-4 ] }
--- a/basis/compiler/cfg/intrinsics/misc/misc.factor
+++ b/basis/compiler/cfg/intrinsics/misc/misc.factor
@ -1,9 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces layouts sequences kernel
-accessors compiler.tree.propagation.info
-compiler.cfg.stacks compiler.cfg.hats
-compiler.cfg.instructions compiler.cfg.utilities ;
+USING: namespaces layouts sequences kernel math accessors
+compiler.tree.propagation.info compiler.cfg.stacks
+compiler.cfg.hats compiler.cfg.instructions
+compiler.cfg.utilities ;
 IN: compiler.cfg.intrinsics.misc

 : emit-tag ( -- )
@ -14,3 +14,9 @@ IN: compiler.cfg.intrinsics.misc
    swap node-input-infos first literal>>
    [ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot ^^slot ] if*
    ds-push ;
+
+: emit-identity-hashcode ( -- )
+    ds-pop tag-mask get bitnot ^^load-immediate ^^and 0 0 ^^slot-imm
+    hashcode-shift ^^shr-imm
+    ^^tag-fixnum
+    ds-push ;
--- a/basis/compiler/cfg/intrinsics/simd/simd.factor
+++ b/basis/compiler/cfg/intrinsics/simd/simd.factor
@ -10,8 +10,8 @@ compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.hats
 compiler.cfg.instructions compiler.cfg.registers
 compiler.cfg.intrinsics.alien
 specialized-arrays ;
-FROM: alien.c-types => heap-size char uchar float double ;
-SPECIALIZED-ARRAYS: float double ;
+FROM: alien.c-types => heap-size uchar ushort uint ulonglong float double ;
+SPECIALIZED-ARRAYS: uchar ushort uint ulonglong float double ;
 IN: compiler.cfg.intrinsics.simd

 MACRO: check-elements ( quots -- )
@ -55,10 +55,15 @@ MACRO: if-literals-match ( quots -- )
 : [unary/param] ( quot -- quot' )
    '[ [ -2 inc-d ds-pop ] 2dip @ ds-push ] ; inline

-: emit-horizontal-shift ( node quot -- )
+: emit-shift-vector-imm-op ( node quot -- )
    [unary/param]
    { [ integer? ] [ representation? ] } if-literals-match ; inline

+:: emit-shift-vector-op ( node imm-quot var-quot -- )
+    node node-input-infos 2 tail-slice* first literal>> integer?
+    [ node imm-quot emit-shift-vector-imm-op ]
+    [ node var-quot emit-binary-vector-op ] if ; inline
+
 : emit-gather-vector-2 ( node -- )
    [ ^^gather-vector-2 ] emit-binary-vector-op ;

@ -155,28 +160,79 @@ MACRO: if-literals-match ( quots -- )
    [ ^^not-vector ]
    [ [ ^^fill-vector ] [ ^^xor-vector ] bi ] if ;

-:: (generate-compare-vector) ( src1 src2 rep {cc,swap} -- dst )
-    {cc,swap} first2 :> swap? :> cc
+:: ((generate-compare-vector)) ( src1 src2 rep {cc,swap} -- dst )
+    {cc,swap} first2 :> ( cc swap? )
    swap?
    [ src2 src1 rep cc ^^compare-vector ]
    [ src1 src2 rep cc ^^compare-vector ] if ;

-:: generate-compare-vector ( src1 src2 rep orig-cc -- dst )
-    rep orig-cc %compare-vector-ccs :> not? :> ccs
+:: (generate-compare-vector) ( src1 src2 rep orig-cc -- dst )
+    rep orig-cc %compare-vector-ccs :> ( ccs not? )

    ccs empty?
    [ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ]
    [
-        ccs unclip :> first-cc :> rest-ccs
-        src1 src2 rep first-cc (generate-compare-vector) :> first-dst
+        ccs unclip :> ( rest-ccs first-cc )
+        src1 src2 rep first-cc ((generate-compare-vector)) :> first-dst

        rest-ccs first-dst
-        [ [ src1 src2 rep ] dip (generate-compare-vector) rep ^^or-vector ]
+        [ [ src1 src2 rep ] dip ((generate-compare-vector)) rep ^^or-vector ]
        reduce

        not? [ rep generate-not-vector ] when
    ] if ;

+: sign-bit-mask ( rep -- byte-array )
+    unsign-rep {
+        { char-16-rep [ uchar-array{
+            HEX: 80 HEX: 80 HEX: 80 HEX: 80
+            HEX: 80 HEX: 80 HEX: 80 HEX: 80
+            HEX: 80 HEX: 80 HEX: 80 HEX: 80
+            HEX: 80 HEX: 80 HEX: 80 HEX: 80
+        } underlying>> ] }
+        { short-8-rep [ ushort-array{
+            HEX: 8000 HEX: 8000 HEX: 8000 HEX: 8000
+            HEX: 8000 HEX: 8000 HEX: 8000 HEX: 8000
+        } underlying>> ] }
+        { int-4-rep [ uint-array{
+            HEX: 8000,0000 HEX: 8000,0000
+            HEX: 8000,0000 HEX: 8000,0000
+        } underlying>> ] }
+        { longlong-2-rep [ ulonglong-array{
+            HEX: 8000,0000,0000,0000
+            HEX: 8000,0000,0000,0000
+        } underlying>> ] }
+    } case ;
+
+:: (generate-minmax-compare-vector) ( src1 src2 rep orig-cc -- dst )
+    orig-cc order-cc {
+        { cc<  [ src1 src2 rep ^^max-vector src1 rep cc/= (generate-compare-vector) ] }
+        { cc<= [ src1 src2 rep ^^min-vector src1 rep cc=  (generate-compare-vector) ] }
+        { cc>  [ src1 src2 rep ^^min-vector src1 rep cc/= (generate-compare-vector) ] }
+        { cc>= [ src1 src2 rep ^^max-vector src1 rep cc=  (generate-compare-vector) ] }
+    } case ;
+
+:: generate-compare-vector ( src1 src2 rep orig-cc -- dst )
+    {
+        {
+            [ rep orig-cc %compare-vector-reps member? ]
+            [ src1 src2 rep orig-cc (generate-compare-vector) ]
+        }
+        {
+            [ rep %min-vector-reps member? ]
+            [ src1 src2 rep orig-cc (generate-minmax-compare-vector) ]
+        }
+        {
+            [ rep unsign-rep orig-cc %compare-vector-reps member? ]
+            [ 
+                rep sign-bit-mask ^^load-constant :> sign-bits
+                src1 sign-bits rep ^^xor-vector
+                src2 sign-bits rep ^^xor-vector
+                rep unsign-rep orig-cc (generate-compare-vector)
+            ]
+        }
+    } cond ;
+
 :: generate-unpack-vector-head ( src rep -- dst )
    {
        {
@ -190,6 +246,14 @@ MACRO: if-literals-match ( quots -- )
                src zero rep ^^merge-vector-head
            ]
        }
+        {
+            [ rep widen-vector-rep %shr-vector-imm-reps member? ]
+            [
+                src src rep ^^merge-vector-head
+                rep rep-component-type
+                heap-size 8 * rep widen-vector-rep ^^shr-vector-imm
+            ]
+        }
        [
            rep ^^zero-vector :> zero
            zero src rep cc> ^^compare-vector :> sign
@ -217,6 +281,14 @@ MACRO: if-literals-match ( quots -- )
                src zero rep ^^merge-vector-tail
            ]
        }
+        {
+            [ rep widen-vector-rep %shr-vector-imm-reps member? ]
+            [
+                src src rep ^^merge-vector-tail
+                rep rep-component-type
+                heap-size 8 * rep widen-vector-rep ^^shr-vector-imm
+            ]
+        }
        [
            rep ^^zero-vector :> zero
            zero src rep cc> ^^compare-vector :> sign
@ -265,3 +337,17 @@ MACRO: if-literals-match ( quots -- )
        ]
    } cond ;

+: generate-min-vector ( src1 src2 rep -- dst )
+    dup %min-vector-reps member?
+    [ ^^min-vector ] [
+        [ cc< generate-compare-vector ]
+        [ generate-blend-vector ] 3bi
+    ] if ;
+
+: generate-max-vector ( src1 src2 rep -- dst )
+    dup %max-vector-reps member?
+    [ ^^max-vector ] [
+        [ cc> generate-compare-vector ]
+        [ generate-blend-vector ] 3bi
+    ] if ;
+
--- a/basis/compiler/cfg/intrinsics/slots/slots.factor
+++ b/basis/compiler/cfg/intrinsics/slots/slots.factor
@ -1,14 +1,17 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: layouts namespaces kernel accessors sequences math
-classes.algebra locals combinators cpu.architecture
-compiler.tree.propagation.info compiler.cfg.stacks
-compiler.cfg.hats compiler.cfg.registers
+classes.algebra classes.builtin locals combinators
+cpu.architecture compiler.tree.propagation.info
+compiler.cfg.stacks compiler.cfg.hats compiler.cfg.registers
 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
+: class-tag ( class -- tag/f )
+    builtins get [ class<= ] with find drop ;
+
+: value-tag ( info -- n ) class>> class-tag ;

 : ^^tag-offset>slot ( slot tag -- vreg' )
    [ ^^offset>slot ] dip ^^sub-imm ;
@ -42,7 +45,7 @@ IN: compiler.cfg.intrinsics.slots
    first class>> immediate class<= not ;

 :: (emit-set-slot) ( infos -- )
-    3inputs :> slot :> obj :> src
+    3inputs :> ( src obj slot )

    slot infos second value-tag ^^tag-offset>slot :> slot

@ -54,7 +57,7 @@ IN: compiler.cfg.intrinsics.slots
 :: (emit-set-slot-imm) ( infos -- )
    ds-drop

-    2inputs :> obj :> src
+    2inputs :> ( src obj )

    infos third literal>> :> slot
    infos second value-tag :> tag
--- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
@ -42,7 +42,7 @@ IN: compiler.cfg.linear-scan.allocation

 : handle-sync-point ( n -- )
    [ active-intervals get values ] dip
-    '[ [ _ spill-at-sync-point ] filter-here ] each ;
+    '[ [ _ spill-at-sync-point ] filter! drop ] each ;

 :: handle-progress ( n sync? -- )
    n {
--- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
@ -18,13 +18,13 @@ ERROR: bad-live-ranges interval ;

 : trim-before-ranges ( live-interval -- )
    [ ranges>> ] [ uses>> last 1 + ] bi
-    [ '[ from>> _ <= ] filter-here ]
+    [ '[ from>> _ <= ] filter! drop ]
    [ swap last (>>to) ]
    2bi ;

 : trim-after-ranges ( live-interval -- )
    [ ranges>> ] [ uses>> first ] bi
-    [ '[ to>> _ >= ] filter-here ]
+    [ '[ to>> _ >= ] filter! drop ]
    [ swap first (>>from) ]
    2bi ;

@ -103,7 +103,7 @@ ERROR: bad-live-ranges interval ;
    ! most one) are split and spilled and removed from the inactive
    ! set.
    new vreg>> active-intervals-for [ [ reg>> reg = ] find swap dup ] keep
-    '[ _ delete-nth new start>> spill ] [ 2drop ] if ;
+    '[ _ remove-nth! drop  new start>> spill ] [ 2drop ] if ;

 :: spill-intersecting-inactive ( new reg -- )
    ! Any inactive intervals using 'reg' are split and spilled
@ -114,7 +114,7 @@ ERROR: bad-live-ranges interval ;
                new start>> spill f
            ] [ drop t ] if
        ] [ drop t ] if
-    ] filter-here ;
+    ] filter! drop ;

 : spill-intersecting ( new reg -- )
    ! Split and spill all active and inactive intervals
@ -141,4 +141,4 @@ ERROR: bad-live-ranges interval ;
        { [ 2dup spill-new? ] [ spill-new ] }
        { [ 2dup register-available? ] [ spill-available ] }
        [ spill-partially-available ]
-    } cond ;
+    } cond ;
--- a/basis/compiler/cfg/linear-scan/allocation/state/state.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor
@ -33,7 +33,7 @@ SYMBOL: active-intervals
    dup vreg>> active-intervals-for push ;

 : delete-active ( live-interval -- )
-    dup vreg>> active-intervals-for delq ;
+    dup vreg>> active-intervals-for remove-eq! drop ;

 : assign-free-register ( new registers -- )
    pop >>reg add-active ;
@ -48,7 +48,7 @@ SYMBOL: inactive-intervals
    dup vreg>> inactive-intervals-for push ;

 : delete-inactive ( live-interval -- )
-    dup vreg>> inactive-intervals-for delq ;
+    dup vreg>> inactive-intervals-for remove-eq! drop ;

 ! Vector of handled live intervals
 SYMBOL: handled-intervals
@ -83,7 +83,7 @@ ERROR: register-already-used live-interval ;
 ! Moving intervals between active and inactive sets
 : process-intervals ( n symbol quots -- )
    ! symbol stores an alist mapping register classes to vectors
-    [ get values ] dip '[ [ _ cond ] with filter-here ] with each ; inline
+    [ get values ] dip '[ [ _ cond ] with filter! drop ] with each ; inline

 : deactivate-intervals ( n -- )
    ! Any active intervals which have ended are moved to handled
--- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
+++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
@ -152,8 +152,8 @@ ERROR: bad-live-interval live-interval ;
    ! to reverse some sequences, and compute the start and end.
    values dup [
        {
-            [ ranges>> reverse-here ]
-            [ uses>> reverse-here ]
+            [ ranges>> reverse! drop ]
+            [ uses>> reverse! drop ]
            [ compute-start/end ]
            [ check-start ]
        } cleave
@ -187,4 +187,4 @@ ERROR: bad-live-interval live-interval ;
    } cond ;

 : intervals-intersect? ( interval1 interval2 -- ? )
-    relevant-ranges intersect-live-ranges >boolean ; inline
+    relevant-ranges intersect-live-ranges >boolean ; inline
--- a/basis/compiler/cfg/predecessors/predecessors.factor
+++ b/basis/compiler/cfg/predecessors/predecessors.factor
@ -12,7 +12,7 @@ IN: compiler.cfg.predecessors
 : update-phi ( bb ##phi -- )
    [
        swap predecessors>>
-        '[ drop _ memq? ] assoc-filter
+        '[ drop _ member-eq? ] assoc-filter
    ] change-inputs drop ;

 : update-phis ( bb -- )
@ -30,4 +30,4 @@ PRIVATE>

 : needs-predecessors ( cfg -- cfg' )
    dup predecessors-valid?>>
-    [ compute-predecessors t >>predecessors-valid? ] unless ;
+    [ compute-predecessors t >>predecessors-valid? ] unless ;
--- a/basis/compiler/cfg/registers/registers.factor
+++ b/basis/compiler/cfg/registers/registers.factor
@ -1,6 +1,6 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces kernel parser assocs ;
+USING: accessors namespaces kernel parser assocs sequences ;
 IN: compiler.cfg.registers

 ! Virtual registers, used by CFG and machine IRs, are just integers
@ -42,5 +42,5 @@ C: <ds-loc> ds-loc
 TUPLE: rs-loc < loc ;
 C: <rs-loc> rs-loc

-SYNTAX: D scan-word <ds-loc> parsed ;
-SYNTAX: R scan-word <rs-loc> parsed ;
+SYNTAX: D scan-word <ds-loc> suffix! ;
+SYNTAX: R scan-word <rs-loc> suffix! ;
--- a/basis/compiler/cfg/renaming/functor/functor.factor
+++ b/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
--- a/basis/compiler/cfg/representations/preferred/preferred.factor
+++ b/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,12 +25,14 @@ GENERIC: uses-vreg-reps ( insn -- reps )
    } case ;

 : define-defs-vreg-rep-method ( insn -- )
-    [ \ defs-vreg-rep create-method ]
-    [ insn-def-slot [ rep>> rep-getter-quot ] [ [ drop f ] ] if* ]
-    bi define ;
+    dup insn-def-slot dup [
+        [ \ defs-vreg-rep create-method ]
+        [ rep>> rep-getter-quot ]
+        bi* define
+    ] [ 2drop ] if ;

 : reps-getter-quot ( reps -- quot )
-    dup [ rep>> { f scalar-rep } memq? not ] all? [
+    dup [ rep>> { f scalar-rep } member-eq? not ] all? [
        [ rep>> ] map [ drop ] swap suffix
    ] [
        [ rep>> rep-getter-quot ] map dup length {
@ -38,14 +44,18 @@ GENERIC: uses-vreg-reps ( insn -- reps )
    ] if ;

 : define-uses-vreg-reps-method ( insn -- )
-    [ \ uses-vreg-reps create-method ]
-    [ insn-use-slots reps-getter-quot ]
-    bi define ;
+    dup insn-use-slots [ drop ] [
+        [ \ uses-vreg-reps create-method ]
+        [ reps-getter-quot ]
+        bi* define
+    ] if-empty ;

 : define-temp-vreg-reps-method ( insn -- )
-    [ \ temp-vreg-reps create-method ]
-    [ insn-temp-slots reps-getter-quot ]
-    bi define ;
+    dup insn-temp-slots [ drop ] [
+        [ \ temp-vreg-reps create-method ]
+        [ reps-getter-quot ]
+        bi* define
+    ] if-empty ;

 PRIVATE>

--- a/basis/compiler/cfg/representations/representations.factor
+++ b/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
@ -209,7 +209,7 @@ RENAMING: convert [ converted-value ] [ converted-value ] [ ]

 : perform-renaming ( insn -- )
    needs-renaming? get [
-        renaming-set get reverse-here
+        renaming-set get reverse! drop
        [ convert-insn-uses ] [ convert-insn-defs ] bi
        renaming-set get length 0 assert=
    ] [ drop ] if ;
--- a/basis/compiler/cfg/ssa/destruction/destruction.factor
+++ b/basis/compiler/cfg/ssa/destruction/destruction.factor
@ -102,7 +102,7 @@ M: ##phi prepare-insn
            [ rename-insn-defs ]
            [ rename-insn-uses ]
            [ [ useless-copy? ] [ ##phi? ] bi or not ] tri
-        ] filter-here
+        ] filter! drop
    ] each-basic-block ;

 : destruct-ssa ( cfg -- cfg' )
@ -114,4 +114,4 @@ M: ##phi prepare-insn
    dup compute-live-ranges
    dup prepare-coalescing
    process-copies
-    dup perform-renaming ;
+    dup perform-renaming ;
--- a/basis/compiler/cfg/ssa/liveness/liveness.factor
+++ b/basis/compiler/cfg/ssa/liveness/liveness.factor
@ -121,10 +121,9 @@ PRIVATE>
 PRIVATE>

 :: live-out? ( vreg node -- ? )
-    [let | def [ vreg def-of ] |
-        {
-            { [ node def eq? ] [ vreg uses-of def only? not ] }
-            { [ def node strictly-dominates? ] [ vreg node (live-out?) ] }
-            [ f ]
-        } cond
-    ] ;
+    vreg def-of :> def
+    {
+        { [ node def eq? ] [ vreg uses-of def only? not ] }
+        { [ def node strictly-dominates? ] [ vreg node (live-out?) ] }
+        [ f ]
+    } cond ;
--- a/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor
+++ b/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor
@ -13,7 +13,7 @@ IN: compiler.cfg.useless-conditionals
                ##compare-imm-branch
                ##compare-float-ordered-branch
                ##compare-float-unordered-branch
-            } memq?
+            } member-eq?
        ]
        [ successors>> first2 [ skip-empty-blocks ] bi@ eq? ]
    } 1&& ;
--- a/basis/compiler/cfg/utilities/utilities.factor
+++ b/basis/compiler/cfg/utilities/utilities.factor
@ -40,8 +40,8 @@ SYMBOL: visited
 :: insert-basic-block ( froms to bb -- )
    bb froms V{ } like >>predecessors drop
    bb to 1vector >>successors drop
-    to predecessors>> [ dup froms memq? [ drop bb ] when ] change-each
-    froms [ successors>> [ dup to eq? [ drop bb ] when ] change-each ] each ;
+    to predecessors>> [ dup froms member-eq? [ drop bb ] when ] map! drop
+    froms [ successors>> [ dup to eq? [ drop bb ] when ] map! drop ] each ;

 : add-instructions ( bb quot -- )
    [ instructions>> building ] dip '[
--- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor
+++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
@ -27,6 +27,9 @@ C: <reference> reference-expr
 M: reference-expr equal?
    over reference-expr? [ [ value>> ] bi@ eq? ] [ 2drop f ] if ;

+M: reference-expr hashcode*
+    nip value>> identity-hashcode ;
+
 : constant>vn ( constant -- vn ) <constant> expr>vn ; inline

 GENERIC: >expr ( insn -- expr )
@ -42,7 +45,7 @@ M: ##load-constant >expr obj>> <constant> ;
 <<

 : input-values ( slot-specs -- slot-specs' )
-    [ type>> { use literal constant } memq? ] filter ;
+    [ type>> { use literal constant } member-eq? ] filter ;

 : expr-class ( insn -- expr )
    name>> "##" ?head drop "-expr" append create-class-in ;
--- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
+++ b/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,8 +110,8 @@ M: ##compare-imm rewrite-tagged-comparison
 : rewrite-redundant-comparison? ( insn -- ? )
    {
        [ src1>> vreg>expr general-compare-expr? ]
-        [ src2>> \ f tag-number = ]
-        [ cc>> { cc= cc/= } memq? ]
+        [ src2>> \ f type-number = ]
+        [ cc>> { cc= cc/= } member-eq? ]
    } 1&& ; inline

 : rewrite-redundant-comparison ( insn -- insn' )
@ -174,7 +174,7 @@ M: ##compare-imm-branch rewrite
    [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ = ; inline

 : (rewrite-self-compare) ( insn -- ? )
-    cc>> { cc= cc<= cc>= } memq? ;
+    cc>> { cc= cc<= cc>= } member-eq? ;

 : rewrite-self-compare-branch ( insn -- insn' )
    (rewrite-self-compare) fold-branch ;
@ -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' )
@ -279,7 +279,7 @@ M: ##not rewrite
        ##sub-imm
        ##mul
        ##mul-imm
-    } memq? ;
+    } member-eq? ;

 : immediate? ( value op -- ? )
    arithmetic-op? [ immediate-arithmetic? ] [ immediate-bitwise? ] if ;
@ -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 ;

@ -515,3 +515,48 @@ M: ##scalar>vector rewrite
 M: ##xor-vector rewrite
    dup [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi eq?
    [ [ dst>> ] [ rep>> ] bi \ ##zero-vector new-insn ] [ drop f ] if ;
+
+: vector-not? ( expr -- ? )
+    {
+        [ not-vector-expr? ]
+        [ {
+            [ xor-vector-expr? ]
+            [ [ src1>> ] [ src2>> ] bi [ vn>expr fill-vector-expr? ] either? ]
+        } 1&& ]
+    } 1|| ;
+
+GENERIC: vector-not-src ( expr -- vreg )
+M: not-vector-expr vector-not-src src>> vn>vreg ;
+M: xor-vector-expr vector-not-src
+    dup src1>> vn>expr fill-vector-expr? [ src2>> ] [ src1>> ] if vn>vreg ;
+
+M: ##and-vector rewrite 
+    {
+        { [ dup src1>> vreg>expr vector-not? ] [
+            {
+                [ dst>> ]
+                [ src1>> vreg>expr vector-not-src ]
+                [ src2>> ]
+                [ rep>> ]
+            } cleave \ ##andn-vector new-insn
+        ] }
+        { [ dup src2>> vreg>expr vector-not? ] [
+            {
+                [ dst>> ]
+                [ src2>> vreg>expr vector-not-src ]
+                [ src1>> ]
+                [ rep>> ]
+            } cleave \ ##andn-vector new-insn
+        ] }
+        [ drop f ]
+    } cond ;
+
+M: ##andn-vector rewrite
+    dup src1>> vreg>expr vector-not? [
+        {
+            [ dst>> ]
+            [ src1>> vreg>expr vector-not-src ]
+            [ src2>> ]
+            [ rep>> ]
+        } cleave \ ##and-vector new-insn
+    ] [ drop f ] if ;
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/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 2 2 }
-        T{ ##load-immediate f 3 5 }
+        T{ ##load-immediate f 1 10 }
+        T{ ##load-immediate f 2 20 }
+        T{ ##load-immediate f 3 $[ \ f type-number ] }
    }
 ] [
    {
-        T{ ##load-immediate f 1 1 }
-        T{ ##load-immediate f 2 2 }
+        T{ ##load-immediate f 1 10 }
+        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 2 2 }
-        T{ ##load-immediate f 3 5 }
+        T{ ##load-immediate f 1 10 }
+        T{ ##load-immediate f 2 20 }
+        T{ ##load-immediate f 3 $[ \ f type-number ] }
    }
 ] [
    {
-        T{ ##load-immediate f 1 1 }
-        T{ ##load-immediate f 2 2 }
+        T{ ##load-immediate f 1 10 }
+        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 ] }
    }
 ] [
    {
@ -1281,6 +1281,128 @@ cell 8 = [
    } value-numbering-step
 ] unit-test

+! NOT x AND y => x ANDN y
+
+[
+    {
+        T{ ##fill-vector f 3 float-4-rep }
+        T{ ##xor-vector  f 4 0 3 float-4-rep }
+        T{ ##andn-vector f 5 0 1 float-4-rep }
+    }
+] [
+    {
+        T{ ##fill-vector f 3 float-4-rep }
+        T{ ##xor-vector  f 4 0 3 float-4-rep }
+        T{ ##and-vector  f 5 4 1 float-4-rep }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##not-vector  f 4 0 float-4-rep }
+        T{ ##andn-vector f 5 0 1 float-4-rep }
+    }
+] [
+    {
+        T{ ##not-vector  f 4 0 float-4-rep }
+        T{ ##and-vector  f 5 4 1 float-4-rep }
+    } value-numbering-step
+] unit-test
+
+! x AND NOT y => y ANDN x
+
+[
+    {
+        T{ ##fill-vector f 3 float-4-rep }
+        T{ ##xor-vector  f 4 0 3 float-4-rep }
+        T{ ##andn-vector f 5 0 1 float-4-rep }
+    }
+] [
+    {
+        T{ ##fill-vector f 3 float-4-rep }
+        T{ ##xor-vector  f 4 0 3 float-4-rep }
+        T{ ##and-vector  f 5 1 4 float-4-rep }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##not-vector  f 4 0 float-4-rep }
+        T{ ##andn-vector f 5 0 1 float-4-rep }
+    }
+] [
+    {
+        T{ ##not-vector  f 4 0 float-4-rep }
+        T{ ##and-vector  f 5 1 4 float-4-rep }
+    } value-numbering-step
+] unit-test
+
+! NOT x ANDN y => x AND y
+
+[
+    {
+        T{ ##fill-vector f 3 float-4-rep }
+        T{ ##xor-vector  f 4 0 3 float-4-rep }
+        T{ ##and-vector  f 5 0 1 float-4-rep }
+    }
+] [
+    {
+        T{ ##fill-vector f 3 float-4-rep }
+        T{ ##xor-vector  f 4 0 3 float-4-rep }
+        T{ ##andn-vector f 5 4 1 float-4-rep }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##not-vector  f 4 0 float-4-rep }
+        T{ ##and-vector  f 5 0 1 float-4-rep }
+    }
+] [
+    {
+        T{ ##not-vector  f 4 0 float-4-rep }
+        T{ ##andn-vector f 5 4 1 float-4-rep }
+    } value-numbering-step
+] unit-test
+
+! AND <=> ANDN
+
+[
+    {
+        T{ ##fill-vector f 3 float-4-rep }
+        T{ ##xor-vector  f 4 0 3 float-4-rep }
+        T{ ##andn-vector f 5 0 1 float-4-rep }
+        T{ ##and-vector  f 6 0 2 float-4-rep }
+        T{ ##or-vector   f 7 5 6 float-4-rep }
+    }
+] [
+    {
+        T{ ##fill-vector f 3 float-4-rep }
+        T{ ##xor-vector  f 4 0 3 float-4-rep }
+        T{ ##and-vector  f 5 4 1 float-4-rep }
+        T{ ##andn-vector f 6 4 2 float-4-rep }
+        T{ ##or-vector   f 7 5 6 float-4-rep }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##not-vector  f 4 0   float-4-rep }
+        T{ ##andn-vector f 5 0 1 float-4-rep }
+        T{ ##and-vector  f 6 0 2 float-4-rep }
+        T{ ##or-vector   f 7 5 6 float-4-rep }
+    }
+] [
+    {
+        T{ ##not-vector  f 4 0   float-4-rep }
+        T{ ##and-vector  f 5 4 1 float-4-rep }
+        T{ ##andn-vector f 6 4 2 float-4-rep }
+        T{ ##or-vector   f 7 5 6 float-4-rep }
+    } value-numbering-step
+] unit-test
+
+! branch folding
+
 : test-branch-folding ( insns -- insns' n )
    <basic-block>
    [ V{ 0 1 } clone >>successors basic-block set value-numbering-step ] keep
@ -1435,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

@ -1537,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
--- a/basis/compiler/cfg/write-barrier/write-barrier.factor
+++ b/basis/compiler/cfg/write-barrier/write-barrier.factor
@ -37,7 +37,7 @@ M: insn eliminate-write-barrier drop t ;
 : write-barriers-step ( bb -- )
    H{ } clone fresh-allocations set
    H{ } clone mutated-objects set
-    instructions>> [ eliminate-write-barrier ] filter-here ;
+    instructions>> [ eliminate-write-barrier ] filter! drop ;

 : eliminate-write-barriers ( cfg -- cfg' )
    dup [ write-barriers-step ] each-basic-block ;
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@ -181,14 +181,16 @@ CODEGEN: ##dot-vector %dot-vector
 CODEGEN: ##sqrt-vector %sqrt-vector
 CODEGEN: ##horizontal-add-vector %horizontal-add-vector
 CODEGEN: ##horizontal-sub-vector %horizontal-sub-vector
-CODEGEN: ##horizontal-shl-vector %horizontal-shl-vector
-CODEGEN: ##horizontal-shr-vector %horizontal-shr-vector
+CODEGEN: ##horizontal-shl-vector-imm %horizontal-shl-vector-imm
+CODEGEN: ##horizontal-shr-vector-imm %horizontal-shr-vector-imm
 CODEGEN: ##abs-vector %abs-vector
 CODEGEN: ##and-vector %and-vector
 CODEGEN: ##andn-vector %andn-vector
 CODEGEN: ##or-vector %or-vector
 CODEGEN: ##xor-vector %xor-vector
 CODEGEN: ##not-vector %not-vector
+CODEGEN: ##shl-vector-imm %shl-vector-imm
+CODEGEN: ##shr-vector-imm %shr-vector-imm
 CODEGEN: ##shl-vector %shl-vector
 CODEGEN: ##shr-vector %shr-vector
 CODEGEN: ##integer>scalar %integer>scalar
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@ -5,13 +5,16 @@ continuations vocabs assocs dlists definitions math graphs generic
 generic.single combinators deques search-deques macros
 source-files.errors combinators.short-circuit

-stack-checker stack-checker.state stack-checker.inlining stack-checker.errors
+stack-checker stack-checker.dependencies stack-checker.inlining
+stack-checker.errors

 compiler.errors compiler.units compiler.utilities

 compiler.tree.builder
 compiler.tree.optimizer

+compiler.crossref
+
 compiler.cfg
 compiler.cfg.builder
 compiler.cfg.optimizer
@ -55,28 +58,28 @@ SYMBOL: compiled

 GENERIC: no-compile? ( word -- ? )

-M: word no-compile? "no-compile" word-prop ;
-
 M: method-body no-compile? "method-generic" word-prop no-compile? ;

 M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;

+M: word no-compile?
+    { [ macro? ] [ "special" word-prop ] [ "no-compile" word-prop ] } 1|| ;
+
+GENERIC: combinator? ( word -- ? )
+
+M: method-body combinator? "method-generic" word-prop combinator? ;
+
+M: predicate-engine-word combinator? "owner-generic" word-prop combinator? ;
+
+M: word combinator? inline? ;
+
 : ignore-error? ( word error -- ? )
    #! Ignore some errors on inline combinators, macros, and special
    #! words such as 'call'.
-    [
-        {
-            [ macro? ]
-            [ inline? ]
-            [ no-compile? ]
-            [ "special" word-prop ]
-        } 1||
-    ] [
-        {
-            [ do-not-compile? ]
-            [ literal-expected? ]
-        } 1||
-    ] bi* and ;
+    {
+        [ drop no-compile? ]
+        [ [ combinator? ] [ unknown-macro-input? ] bi* and ]
+    } 2|| ;

 : finish ( word -- )
    #! Recompile callers if the word's stack effect changed, then
@ -199,6 +202,14 @@ M: optimizing-compiler recompile ( words -- alist )
    ] with-scope
    "--- compile done" compiler-message ;

+M: optimizing-compiler to-recompile ( -- words )
+    changed-definitions get compiled-usages
+    changed-generics get compiled-generic-usages
+    append assoc-combine keys ;
+
+M: optimizing-compiler process-forgotten-words
+    [ delete-compiled-xref ] each ;
+
 : with-optimizer ( quot -- )
    [ optimizing-compiler compiler-impl ] dip with-variable ; inline

--- a/basis/compiler/constants/constants.factor
+++ b/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 tag-number - ; inline
-: string-offset ( -- n ) 4 string tag-number slot-offset ; inline
-: string-aux-offset ( -- n ) 2 string tag-number slot-offset ; inline
-: profile-count-offset ( -- n ) 8 \ word tag-number slot-offset ; inline
-: byte-array-offset ( -- n ) 2 byte-array tag-number slot-offset ; inline
-: alien-offset ( -- n ) 3 alien tag-number slot-offset ; inline
-: underlying-alien-offset ( -- n ) 1 alien tag-number slot-offset ; inline
-: tuple-class-offset ( -- n ) 1 tuple tag-number slot-offset ; inline
-: word-xt-offset ( -- n ) 10 \ word tag-number slot-offset ; inline
-: quot-xt-offset ( -- n ) 4 quotation tag-number slot-offset ; inline
-: word-code-offset ( -- n ) 11 \ word tag-number slot-offset ; inline
-: array-start-offset ( -- n ) 2 array tag-number slot-offset ; inline
+: float-offset ( -- n ) 8 float type-number - ; inline
+: string-offset ( -- n ) 4 string type-number slot-offset ; inline
+: string-aux-offset ( -- n ) 2 string type-number slot-offset ; inline
+: profile-count-offset ( -- n ) 8 \ word type-number slot-offset ; inline
+: byte-array-offset ( -- n ) 16 byte-array type-number - ; inline
+: alien-offset ( -- n ) 4 alien type-number slot-offset ; inline
+: underlying-alien-offset ( -- n ) 1 alien type-number slot-offset ; inline
+: tuple-class-offset ( -- n ) 1 tuple type-number slot-offset ; inline
+: word-xt-offset ( -- n ) 10 \ word type-number slot-offset ; inline
+: quot-xt-offset ( -- n ) 4 quotation type-number slot-offset ; inline
+: word-code-offset ( -- n ) 11 \ word type-number slot-offset ; inline
+: array-start-offset ( -- n ) 2 array type-number slot-offset ; inline
 : compiled-header-size ( -- n ) 4 bootstrap-cells ; inline

 ! Relocation classes
--- a/basis/compiler/crossref/authors.txt
+++ b/basis/compiler/crossref/authors.txt
--- a/basis/compiler/crossref/crossref.factor
+++ b/basis/compiler/crossref/crossref.factor
@ -0,0 +1,68 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs classes.algebra compiler.units definitions graphs
+grouping kernel namespaces sequences words
+stack-checker.dependencies ;
+IN: compiler.crossref
+
+SYMBOL: compiled-crossref
+
+compiled-crossref [ H{ } clone ] initialize
+
+SYMBOL: compiled-generic-crossref
+
+compiled-generic-crossref [ H{ } clone ] initialize
+
+: compiled-usage ( word -- assoc )
+    compiled-crossref get at ;
+
+: (compiled-usages) ( word -- assoc )
+    #! If the word is not flushable anymore, we have to recompile
+    #! all words which flushable away a call (presumably when the
+    #! word was still flushable). If the word is flushable, we
+    #! don't have to recompile words that folded this away.
+    [ compiled-usage ]
+    [ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi
+    [ dependency>= nip ] curry assoc-filter ;
+
+: compiled-usages ( seq -- assocs )
+    [ drop word? ] assoc-filter
+    [ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ;
+
+: compiled-generic-usage ( word -- assoc )
+    compiled-generic-crossref get at ;
+
+: (compiled-generic-usages) ( generic class -- assoc )
+    [ compiled-generic-usage ] dip
+    [
+        2dup [ valid-class? ] both?
+        [ classes-intersect? ] [ 2drop f ] if nip
+    ] curry assoc-filter ;
+
+: compiled-generic-usages ( assoc -- assocs )
+    [ (compiled-generic-usages) ] { } assoc>map ;
+
+: (compiled-xref) ( word dependencies word-prop variable -- )
+    [ [ concat ] dip set-word-prop ] [ get add-vertex* ] bi-curry* 2bi ;
+
+: compiled-xref ( word dependencies generic-dependencies -- )
+    [ [ drop crossref? ] { } assoc-filter-as ] bi@
+    [ "compiled-uses" compiled-crossref (compiled-xref) ]
+    [ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ]
+    bi-curry* bi ;
+
+: (compiled-unxref) ( word word-prop variable -- )
+    [ [ [ dupd word-prop 2 <groups> ] dip get remove-vertex* ] 2curry ]
+    [ drop [ remove-word-prop ] curry ]
+    2bi bi ;
+
+: compiled-unxref ( word -- )
+    [ "compiled-uses" compiled-crossref (compiled-unxref) ]
+    [ "compiled-generic-uses" compiled-generic-crossref (compiled-unxref) ]
+    bi ;
+
+: delete-compiled-xref ( word -- )
+    [ compiled-unxref ]
+    [ compiled-crossref get delete-at ]
+    [ compiled-generic-crossref get delete-at ]
+    tri ;
--- a/basis/compiler/tests/alien.factor
+++ b/basis/compiler/tests/alien.factor
@ -12,7 +12,7 @@ IN: compiler.tests.alien

 <<
 : libfactor-ffi-tests-path ( -- string )
-    "resource:" (normalize-path)
+    "resource:" absolute-path
    {
        { [ os winnt? ]  [ "libfactor-ffi-test.dll" ] }
        { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
@ -90,14 +90,14 @@ FUNCTION: TINY ffi_test_17 int x ;
 [ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with

 : indirect-test-1 ( ptr -- result )
-    "int" { } "cdecl" alien-indirect ;
+    int { } "cdecl" alien-indirect ;

 { 1 1 } [ indirect-test-1 ] must-infer-as

 [ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test

 : indirect-test-1' ( ptr -- )
-    "int" { } "cdecl" alien-indirect drop ;
+    int { } "cdecl" alien-indirect drop ;

 { 1 0 } [ indirect-test-1' ] must-infer-as

@ -106,7 +106,7 @@ FUNCTION: TINY ffi_test_17 int x ;
 [ -1 indirect-test-1 ] must-fail

 : indirect-test-2 ( x y ptr -- result )
-    "int" { "int" "int" } "cdecl" alien-indirect gc ;
+    int { int int } "cdecl" alien-indirect gc ;

 { 3 1 } [ indirect-test-2 ] must-infer-as

@ -115,20 +115,20 @@ FUNCTION: TINY ffi_test_17 int x ;
 unit-test

 : indirect-test-3 ( a b c d ptr -- result )
-    "int" { "int" "int" "int" "int" } "stdcall" alien-indirect
+    int { int int int int } "stdcall" alien-indirect
    gc ;

 [ f ] [ "f-stdcall" load-library f = ] unit-test
 [ "stdcall" ] [ "f-stdcall" library abi>> ] unit-test

 : ffi_test_18 ( w x y z -- int )
-    "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
+    int "f-stdcall" "ffi_test_18" { int int int int }
    alien-invoke gc ;

 [ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test

 : ffi_test_19 ( x y z -- BAR )
-    "BAR" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
+    BAR "f-stdcall" "ffi_test_19" { long long long }
    alien-invoke gc ;

 [ 11 6 -7 ] [
@ -157,17 +157,17 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
 ! Make sure XT doesn't get clobbered in stack frame

 : ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result y )
-    "int"
+    int
    "f-cdecl" "ffi_test_31"
-    { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
+    { int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int }
    alien-invoke gc 3 ;

 [ 861 3 ] [ 42 [ ] each ffi_test_31 ] unit-test

 : ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result )
-    "float"
+    float
    "f-cdecl" "ffi_test_31_point_5"
-    { "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" }
+    { float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float }
    alien-invoke ;

 [ 861.0 ] [ 42 [ >float ] each ffi_test_31_point_5 ] unit-test
@ -312,21 +312,21 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;

 ! Test callbacks

-: callback-1 ( -- callback ) "void" { } "cdecl" [ ] alien-callback ;
+: callback-1 ( -- callback ) void { } "cdecl" [ ] alien-callback ;

 [ 0 1 ] [ [ callback-1 ] infer [ in>> ] [ out>> ] bi ] unit-test

 [ t ] [ callback-1 alien? ] unit-test

-: callback_test_1 ( ptr -- ) "void" { } "cdecl" alien-indirect ;
+: callback_test_1 ( ptr -- ) void { } "cdecl" alien-indirect ;

 [ ] [ callback-1 callback_test_1 ] unit-test

-: callback-2 ( -- callback ) "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
+: callback-2 ( -- callback ) void { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;

 [ ] [ callback-2 callback_test_1 ] unit-test

-: callback-3 ( -- callback ) "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
+: callback-3 ( -- callback ) void { } "cdecl" [ 5 "x" set ] alien-callback ;

 [ t ] [
    namestack*
@ -341,7 +341,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
 ] unit-test

 : callback-4 ( -- callback )
-    "void" { } "cdecl" [ "Hello world" write ] alien-callback
+    void { } "cdecl" [ "Hello world" write ] alien-callback
    gc ;

 [ "Hello world" ] [
@ -349,40 +349,40 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
 ] unit-test

 : callback-5 ( -- callback )
-    "void" { } "cdecl" [ gc ] alien-callback ;
+    void { } "cdecl" [ gc ] alien-callback ;

 [ "testing" ] [
    "testing" callback-5 callback_test_1
 ] unit-test

 : callback-5b ( -- callback )
-    "void" { } "cdecl" [ compact-gc ] alien-callback ;
+    void { } "cdecl" [ compact-gc ] alien-callback ;

 [ "testing" ] [
    "testing" callback-5b callback_test_1
 ] unit-test

 : callback-6 ( -- callback )
-    "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
+    void { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;

 [ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test

 : callback-7 ( -- callback )
-    "void" { } "cdecl" [ 1000000 sleep ] alien-callback ;
+    void { } "cdecl" [ 1000000 sleep ] alien-callback ;

 [ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test

 [ f ] [ namespace global eq? ] unit-test

 : callback-8 ( -- callback )
-    "void" { } "cdecl" [
+    void { } "cdecl" [
        [ continue ] callcc0
    ] alien-callback ;

 [ ] [ callback-8 callback_test_1 ] unit-test

 : callback-9 ( -- callback )
-    "int" { "int" "int" "int" } "cdecl" [
+    int { int int int } "cdecl" [
        + + 1 +
    ] alien-callback ;

@ -440,13 +440,13 @@ STRUCT: double-rect
    } cleave ;

 : double-rect-callback ( -- alien )
-    "void" { "void*" "void*" "double-rect" } "cdecl"
+    void { void* void* double-rect } "cdecl"
    [ "example" set-global 2drop ] alien-callback ;

 : double-rect-test ( arg -- arg' )
    f f rot
    double-rect-callback
-    "void" { "void*" "void*" "double-rect" } "cdecl" alien-indirect
+    void { void* void* double-rect } "cdecl" alien-indirect
    "example" get-global ;

 [ 1.0 2.0 3.0 4.0 ]
@ -463,7 +463,7 @@ FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
 ] unit-test

 : callback-10 ( -- callback )
-    "test_struct_14" { "double" "double" } "cdecl"
+    test_struct_14 { double double } "cdecl"
    [
        test_struct_14 <struct>
            swap >>x2
@ -471,7 +471,7 @@ FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
    ] alien-callback ;

 : callback-10-test ( x1 x2 callback -- result )
-    "test_struct_14" { "double" "double" } "cdecl" alien-indirect ;
+    test_struct_14 { double double } "cdecl" alien-indirect ;

 [ 1.0 2.0 ] [
    1.0 2.0 callback-10 callback-10-test
@ -486,7 +486,7 @@ FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
 ] unit-test

 : callback-11 ( -- callback )
-    "test-struct-12" { "int" "double" } "cdecl"
+    test-struct-12 { int double } "cdecl"
    [
        test-struct-12 <struct>
            swap >>x
@ -494,7 +494,7 @@ FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
    ] alien-callback ;

 : callback-11-test ( x1 x2 callback -- result )
-    "test-struct-12" { "int" "double" } "cdecl" alien-indirect ;
+    test-struct-12 { int double } "cdecl" alien-indirect ;

 [ 1 2.0 ] [
    1 2.0 callback-11 callback-11-test
@ -510,7 +510,7 @@ FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
 [ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test

 : callback-12 ( -- callback )
-    "test_struct_15" { "float" "float" } "cdecl"
+    test_struct_15 { float float } "cdecl"
    [
        test_struct_15 <struct>
            swap >>y
@ -518,7 +518,7 @@ FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
    ] alien-callback ;

 : callback-12-test ( x1 x2 callback -- result )
-    "test_struct_15" { "float" "float" } "cdecl" alien-indirect ;
+    test_struct_15 { float float } "cdecl" alien-indirect ;

 [ 1.0 2.0 ] [
    1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
@ -533,7 +533,7 @@ FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
 [ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test

 : callback-13 ( -- callback )
-    "test_struct_16" { "float" "int" } "cdecl"
+    test_struct_16 { float int } "cdecl"
    [
        test_struct_16 <struct>
            swap >>a
@ -541,7 +541,7 @@ FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
    ] alien-callback ;

 : callback-13-test ( x1 x2 callback -- result )
-    "test_struct_16" { "float" "int" } "cdecl" alien-indirect ;
+    test_struct_16 { float int } "cdecl" alien-indirect ;

 [ 1.0 2 ] [
    1.0 2 callback-13 callback-13-test
@ -588,5 +588,4 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
 ! Regression: calling an undefined function would raise a protection fault
 FUNCTION: void this_does_not_exist ( ) ;

-[ this_does_not_exist ] [ { "kernel-error" 10 f f } = ] must-fail-with
-
+[ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with
--- a/basis/compiler/tests/codegen.factor
+++ b/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
@ -270,8 +256,8 @@ TUPLE: id obj ;
    { float } declare dup 0 =
    [ drop 1 ] [
        dup 0 >=
-        [ 2 "double" "libm" "pow" { "double" "double" } alien-invoke ]
-        [ -0.5 "double" "libm" "pow" { "double" "double" } alien-invoke ]
+        [ 2 double "libm" "pow" { double double } alien-invoke ]
+        [ -0.5 double "libm" "pow" { double double } alien-invoke ]
        if
    ] if ;

@ -475,4 +461,4 @@ TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-
 [ 2 0 ] [
    1 1
    [ [ HEX: f bitand ] bi@ [ shift ] [ drop -3 shift ] 2bi ] compile-call
-] unit-test
+] unit-test
--- a/basis/compiler/tests/intrinsics.factor
+++ b/basis/compiler/tests/intrinsics.factor
@ -21,7 +21,6 @@ IN: compiler.tests.intrinsics
 [ 2 1 3 ] [ 1 2 3 [ swapd ] compile-call ] unit-test
 [ 2 ] [ 1 2 [ nip ] compile-call ] unit-test
 [ 3 ] [ 1 2 3 [ 2nip ] compile-call ] unit-test
-[ 2 1 2 ] [ 1 2 [ tuck ] compile-call ] unit-test
 [ 1 2 1 ] [ 1 2 [ over ] compile-call ] unit-test
 [ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-call ] unit-test
 [ 2 1 ] [ 1 2 [ swap ] compile-call ] unit-test
@ -244,20 +243,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: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test
+[ HEX: 8000000 ] [ HEX: -8000000 >fixnum [ 0 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
-[ -268435457 ] [ 1 28 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
+[ t ] [ 1 26 fixnum-shift dup [ fixnum+ ] compile-call 1 27 fixnum-shift = ] 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 +284,8 @@ cell 8 = [

 ! 64-bit overflow
 cell 8 = [
-    [ t ] [ 1 59 fixnum-shift dup [ fixnum+ ] compile-call 1 60 fixnum-shift = ] unit-test
-    [ -1152921504606846977 ] [ 1 60 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
+    [ t ] [ 1 58 fixnum-shift dup [ fixnum+ ] compile-call 1 59 fixnum-shift = ] 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 +300,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 +310,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
-        2dup
-        [ fixnum* ] 2keep compiled-fixnum* =
-        [ 2drop ] [ "Oops" throw ] if
+        32 random-bits >fixnum
+        32 random-bits >fixnum
+        2dup [ fixnum* ] [ compiled-fixnum* ] 2bi 2dup =
+        [ 2drop 2drop ] [ bug-in-fixnum* ] if
    ] times
 ] unit-test

@ -419,7 +420,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
@ -584,16 +585,16 @@ TUPLE: alien-accessor-regression { b byte-array } { i fixnum } ;
    swap [
        { tuple } declare 1 slot
    ] [
-        0 slot
+        1 slot
    ] if ;

-[ t ] [ f B{ } mutable-value-bug-1 byte-array type-number = ] unit-test
+[ 0 ] [ f { } mutable-value-bug-1 ] unit-test

 : mutable-value-bug-2 ( a b -- c )
    swap [
-        0 slot
+        1 slot
    ] [
        { tuple } declare 1 slot
    ] if ;

-[ t ] [ t B{ } mutable-value-bug-2 byte-array type-number = ] unit-test
+[ 0 ] [ t { } mutable-value-bug-2 ] unit-test
--- a/basis/compiler/tests/low-level-ir.factor
+++ b/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{ ##add-imm f 0 0 -8 }
+        T{ ##load-immediate f 0 32 }
+        T{ ##add-imm f 0 0 -16 }
    } compile-test-bb
 ] unit-test
--- a/basis/compiler/tests/optimizer.factor
+++ b/basis/compiler/tests/optimizer.factor
@ -4,7 +4,7 @@ sbufs strings tools.test vectors words sequences.private
 quotations classes classes.algebra classes.tuple.private
 continuations growable namespaces hints alien.accessors
 compiler.tree.builder compiler.tree.optimizer sequences.deep
-compiler definitions generic.single ;
+compiler definitions generic.single shuffle ;
 IN: compiler.tests.optimizer

 GENERIC: xyz ( obj -- obj )
@ -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
@ -443,5 +443,7 @@ M: object bad-dispatch-position-test* ;
 [ -1 ] [ 3 4 0 dispatch-branch-problem ] unit-test
 [ 12 ] [ 3 4 1 dispatch-branch-problem ] unit-test

+[ 1024 bignum ] [ 10 [ 1 >bignum swap >fixnum shift ] compile-call dup class ] unit-test
+
 ! Not sure if I want to fix this...
-! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with
+! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with
--- a/basis/compiler/tests/redefine3.factor
+++ b/basis/compiler/tests/redefine3.factor
@ -1,6 +1,6 @@
 USING: accessors compiler compiler.units tools.test math parser
 kernel sequences sequences.private classes.mixin generic
-definitions arrays words assocs eval ;
+definitions arrays words assocs eval grouping ;
 IN: compiler.tests.redefine3

 GENERIC: sheeple ( obj -- x )
@ -13,20 +13,23 @@ M: empty-mixin sheeple drop "wake up" ; inline

 : sheeple-test ( -- string ) { } sheeple ;

+: compiled-use? ( key word -- ? )
+    "compiled-uses" word-prop 2 <groups> key? ;
+
 [ "sheeple" ] [ sheeple-test ] unit-test
 [ t ] [ \ sheeple-test optimized? ] unit-test
-[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
-[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
+[ t ] [ object \ sheeple method \ sheeple-test compiled-use? ] unit-test
+[ f ] [ empty-mixin \ sheeple method \ sheeple-test compiled-use? ] unit-test

 [ ] [ "IN: compiler.tests.redefine3 USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test

 [ "wake up" ] [ sheeple-test ] unit-test
-[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
-[ t ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
+[ f ] [ object \ sheeple method \ sheeple-test compiled-use? ] unit-test
+[ t ] [ empty-mixin \ sheeple method \ sheeple-test compiled-use? ] unit-test

 [ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test

 [ "sheeple" ] [ sheeple-test ] unit-test
 [ t ] [ \ sheeple-test optimized? ] unit-test
-[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
-[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
+[ t ] [ object \ sheeple method \ sheeple-test compiled-use? ] unit-test
+[ f ] [ empty-mixin \ sheeple method \ sheeple-test compiled-use? ] unit-test
--- a/basis/compiler/tests/simple.factor
+++ b/basis/compiler/tests/simple.factor
@ -1,6 +1,7 @@
 USING: compiler compiler.units tools.test kernel kernel.private
 sequences.private math.private math combinators strings alien
-arrays memory vocabs parser eval ;
+arrays memory vocabs parser eval quotations compiler.errors
+definitions ;
 IN: compiler.tests.simple

 ! Test empty word
@ -238,3 +239,13 @@ M: f single-combination-test-2 single-combination-test-4 ;
        "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized?" eval( -- obj )
    ] unit-test
 ] times
+
+! This should not compile
+GENERIC: bad-effect-test ( a -- )
+M: quotation bad-effect-test call ; inline
+: bad-effect-test* ( -- ) [ 1 2 3 ] bad-effect-test ;
+
+[ bad-effect-test* ] [ not-compiled? ] must-fail-with
+
+! Don't want compiler error to stick around
+[ ] [ [ M\ quotation bad-effect-test forget ] with-compilation-unit ] unit-test
--- a/basis/compiler/tests/stack-trace.factor
+++ b/basis/compiler/tests/stack-trace.factor
@ -19,7 +19,7 @@ IN: compiler.tests.stack-trace

 : bleh ( seq -- seq' ) [ 3 + ] map [ 0 > ] filter ;

-: stack-trace-any? ( word -- ? ) symbolic-stack-trace memq? ;
+: stack-trace-any? ( word -- ? ) symbolic-stack-trace member-eq? ;

 [ t ] [
    [ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-any?
--- a/basis/compiler/tree/builder/builder.factor
+++ b/basis/compiler/tree/builder/builder.factor
@ -39,7 +39,7 @@ M: word (build-tree)
    [
        <recursive-state> recursive-state set
        V{ } clone stack-visitor set
-        [ [ >vector \ meta-d set ] [ length d-in set ] bi ]
+        [ [ >vector \ meta-d set ] [ length input-count set ] bi ]
        [ (build-tree) ]
        bi*
    ] with-infer nip ;
--- a/basis/compiler/tree/cleanup/cleanup-tests.factor
+++ b/basis/compiler/tree/cleanup/cleanup-tests.factor
@ -491,7 +491,7 @@ cell-bits 32 = [
 ] unit-test

 [ t ] [
-    [ { array } declare 2 <groups> [ . . ] assoc-each ]
+    [ { array } declare 2 <sliced-groups> [ . . ] assoc-each ]
    \ nth-unsafe inlined?
 ] unit-test

--- a/basis/compiler/tree/cleanup/cleanup.factor
+++ b/basis/compiler/tree/cleanup/cleanup.factor
@ -3,7 +3,7 @@
 USING: kernel accessors sequences combinators fry
 classes.algebra namespaces assocs words math math.private
 math.partial-dispatch math.intervals classes classes.tuple
-classes.tuple.private layouts definitions stack-checker.state
+classes.tuple.private layouts definitions stack-checker.dependencies
 stack-checker.branches
 compiler.utilities
 compiler.tree
@ -20,7 +20,7 @@ IN: compiler.tree.cleanup
 GENERIC: delete-node ( node -- )

 M: #call-recursive delete-node
-    dup label>> calls>> [ node>> eq? not ] with filter-here ;
+    dup label>> calls>> [ node>> eq? not ] with filter! drop ;

 M: #return-recursive delete-node
    label>> f >>return drop ;
--- a/basis/compiler/tree/dead-code/dead-code-tests.factor
+++ b/basis/compiler/tree/dead-code/dead-code-tests.factor
@ -6,7 +6,7 @@ compiler.tree.tuple-unboxing compiler.tree.debugger
 compiler.tree.recursive compiler.tree.normalization
 compiler.tree.checker tools.test kernel math stack-checker.state
 accessors combinators io prettyprint words sequences.deep
-sequences.private arrays classes kernel.private ;
+sequences.private arrays classes kernel.private shuffle ;
 IN: compiler.tree.dead-code.tests

 : count-live-values ( quot -- n )
--- a/basis/compiler/tree/dead-code/recursive/recursive.factor
+++ b/basis/compiler/tree/dead-code/recursive/recursive.factor
@ -39,14 +39,13 @@ M: #enter-recursive remove-dead-code*
    2bi ;

 :: (drop-call-recursive-outputs) ( inputs outputs -- #shuffle )
-    [let* | new-live-outputs [ inputs outputs filter-corresponding make-values ]
-            live-outputs [ outputs filter-live ] |
-        new-live-outputs
-        live-outputs
-        live-outputs
-        new-live-outputs
-        drop-values
-    ] ;
+    inputs outputs filter-corresponding make-values :> new-live-outputs
+    outputs filter-live :> live-outputs
+    new-live-outputs
+    live-outputs
+    live-outputs
+    new-live-outputs
+    drop-values ;

 : drop-call-recursive-outputs ( node -- #shuffle )
    dup [ label>> return>> in-d>> ] [ out-d>> ] bi
@ -60,22 +59,20 @@ M: #call-recursive remove-dead-code*
    tri 3array ;

 :: drop-recursive-inputs ( node -- shuffle )
-    [let* | shuffle [ node [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs ]
-            new-outputs [ shuffle out-d>> ] |
-        node new-outputs
-        [ [ label>> enter-recursive>> ] dip >>in-d drop ] [ >>in-d drop ] 2bi
-        shuffle
-    ] ;
+    node [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs :> shuffle
+    shuffle out-d>> :> new-outputs
+    node new-outputs
+    [ [ label>> enter-recursive>> ] dip >>in-d drop ] [ >>in-d drop ] 2bi
+    shuffle ;

 :: drop-recursive-outputs ( node -- shuffle )
-    [let* | return [ node label>> return>> ]
-            new-inputs [ return in-d>> filter-live ]
-            new-outputs [ return [ in-d>> ] [ out-d>> ] bi filter-corresponding ] |
-        return
-        [ new-inputs >>in-d new-outputs >>out-d drop ]
-        [ drop-dead-outputs ]
-        bi
-    ] ;
+    node label>> return>> :> return
+    return in-d>> filter-live :> new-inputs
+    return [ in-d>> ] [ out-d>> ] bi filter-corresponding :> new-outputs
+    return
+    [ new-inputs >>in-d new-outputs >>out-d drop ]
+    [ drop-dead-outputs ]
+    bi ;

 M: #recursive remove-dead-code* ( node -- nodes )
    [ drop-recursive-inputs ]
--- a/basis/compiler/tree/dead-code/simple/simple.factor
+++ b/basis/compiler/tree/dead-code/simple/simple.factor
@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors words assocs sequences arrays namespaces
 fry locals definitions classes classes.algebra generic
-stack-checker.state
+stack-checker.dependencies
 stack-checker.backend
 compiler.tree
 compiler.tree.propagation.info
@ -71,14 +71,13 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
    filter-corresponding zip #data-shuffle ; inline

 :: drop-dead-values ( outputs -- #shuffle )
-    [let* | new-outputs [ outputs make-values ]
-            live-outputs [ outputs filter-live ] |
-        new-outputs
-        live-outputs
-        outputs
-        new-outputs
-        drop-values
-    ] ;
+    outputs make-values :> new-outputs
+    outputs filter-live :> live-outputs
+    new-outputs
+    live-outputs
+    outputs
+    new-outputs
+    drop-values ;

 : drop-dead-outputs ( node -- #shuffle )
    dup out-d>> drop-dead-values [ in-d>> >>out-d drop ] keep ;
--- a/basis/compiler/tree/debugger/debugger.factor
+++ b/basis/compiler/tree/debugger/debugger.factor
@ -51,7 +51,6 @@ MATCH-VARS: ?a ?b ?c ;
        { { { ?b ?a } { ?a ?b } } [ swap ] }
        { { { ?b ?a ?c } { ?a ?b ?c } } [ swapd ] }
        { { { ?a ?b } { ?a ?a ?b } } [ dupd ] }
-        { { { ?a ?b } { ?b ?a ?b } } [ tuck ] }
        { { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] }
        { { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] }
        { { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }
--- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor
+++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor
@ -75,7 +75,7 @@ M: #push compute-modular-candidates*
    0 cell-bits tag-bits get - 1 - [a,b] interval-subset? ;

 : modular-word? ( #call -- ? )
-    dup word>> { shift fixnum-shift bignum-shift } memq?
+    dup word>> { shift fixnum-shift bignum-shift } member-eq?
    [ node-input-infos second interval>> small-shift? ]
    [ word>> "modular-arithmetic" word-prop ]
    if ;
@ -178,10 +178,10 @@ MEMO: fixnum-coercion ( flags -- nodes )
    ] when ;

 : like->fixnum? ( #call -- ? )
-    word>> { >fixnum bignum>fixnum float>fixnum } memq? ;
+    word>> { >fixnum bignum>fixnum float>fixnum } member-eq? ;

 : like->integer? ( #call -- ? )
-    word>> { >integer >bignum fixnum>bignum } memq? ;
+    word>> { >integer >bignum fixnum>bignum } member-eq? ;

 M: #call optimize-modular-arithmetic*
    {
--- a/basis/compiler/tree/propagation/branches/branches.factor
+++ b/basis/compiler/tree/propagation/branches/branches.factor
@ -97,7 +97,7 @@ M: #phi propagate-before ( #phi -- )
    constraints get last update-constraints ;

 : branch-phi-constraints ( output values booleans -- )
-     {
+    {
        {
            { { t } { f } }
            [
@ -130,6 +130,22 @@ M: #phi propagate-before ( #phi -- )
                swap t-->
            ]
        }
+        {
+            { { t f } { t } }
+            [
+                first =f
+                condition-value get =t /\
+                swap f-->
+            ]
+        }
+        {
+            { { t } { t f } }
+            [
+                second =f
+                condition-value get =f /\
+                swap f-->
+            ]
+        }
        {
            { { t f } { } }
            [
--- a/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor
+++ b/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor
@ -1,7 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: compiler.tree.propagation.call-effect tools.test fry math effects kernel
-compiler.tree.builder compiler.tree.optimizer compiler.tree.debugger sequences ;
+compiler.tree.builder compiler.tree.optimizer compiler.tree.debugger sequences
+eval combinators ;
 IN: compiler.tree.propagation.call-effect.tests

 [ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
@ -58,4 +59,23 @@ IN: compiler.tree.propagation.call-effect.tests
 ! [ boa ] by itself doesn't infer
 TUPLE: a-tuple x ;

-[ V{ a-tuple } ] [ [ a-tuple '[ _ boa ] call( x -- tuple ) ] final-classes ] unit-test
+[ V{ a-tuple } ] [ [ a-tuple '[ _ boa ] call( x -- tuple ) ] final-classes ] unit-test
+
+! See if redefinitions are handled correctly
+: call(-redefine-test ( a -- b ) 1 + ;
+
+: test-quotatation ( -- quot ) [ call(-redefine-test ] ;
+
+[ t ] [ test-quotatation cached-effect (( a -- b )) effect<= ] unit-test
+
+[ ] [ "IN: compiler.tree.propagation.call-effect.tests USE: math : call(-redefine-test ( a b -- c ) + ;" eval( -- ) ] unit-test
+
+[ t ] [ test-quotatation cached-effect (( a b -- c )) effect<= ] unit-test
+
+: inline-cache-invalidation-test ( a b c -- c ) call( a b -- c ) ;
+
+[ 4 ] [ 1 3 test-quotatation inline-cache-invalidation-test ] unit-test
+
+[ ] [ "IN: compiler.tree.propagation.call-effect.tests USE: math : call(-redefine-test ( a -- c ) 1 + ;" eval( -- ) ] unit-test
+
+[ 1 3 test-quotatation inline-cache-invalidation-test ] [ T{ wrong-values f (( a b -- c )) } = ] must-fail-with
--- a/Show More
+++ b/Show More