Merge branch 'master' into startup

Conflicts:
	core/bootstrap/primitives.factor
	vm/run.hpp

Makefile

@@ -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 \

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"

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

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

@@ -30,8 +30,9 @@ TUPLE: abstract-c-type
 { unboxer-quot callable }
 { getter callable }
 { setter callable }
-size
+{ size integer }
-align ;
+{ 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?
+M: object c-struct? drop f ;
-    drop f ;
+
-M: c-type-name c-struct?
+M: c-type-name c-struct? dup void? [ drop f ] [ c-type c-struct? ] if ;
-    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>
+    cpu ppc? [
-        [ alien-unsigned-1 0 = not ] >>getter
+        <c-type>
-        [ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter
+            [ alien-unsigned-4 c-bool> ] >>getter
-        1 >>size
+            [ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
-        1 >>align
+            4 >>size
-        "box_boolean" >>boxer
+            4 >>align
-        "to_boolean" >>unboxer
+            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
+    cpu x86.64? os windows? and [
-    \ long c-type \ intptr_t typedef
+        \ longlong c-type \ ptrdiff_t typedef
-    \ ulong c-type \ uintptr_t typedef
+        \ longlong c-type \ intptr_t typedef
-    \ ulong c-type \ size_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 { float double } member-eq? ] [ drop -1/0. 1/0. ] }
-        { [ dup { char short int long longlong } memq? ] [ signed-interval ] }
+        { [ dup { char short int long longlong } member-eq? ] [ signed-interval ] }
-        { [ dup { uchar ushort uint ulong ulonglong } memq? ] [ unsigned-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

basis/alien/data/data.factor

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

basis/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

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 )) ;

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 ]

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" } ;
 

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? ;

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" } ;
 

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
 

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)

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

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
+USING: alien arrays byte-arrays generic hashtables
-io io.binary io.files io.encodings.binary io.pathnames kernel
+hashtables.private io io.binary io.files io.encodings.binary
-kernel.private math namespaces make parser prettyprint sequences
+io.pathnames kernel kernel.private math namespaces make parser
-strings sbufs vectors words quotations assocs system layouts splitting
+prettyprint sequences strings sbufs vectors words quotations
-grouping growable classes classes.builtin classes.tuple
+assocs system layouts splitting grouping growable classes
-classes.tuple.private vocabs vocabs.loader source-files definitions
+classes.builtin classes.tuple classes.tuple.private vocabs
-debugger quotations.private combinators math.order math.private
+vocabs.loader source-files definitions debugger
-accessors slots.private generic.single.private compiler.units
+quotations.private combinators combinators.short-circuit
-compiler.constants fry bootstrap.image.syntax ;
+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?)
+M: bignum (eql?) = ;
-    over float? [ fp-bitwise= ] [ 2drop f ] if ;
 
-M: sequence (eql?)
+M: float (eql?) fp-bitwise= ;
-    over sequence? [
+
-        2dup [ length ] bi@ =
+M: sequence (eql?) 2dup [ length ] bi@ = [ [ eql? ] 2all? ] [ 2drop f ] if ;
-        [ [ eql? ] 2all? ] [ 2drop f ] if
-    ] [ 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 49
-USERENV: pic-tuple 50
+USERENV: pic-check-tag 50
-USERENV: pic-hi-tag-tuple 51
+USERENV: pic-check-tuple 51
-USERENV: pic-check-tag 52
+USERENV: pic-hit 52
-USERENV: pic-check 53
+USERENV: pic-miss-word 53
-USERENV: pic-hit 54
+USERENV: pic-miss-tail-word 54
-USERENV: pic-miss-word 55
-USERENV: pic-miss-tail-word 56
 
 ! Megamorphic dispatch
 USERENV: mega-lookup 57
@@ -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

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

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

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! ;

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

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

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 )
+<PRIVATE
-    check-month 1 - month-names nth ;
+
+: (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 )
+CONSTANT: day-names
-    {
+    { "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" }
-        "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"
-    } ;
-
-: day-name ( n -- string ) day-names nth ;
 
 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
+    year 100 /mod :> ( b c )
-    b 4 /mod :> e :> d
+    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 )
+GENERIC: beginning-of-year ( object -- new-timestamp )
-    beginning-of-month 1 >>month ;
+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 ;

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 ;
 

basis/channels/examples/examples.factor

@@ -25,12 +25,11 @@ IN: channels.examples
     ] 3keep filter ;
 
 :: (sieve) ( prime c -- )
-    [let | p [ c from ] 
+    c from :> p
-           newc [ <channel> ] |
+    <channel> :> newc
-        p prime to
+    p prime to
-        [ newc p c filter ] "Filter" spawn drop
+    [ newc p c filter ] "Filter" spawn drop
-        prime newc (sieve)
+    prime newc (sieve) ;
-    ] ;
 
 : sieve ( prime -- ) 
     #! Send prime numbers to 'prime' channel

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" }

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" get-remote-thread [
-        "remote-channels" 
+        [ channel-thread t ] "Remote channels" spawn-server
-        [ channel-process t ] "Remote channels" spawn-server
+        "remote-channels" register-remote-thread 
-        register-process 
     ] 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
+    [ id>> swap to-message boa ] keep send-message drop ;
-    node>> "remote-channels" <remote-process> 
-    send-synchronous no-channel = [ no-channel throw ] when ;
 
 M: remote-channel from ( remote-channel -- value )
-    [ [ \ from , id>> , ] { } make ] keep
+    [ id>> from-message boa ] keep send-message ;
-    node>> "remote-channels" <remote-process> 
-    send-synchronous dup no-channel = [ no-channel throw ] when* ;
 
 [
     H{ } clone \ remote-channels set-global

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

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

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

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

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 ;
+        class (boxer-quot) >>boxer-quot ;
-    
-GENERIC: align-offset ( offset class -- offset' )
 
-M: struct-slot-spec align-offset
+GENERIC: compute-slot-offset ( offset class -- offset' )
-    [ type>> c-type-align 8 * align ] keep
+
+: 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 )
+: compute-struct-offsets ( slots -- size )
-    0 [ align-offset ] reduce 8 align 8 /i ;
+    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: number binary-zero? 0 = ;
-M: struct binary-zero?
+M: struct binary-zero? >c-ptr [ 0 = ] all? ;
-    [ byte-length iota ] [ >c-ptr ] bi
-    [ <displaced-alien> *uchar zero? ] curry 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
+    scan-param suffix!
-    [ 8 <vector> ] over push-all
+    [ 8 <vector> ] append!
     [ parse-struct-slots` ] [ ] while
-    [ >array define-struct-class ] over push-all ;
+    [ >array define-struct-class ] append! ;
 
 USING: vocabs vocabs.loader ;
 

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

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 kernel namespaces cocoa.classes cocoa.runtime
-compiler.units math core-graphics.types ;
+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"
+    void
-    { "id" "SEL" "NSRect" }
+    { id SEL NSRect }
     [ gc "x" set 2drop ]
 } ;
 
@@ -30,8 +31,8 @@ CLASS: {
     { +name+ "Bar" }
 } {
     "bar"
-    "NSRect"
+    NSRect
-    { "id" "SEL" }
+    { id SEL }
     [ 2drop test-foo "x" get ]
 } ;
 
@@ -52,13 +53,13 @@ CLASS: {
     { +name+ "Bar" }
 } {
     "bar"
-    "NSRect"
+    NSRect
-    { "id" "SEL" }
+    { id SEL }
     [ 2drop test-foo "x" get ]
 } {
     "babb"
-    "int"
+    int
-    { "id" "SEL" "int" }
+    { id SEL int }
     [ 2nip sq ]
 } ;
 

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
 

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

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
+core-graphics.types stack-checker kernel math namespaces make
-strings words cocoa.runtime io macros memoize io.encodings.utf8
+quotations sequences strings words cocoa.runtime cocoa.types io
-effects libc libc.private lexer init core-foundation fry
+macros memoize io.encodings.utf8 effects layouts libc
-generalizations specialized-arrays ;
+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" }
+    { "c" c:char }
-    { "i" "int" }
+    { "i" c:int }
-    { "s" "short" }
+    { "s" c:short }
-    { "C" "uchar" }
+    { "C" c:uchar }
-    { "I" "uint" }
+    { "I" c:uint }
-    { "S" "ushort" }
+    { "S" c:ushort }
-    { "f" "float" }
+    { "f" c:float }
-    { "d" "double" }
+    { "d" c:double }
-    { "B" "bool" }
+    { "B" c:bool }
-    { "v" "void" }
+    { "v" c:void }
-    { "*" "char*" }
+    { "*" c:char* }
-    { "?" "unknown_type" }
+    { "?" unknown_type }
-    { "@" "id" }
+    { "@" id }
-    { "#" "Class" }
+    { "#" Class }
-    { ":" "SEL" }
+    { ":" SEL }
 }
-"ptrdiff_t" heap-size {
+cell {
     { 4 [ H{
-        { "l" "long" }
+        { "l" c:long }
-        { "q" "longlong" }
+        { "q" c:longlong }
-        { "L" "ulong" }
+        { "L" c:ulong }
-        { "Q" "ulonglong" }
+        { "Q" c:ulonglong }
     } ] }
     { 8 [ H{
-        { "l" "long32" }
+        { "l" long32 }
-        { "q" "long" }
+        { "q" long }
-        { "L" "ulong32" }
+        { "L" ulong32 }
-        { "Q" "ulong" }
+        { "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}" }
+        { NSPoint    "{_NSPoint=ff}" }
-        { "NSRect"     "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
+        { NSRect     "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
-        { "NSSize"     "{_NSSize=ff}" }
+        { NSSize     "{_NSSize=ff}" }
-        { "NSRange"    "{_NSRange=II}" }
+        { NSRange    "{_NSRange=II}" }
-        { "NSInteger"  "i" }
+        { NSInteger  "i" }
-        { "NSUInteger" "I" }
+        { NSUInteger "I" }
-        { "CGFloat"    "f" }
+        { CGFloat    "f" }
     } ] }
     { 8 [ H{
-        { "NSPoint"    "{CGPoint=dd}" }
+        { NSPoint    "{CGPoint=dd}" }
-        { "NSRect"     "{CGRect={CGPoint=dd}{CGSize=dd}}" }
+        { NSRect     "{CGRect={CGPoint=dd}{CGSize=dd}}" }
-        { "NSSize"     "{CGSize=dd}" }
+        { NSSize     "{CGSize=dd}" }
-        { "NSRange"    "{_NSRange=QQ}" }
+        { NSRange    "{_NSRange=QQ}" }
-        { "NSInteger"  "q" }
+        { NSInteger  "q" }
-        { "NSUInteger" "Q" }
+        { NSUInteger "Q" }
-        { "CGFloat"    "d" }
+        { 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 ;
 

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." }

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! ;

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

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 ;
 

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

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

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

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

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

@@ -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 f "malloc" { int } alien-invoke ]
-    [ "int" { "int" } "cdecl" alien-indirect ]
+    [ int { int } "cdecl" alien-indirect ]
-    [ "int" { "int" } "cdecl" [ ] alien-callback ]
+    [ 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

basis/compiler/cfg/builder/builder.factor

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

basis/compiler/cfg/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
+        V{ } clone >>predecessors ;
-        \ basic-block counter >>id ;
+
+M: basic-block hashcode* nip id>> ;
 
 TUPLE: cfg { entry basic-block } word label
 spill-area-size reps

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 -- )

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? ;
 

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 ;
 

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 ;

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 ]
+    dup insn-def-slot dup [
-    [ insn-def-slot [ name>> reader-word 1quotation ] [ [ drop f ] ] if* ] bi
+        [ \ defs-vreg create-method ]
-    define ;
+        [ name>> reader-word 1quotation ] bi*
+        define
+    ] [ 2drop ] if ;
 
 : define-uses-vregs-method ( insn -- )
-    [ \ uses-vregs create-method ]
+    dup insn-use-slots [ drop ] [
-    [ insn-use-slots [ name>> ] map slot-array-quot ] bi
+        [ \ uses-vregs create-method ]
-    define ;
+        [ [ name>> ] map slot-array-quot ] bi*
+        define
+    ] if-empty ;
 
 : define-temp-vregs-method ( insn -- )
-    [ \ temp-vregs create-method ]
+    dup insn-temp-slots [ drop ] [
-    [ insn-temp-slots [ name>> ] map slot-array-quot ] bi
+        [ \ temp-vregs create-method ]
-    define ;
+        [ [ name>> ] map slot-array-quot ] bi*
+        define
+    ] if-empty ;
 
 PRIVATE>
 

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

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences assocs fry
+USING: accessors kernel sequences assocs fry math
-cpu.architecture layouts
+cpu.architecture layouts namespaces
 compiler.cfg.rpo
 compiler.cfg.registers
 compiler.cfg.instructions
@@ -21,12 +21,14 @@ GENERIC: allocation-size* ( insn -- n )
 
 M: ##allot allocation-size* size>> ;
 
-M: ##box-alien allocation-size* drop 4 cells ;
+M: ##box-alien allocation-size* drop 5 cells ;
 
-M: ##box-displaced-alien allocation-size* drop 4 cells ;
+M: ##box-displaced-alien allocation-size* drop 5 cells ;
 
 : allocation-size ( bb -- n )
-    instructions>> [ ##allocation? ] filter [ allocation-size* ] 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 ;

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 ;

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

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 ] |
+    node node-input-infos :> infos
-        infos test call
+    infos test call
-        [ infos quot call ]
+    [ infos quot call ]
-        [ node emit-primitive ]
+    [ node emit-primitive ] if ; inline
-        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 ;

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

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

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

basis/compiler/cfg/intrinsics/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-vmin) [ [ generate-min-vector ] emit-binary-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vmax) [ [ ^^max-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-vlshift) [ [ ^^shl-vector-imm ] [ ^^shl-vector ] emit-shift-vector-op ] }
-        { math.vectors.simd.intrinsics:(simd-vrshift) [ [ ^^shr-vector ] emit-binary-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 ] emit-horizontal-shift ] }
+        { math.vectors.simd.intrinsics:(simd-hlshift) [ [ ^^horizontal-shl-vector-imm ] emit-shift-vector-imm-op ] }
-        { math.vectors.simd.intrinsics:(simd-hrshift) [ [ ^^horizontal-shr-vector ] emit-horizontal-shift ] }
+        { 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 ] }

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
+USING: namespaces layouts sequences kernel math accessors
-accessors compiler.tree.propagation.info
+compiler.tree.propagation.info compiler.cfg.stacks
-compiler.cfg.stacks compiler.cfg.hats
+compiler.cfg.hats compiler.cfg.instructions
-compiler.cfg.instructions compiler.cfg.utilities ;
+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 ;

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 ;
+FROM: alien.c-types => heap-size uchar ushort uint ulonglong float double ;
-SPECIALIZED-ARRAYS: 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 )
+:: ((generate-compare-vector)) ( src1 src2 rep {cc,swap} -- dst )
-    {cc,swap} first2 :> swap? :> cc
+    {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 )
+:: (generate-compare-vector) ( src1 src2 rep orig-cc -- dst )
-    rep orig-cc %compare-vector-ccs :> not? :> ccs
+    rep orig-cc %compare-vector-ccs :> ( ccs not? )
 
     ccs empty?
     [ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ]
     [
-        ccs unclip :> first-cc :> rest-ccs
+        ccs unclip :> ( rest-ccs first-cc )
-        src1 src2 rep first-cc (generate-compare-vector) :> first-dst
+        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 ;
+

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
+classes.algebra classes.builtin locals combinators
-compiler.tree.propagation.info compiler.cfg.stacks
+cpu.architecture compiler.tree.propagation.info
-compiler.cfg.hats compiler.cfg.registers
+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

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 {

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 ;

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

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 ]
+            [ ranges>> reverse! drop ]
-            [ uses>> reverse-here ]
+            [ 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

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 ;

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: D scan-word <ds-loc> suffix! ;
-SYNTAX: R scan-word <rs-loc> parsed ;
+SYNTAX: R scan-word <rs-loc> suffix! ;

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

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

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

@@ -11,6 +11,10 @@ GENERIC: defs-vreg-rep ( insn -- rep/f )
 GENERIC: temp-vreg-reps ( insn -- reps )
 GENERIC: uses-vreg-reps ( insn -- reps )
 
+M: insn defs-vreg-rep drop f ;
+M: insn temp-vreg-reps drop { } ;
+M: insn uses-vreg-reps drop { } ;
+
 <PRIVATE
 
 : rep-getter-quot ( rep -- quot )
@@ -21,12 +25,14 @@ GENERIC: uses-vreg-reps ( insn -- reps )
     } case ;
 
 : define-defs-vreg-rep-method ( insn -- )
-    [ \ defs-vreg-rep create-method ]
+    dup insn-def-slot dup [
-    [ insn-def-slot [ rep>> rep-getter-quot ] [ [ drop f ] ] if* ]
+        [ \ defs-vreg-rep create-method ]
-    bi define ;
+        [ 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 ]
+    dup insn-use-slots [ drop ] [
-    [ insn-use-slots reps-getter-quot ]
+        [ \ uses-vreg-reps create-method ]
-    bi define ;
+        [ reps-getter-quot ]
+        bi* define
+    ] if-empty ;
 
 : define-temp-vreg-reps-method ( insn -- )
-    [ \ temp-vreg-reps create-method ]
+    dup insn-temp-slots [ drop ] [
-    [ insn-temp-slots reps-getter-quot ]
+        [ \ temp-vreg-reps create-method ]
-    bi define ;
+        [ reps-getter-quot ]
+        bi* define
+    ] if-empty ;
 
 PRIVATE>
 

basis/compiler/cfg/representations/representations.factor

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

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 ;

basis/compiler/cfg/ssa/liveness/liveness.factor

@@ -121,10 +121,9 @@ PRIVATE>
 PRIVATE>
 
 :: live-out? ( vreg node -- ? )
-    [let | def [ vreg def-of ] |
+    vreg def-of :> def
-        {
+    {
-            { [ node def eq? ] [ vreg uses-of def only? not ] }
+        { [ node def eq? ] [ vreg uses-of def only? not ] }
-            { [ def node strictly-dominates? ] [ vreg node (live-out?) ] }
+        { [ def node strictly-dominates? ] [ vreg node (live-out?) ] }
-            [ f ]
+        [ f ]
-        } cond
+    } cond ;
-    ] ;

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&& ;

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
+    to predecessors>> [ dup froms member-eq? [ drop bb ] when ] map! drop
-    froms [ successors>> [ dup to eq? [ drop bb ] when ] change-each ] each ;
+    froms [ successors>> [ dup to eq? [ drop bb ] when ] map! drop ] each ;
 
 : add-instructions ( bb quot -- )
     [ instructions>> building ] dip '[

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 ;

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 = ]
+        [ src2>> \ f type-number = ]
-        [ cc>> { cc= cc/= } memq? ]
+        [ 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 ;

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

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

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 ;

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-shl-vector-imm %horizontal-shl-vector-imm
-CODEGEN: ##horizontal-shr-vector %horizontal-shr-vector
+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

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'.
-    [
+    {
-        {
+        [ drop no-compile? ]
-            [ macro? ]
+        [ [ combinator? ] [ unknown-macro-input? ] bi* and ]
-            [ inline? ]
+    } 2|| ;
-            [ no-compile? ]
-            [ "special" word-prop ]
-        } 1||
-    ] [
-        {
-            [ do-not-compile? ]
-            [ literal-expected? ]
-        } 1||
-    ] bi* and ;
 
 : 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
 

basis/compiler/constants/constants.factor

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

basis/compiler/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 ;

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
-

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 ]
+        [ 2 double "libm" "pow" { double double } alien-invoke ]
-        [ -0.5 "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

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: 8000000 ] [ HEX: -8000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
-[ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test
+[ HEX: 8000000 ] [ HEX: -7ffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test
 
-[ t ] [ 1 27 fixnum-shift dup [ fixnum+ ] compile-call 1 28 fixnum-shift = ] unit-test
+[ t ] [ 1 26 fixnum-shift dup [ fixnum+ ] compile-call 1 27 fixnum-shift = ] unit-test
-[ -268435457 ] [ 1 28 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
+[ -134217729 ] [ 1 27 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
 
 [ t ] [ 1 20 shift 1 20 shift [ fixnum* ] compile-call 1 40 shift = ] unit-test
 [ t ] [ 1 20 shift neg 1 20 shift [ fixnum* ] compile-call 1 40 shift neg = ] unit-test
 [ t ] [ 1 20 shift neg 1 20 shift neg [ fixnum* ] compile-call 1 40 shift = ] unit-test
 [ -351382792 ] [ -43922849 [ 3 fixnum-shift ] compile-call ] unit-test
 
-[ 268435456 ] [ -268435456 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
+[ 134217728 ] [ -134217728 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
 
-[ 268435456 0 ] [ -268435456 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
+[ 134217728 0 ] [ -134217728 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
 
 [ t ] [ f [ f eq? ] compile-call ] unit-test
 
@@ -285,8 +284,8 @@ cell 8 = [
 
 ! 64-bit overflow
 cell 8 = [
-    [ t ] [ 1 59 fixnum-shift dup [ fixnum+ ] compile-call 1 60 fixnum-shift = ] unit-test
+    [ t ] [ 1 58 fixnum-shift dup [ fixnum+ ] compile-call 1 59 fixnum-shift = ] unit-test
-    [ -1152921504606846977 ] [ 1 60 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
+    [ -576460752303423489 ] [ 1 59 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
     
     [ t ] [ 1 40 shift 1 40 shift [ fixnum* ] compile-call 1 80 shift = ] unit-test
     [ t ] [ 1 40 shift neg 1 40 shift [ fixnum* ] compile-call 1 80 shift neg = ] unit-test
@@ -301,9 +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
+        32 random-bits >fixnum
-        2dup
+        32 random-bits >fixnum
-        [ fixnum* ] 2keep compiled-fixnum* =
+        2dup [ fixnum* ] [ compiled-fixnum* ] 2bi 2dup =
-        [ 2drop ] [ "Oops" throw ] if
+        [ 2drop 2drop ] [ bug-in-fixnum* ] if
     ] times
 ] unit-test
 
@@ -419,7 +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

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

@@ -36,7 +36,7 @@ IN: compiler.tests.low-level-ir
 ! loading immediates
 [ f ] [
     V{
-        T{ ##load-immediate f 0 5 }
+        T{ ##load-immediate f 0 $[ \ f type-number ] }
     } compile-test-bb
 ] unit-test
 
@@ -50,7 +50,7 @@ IN: compiler.tests.low-level-ir
 ! one of the sources
 [ t ] [
     V{
-        T{ ##load-immediate f 1 $[ 2 cell log2 shift array tag-number - ] }
+        T{ ##load-immediate f 1 $[ 2 cell log2 shift array type-number - ] }
         T{ ##load-reference f 0 { t f t } }
         T{ ##slot f 0 0 1 }
     } compile-test-bb
@@ -59,13 +59,13 @@ IN: compiler.tests.low-level-ir
 [ t ] [
     V{
         T{ ##load-reference f 0 { t f t } }
-        T{ ##slot-imm f 0 0 2 $[ array tag-number ] }
+        T{ ##slot-imm f 0 0 2 $[ array type-number ] }
     } compile-test-bb
 ] unit-test
 
 [ t ] [
     V{
-        T{ ##load-immediate f 1 $[ 2 cell log2 shift array tag-number - ] }
+        T{ ##load-immediate f 1 $[ 2 cell log2 shift array type-number - ] }
         T{ ##load-reference f 0 { t f t } }
         T{ ##set-slot f 0 0 1 }
     } compile-test-bb
@@ -75,12 +75,12 @@ IN: compiler.tests.low-level-ir
 [ t ] [
     V{
         T{ ##load-reference f 0 { t f t } }
-        T{ ##set-slot-imm f 0 0 2 $[ array tag-number ] }
+        T{ ##set-slot-imm f 0 0 2 $[ array type-number ] }
     } compile-test-bb
     dup first eq?
 ] unit-test
 
-[ 8 ] [
+[ 4 ] [
     V{
         T{ ##load-immediate f 0 4 }
         T{ ##shl f 0 0 0 }
@@ -90,16 +90,16 @@ IN: compiler.tests.low-level-ir
 [ 4 ] [
     V{
         T{ ##load-immediate f 0 4 }
-        T{ ##shl-imm f 0 0 3 }
+        T{ ##shl-imm f 0 0 4 }
     } compile-test-bb
 ] unit-test
 
 [ 31 ] [
     V{
         T{ ##load-reference f 1 B{ 31 67 52 } }
-        T{ ##unbox-any-c-ptr f 0 1 2 }
+        T{ ##unbox-any-c-ptr f 0 1 }
         T{ ##alien-unsigned-1 f 0 0 0 }
-        T{ ##shl-imm f 0 0 3 }
+        T{ ##shl-imm f 0 0 4 }
     } compile-test-bb
 ] unit-test
 
@@ -108,13 +108,13 @@ IN: compiler.tests.low-level-ir
         T{ ##load-reference f 0 "hello world" }
         T{ ##load-immediate f 1 3 }
         T{ ##string-nth f 0 0 1 2 }
-        T{ ##shl-imm f 0 0 3 }
+        T{ ##shl-imm f 0 0 4 }
     } compile-test-bb
 ] unit-test
 
 [ 1 ] [
     V{
-        T{ ##load-immediate f 0 16 }
+        T{ ##load-immediate f 0 32 }
-        T{ ##add-imm f 0 0 -8 }
+        T{ ##add-imm f 0 0 -16 }
     } compile-test-bb
 ] unit-test

basis/compiler/tests/optimizer.factor

@@ -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

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
+[ t ] [ object \ sheeple method \ sheeple-test compiled-use? ] unit-test
-[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] 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
+[ f ] [ object \ sheeple method \ sheeple-test compiled-use? ] unit-test
-[ t ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] 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
+[ t ] [ object \ sheeple method \ sheeple-test compiled-use? ] unit-test
-[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
+[ f ] [ empty-mixin \ sheeple method \ sheeple-test compiled-use? ] unit-test

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

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?

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 ;

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
 

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 ;

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 )

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 ]
+    inputs outputs filter-corresponding make-values :> new-live-outputs
-            live-outputs [ outputs filter-live ] |
+    outputs filter-live :> live-outputs
-        new-live-outputs
+    new-live-outputs
-        live-outputs
+    live-outputs
-        live-outputs
+    live-outputs
-        new-live-outputs
+    new-live-outputs
-        drop-values
+    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 ]
+    node [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs :> shuffle
-            new-outputs [ shuffle out-d>> ] |
+    shuffle out-d>> :> new-outputs
-        node new-outputs
+    node new-outputs
-        [ [ label>> enter-recursive>> ] dip >>in-d drop ] [ >>in-d drop ] 2bi
+    [ [ label>> enter-recursive>> ] dip >>in-d drop ] [ >>in-d drop ] 2bi
-        shuffle
+    shuffle ;
-    ] ;
 
 :: drop-recursive-outputs ( node -- shuffle )
-    [let* | return [ node label>> return>> ]
+    node label>> return>> :> return
-            new-inputs [ return in-d>> filter-live ]
+    return in-d>> filter-live :> new-inputs
-            new-outputs [ return [ in-d>> ] [ out-d>> ] bi filter-corresponding ] |
+    return [ in-d>> ] [ out-d>> ] bi filter-corresponding :> new-outputs
-        return
+    return
-        [ new-inputs >>in-d new-outputs >>out-d drop ]
+    [ new-inputs >>in-d new-outputs >>out-d drop ]
-        [ drop-dead-outputs ]
+    [ drop-dead-outputs ]
-        bi
+    bi ;
-    ] ;
 
 M: #recursive remove-dead-code* ( node -- nodes )
     [ drop-recursive-inputs ]

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 ]
+    outputs make-values :> new-outputs
-            live-outputs [ outputs filter-live ] |
+    outputs filter-live :> live-outputs
-        new-outputs
+    new-outputs
-        live-outputs
+    live-outputs
-        outputs
+    outputs
-        new-outputs
+    new-outputs
-        drop-values
+    drop-values ;
-    ] ;
 
 : drop-dead-outputs ( node -- #shuffle )
     dup out-d>> drop-dead-values [ in-d>> >>out-d drop ] keep ;

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 ] }

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*
     {

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 } { } }
             [

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