Merge branch 'master' of git://factorcode.org/git/factor

basis/alarms/alarms-tests.factor

@@ -1,6 +1,6 @@
-IN: alarms.tests
 USING: alarms alarms.private kernel calendar sequences
 tools.test threads concurrency.count-downs ;
+IN: alarms.tests
 
 [ ] [
     1 <count-down>

basis/alarms/alarms.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays calendar combinators generic init
+USING: accessors assocs boxes calendar
-kernel math namespaces sequences heaps boxes threads
+combinators.short-circuit fry heaps init kernel math.order
-quotations assocs math.order ;
+namespaces quotations threads ;
 IN: alarms
 
 TUPLE: alarm
@@ -21,21 +21,21 @@ SYMBOL: alarm-thread
 
 ERROR: bad-alarm-frequency frequency ;
 : check-alarm ( frequency/f -- frequency/f )
-    dup [ duration? ] [ not ] bi or [ bad-alarm-frequency ] unless ;
+    dup { [ duration? ] [ not ] } 1|| [ bad-alarm-frequency ] unless ;
 
 : <alarm> ( quot time frequency -- alarm )
     check-alarm <box> alarm boa ;
 
 : register-alarm ( alarm -- )
-    dup dup time>> alarms get-global heap-push*
+    [ dup time>> alarms get-global heap-push* ]
-    swap entry>> >box
+    [ entry>> >box ] bi
     notify-alarm-thread ;
 
 : alarm-expired? ( alarm now -- ? )
     [ time>> ] dip before=? ;
 
 : reschedule-alarm ( alarm -- )
-    dup [ swap interval>> time+ now max ] change-time register-alarm ;
+    dup '[ _ interval>> time+ now max ] change-time register-alarm ;
 
 : call-alarm ( alarm -- )
     [ entry>> box> drop ]

basis/alien/arrays/arrays-docs.factor

@@ -4,4 +4,9 @@ USING: help.syntax help.markup byte-arrays alien.c-types ;
 ARTICLE: "c-arrays" "C arrays"
 "C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."
 $nl
-"C type specifiers for array types are documented in " { $link "c-types-specs" } "." ;
+"C type specifiers for array types are documented in " { $link "c-types-specs" } "."
+$nl
+"Specialized sequences are provided for accessing memory as an array of primitive type values. These sequences are implemented in the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "specialized-arrays.direct" } " vocabulary sets. They can also be loaded and constructed through their primitive C types:"
+{ $subsection require-c-type-arrays }
+{ $subsection <c-type-array> }
+{ $subsection <c-type-direct-array> } ;

basis/alien/arrays/arrays.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.strings alien.c-types alien.accessors alien.structs
 arrays words sequences math kernel namespaces fry libc cpu.architecture
-io.encodings.utf8 ;
+io.encodings.utf8 accessors ;
 IN: alien.arrays
 
 UNION: value-type array struct-type ;
@@ -11,7 +11,12 @@ M: array c-type ;
 
 M: array c-type-class drop object ;
 
-M: array heap-size unclip [ product ] [ heap-size ] bi* * ;
+M: array c-type-boxed-class drop object ;
+
+: array-length ( seq -- n )
+    [ dup word? [ def>> call( -- object ) ] when ] [ * ] map-reduce ;
+
+M: array heap-size unclip [ array-length ] [ heap-size ] bi* * ;
 
 M: array c-type-align first c-type-align ;
 
@@ -27,11 +32,15 @@ M: array box-return drop "void*" box-return ;
 
 M: array stack-size drop "void*" stack-size ;
 
-M: array c-type-boxer-quot drop [ ] ;
+M: array c-type-boxer-quot
+    unclip
+    [ array-length ]
+    [ [ require-c-type-arrays ] keep ] bi*
+    [ <c-type-direct-array> ] 2curry ;
 
 M: array c-type-unboxer-quot drop [ >c-ptr ] ;
 
-M: value-type c-type-reg-class drop int-regs ;
+M: value-type c-type-rep drop int-rep ;
 
 M: value-type c-type-getter
     drop [ swap <displaced-alien> ] ;
@@ -45,8 +54,9 @@ PREDICATE: string-type < pair
 
 M: string-type c-type ;
 
-M: string-type c-type-class
+M: string-type c-type-class drop object ;
-    drop object ;
+
+M: string-type c-type-boxed-class drop object ;
 
 M: string-type heap-size
     drop "void*" heap-size ;
@@ -72,8 +82,8 @@ M: string-type box-return
 M: string-type stack-size
     drop "void*" stack-size ;
 
-M: string-type c-type-reg-class
+M: string-type c-type-rep
-    drop int-regs ;
+    drop int-rep ;
 
 M: string-type c-type-boxer
     drop "void*" c-type-boxer ;

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

@@ -1,7 +1,7 @@
 IN: alien.c-types
 USING: alien help.syntax help.markup libc kernel.private
 byte-arrays math strings hashtables alien.syntax alien.strings sequences
-io.encodings.string debugger destructors ;
+io.encodings.string debugger destructors vocabs.loader ;
 
 HELP: <c-type>
 { $values { "type" hashtable } }
@@ -128,6 +128,21 @@ HELP: malloc-string
     }
 } ;
 
+HELP: require-c-type-arrays
+{ $values { "c-type" "a C type" } }
+{ $description { $link require } "s any unloaded vocabularies needed to construct a specialized array or direct array of " { $snippet "c-type" } " using the " { $link <c-type-array> } " or " { $link <c-type-direct-array> } " vocabularies." }
+{ $notes "This word must be called inside a compilation unit. See the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "specialized-arrays.direct" } " vocabulary sets for details on the underlying sequence types loaded." } ;
+
+HELP: <c-type-array>
+{ $values { "len" integer } { "c-type" "a C type" } { "array" "a specialized array" } }
+{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } "." }
+{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-type-arrays } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." } ;
+
+HELP: <c-type-direct-array>
+{ $values { "alien" c-ptr } { "len" integer } { "c-type" "a C type" } { "array" "a specialized direct array" } }
+{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } " over the range of memory referenced by " { $snippet "alien" } "." }
+{ $notes "The appropriate direct specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-type-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." } ;
+
 ARTICLE: "c-strings" "C strings"
 "C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
 $nl

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

@@ -1,10 +1,10 @@
-IN: alien.c-types.tests
 USING: alien alien.syntax alien.c-types kernel tools.test
 sequences system libc alien.strings io.encodings.utf8 ;
+IN: alien.c-types.tests
 
 CONSTANT: xyz 123
 
-[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
+[ 492 ] [ { "int" xyz } heap-size ] unit-test
 
 [ -1 ] [ -1 <char> *char ] unit-test
 [ -1 ] [ -1 <short> *short ] unit-test

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

@@ -5,7 +5,7 @@ namespaces make parser sequences strings words splitting math.parser
 cpu.architecture alien alien.accessors alien.strings quotations
 layouts system compiler.units io io.files io.encodings.binary
 io.streams.memory accessors combinators effects continuations fry
-classes ;
+classes vocabs vocabs.loader ;
 IN: alien.c-types
 
 DEFER: <int>
@@ -13,17 +13,25 @@ DEFER: *char
 
 : little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
 
-TUPLE: c-type
+TUPLE: abstract-c-type
 { class class initial: object }
-boxer
+{ boxed-class class initial: object }
 { boxer-quot callable }
-unboxer
 { unboxer-quot callable }
 { getter callable }
 { setter callable }
-{ reg-class initial: int-regs }
 size
 align
+array-class
+array-constructor
+direct-array-class
+direct-array-constructor
+sequence-mixin-class ;
+
+TUPLE: c-type < abstract-c-type
+boxer
+unboxer
+{ rep initial: int-rep }
 stack-align? ;
 
 : <c-type> ( -- type )
@@ -68,12 +76,63 @@ M: string c-type ( name -- type )
         ] ?if
     ] if ;
 
+: ?require-word ( word/pair -- )
+    dup word? [ drop ] [ first require ] ?if ;
+
+GENERIC: require-c-type-arrays ( c-type -- )
+
+M: object require-c-type-arrays
+    drop ;
+
+M: c-type require-c-type-arrays
+    [ array-class>> ?require-word ]
+    [ sequence-mixin-class>> ?require-word ]
+    [ direct-array-class>> ?require-word ] tri ;
+
+M: string require-c-type-arrays
+    c-type require-c-type-arrays ;
+
+M: array require-c-type-arrays
+    first c-type require-c-type-arrays ;
+
+ERROR: specialized-array-vocab-not-loaded vocab word ;
+
+: c-type-array-constructor ( c-type -- word )
+    array-constructor>> dup array?
+    [ first2 specialized-array-vocab-not-loaded ] when ; foldable
+
+: c-type-direct-array-constructor ( c-type -- word )
+    direct-array-constructor>> dup array?
+    [ first2 specialized-array-vocab-not-loaded ] when ; foldable
+
+GENERIC: <c-type-array> ( len c-type -- array )
+M: object <c-type-array>
+    c-type-array-constructor execute( len -- array ) ; inline
+M: string <c-type-array>
+    c-type <c-type-array> ; inline
+M: array <c-type-array>
+    first c-type <c-type-array> ; inline
+
+GENERIC: <c-type-direct-array> ( alien len c-type -- array )
+M: object <c-type-direct-array>
+    c-type-direct-array-constructor execute( alien len -- array ) ; inline
+M: string <c-type-direct-array>
+    c-type <c-type-direct-array> ; inline
+M: array <c-type-direct-array>
+    first c-type <c-type-direct-array> ; inline
+
 GENERIC: c-type-class ( name -- class )
 
-M: c-type c-type-class class>> ;
+M: abstract-c-type c-type-class class>> ;
 
 M: string c-type-class c-type c-type-class ;
 
+GENERIC: c-type-boxed-class ( name -- class )
+
+M: abstract-c-type c-type-boxed-class boxed-class>> ;
+
+M: string c-type-boxed-class c-type c-type-boxed-class ;
+
 GENERIC: c-type-boxer ( name -- boxer )
 
 M: c-type c-type-boxer boxer>> ;
@@ -82,7 +141,7 @@ M: string c-type-boxer c-type c-type-boxer ;
 
 GENERIC: c-type-boxer-quot ( name -- quot )
 
-M: c-type c-type-boxer-quot boxer-quot>> ;
+M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
 
 M: string c-type-boxer-quot c-type c-type-boxer-quot ;
 
@@ -94,15 +153,15 @@ M: string c-type-unboxer c-type c-type-unboxer ;
 
 GENERIC: c-type-unboxer-quot ( name -- quot )
 
-M: c-type c-type-unboxer-quot unboxer-quot>> ;
+M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
 
 M: string c-type-unboxer-quot c-type c-type-unboxer-quot ;
 
-GENERIC: c-type-reg-class ( name -- reg-class )
+GENERIC: c-type-rep ( name -- rep )
 
-M: c-type c-type-reg-class reg-class>> ;
+M: c-type c-type-rep rep>> ;
 
-M: string c-type-reg-class c-type c-type-reg-class ;
+M: string c-type-rep c-type c-type-rep ;
 
 GENERIC: c-type-getter ( name -- quot )
 
@@ -118,7 +177,7 @@ M: string c-type-setter c-type c-type-setter ;
 
 GENERIC: c-type-align ( name -- n )
 
-M: c-type c-type-align align>> ;
+M: abstract-c-type c-type-align align>> ;
 
 M: string c-type-align c-type c-type-align ;
 
@@ -129,13 +188,11 @@ M: c-type c-type-stack-align? stack-align?>> ;
 M: string c-type-stack-align? c-type c-type-stack-align? ;
 
 : c-type-box ( n type -- )
-    dup c-type-reg-class
+    [ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
-    swap c-type-boxer [ "No boxer" throw ] unless*
     %box ;
 
 : c-type-unbox ( n ctype -- )
-    dup c-type-reg-class
+    [ c-type-rep ] [ c-type-unboxer [ "No unboxer" throw ] unless* ] bi
-    swap c-type-unboxer [ "No unboxer" throw ] unless*
     %unbox ;
 
 GENERIC: box-parameter ( n ctype -- )
@@ -169,7 +226,7 @@ GENERIC: heap-size ( type -- size ) foldable
 
 M: string heap-size c-type heap-size ;
 
-M: c-type heap-size size>> ;
+M: abstract-c-type heap-size size>> ;
 
 GENERIC: stack-size ( type -- size ) foldable
 
@@ -179,9 +236,9 @@ M: c-type stack-size size>> cell align ;
 
 GENERIC: byte-length ( seq -- n ) flushable
 
-M: byte-array byte-length length ;
+M: byte-array byte-length length ; inline
 
-M: f byte-length drop 0 ;
+M: f byte-length drop 0 ; inline
 
 : c-getter ( name -- quot )
     c-type-getter [
@@ -224,7 +281,7 @@ M: memory-stream stream-read
     ] [ [ + ] change-index drop ] 2bi ;
 
 : byte-array>memory ( byte-array base -- )
-    swap dup byte-length memcpy ;
+    swap dup byte-length memcpy ; inline
 
 : array-accessor ( type quot -- def )
     [
@@ -269,23 +326,42 @@ M: long-long-type box-return ( type -- )
     [ define-out ]
     tri ;
 
-: expand-constants ( c-type -- c-type' )
-    dup array? [
-        unclip [
-            [
-                dup word? [
-                    def>> call( -- object )
-                ] when
-            ] map
-        ] dip prefix
-    ] when ;
-
 : malloc-file-contents ( path -- alien len )
     binary file-contents [ malloc-byte-array ] [ length ] bi ;
 
 : if-void ( type true false -- )
     pick "void" = [ drop nip call ] [ nip call ] if ; inline
 
+: ?lookup ( vocab word -- word/pair )
+    over vocab [ swap lookup ] [ 2array ] if ;
+
+: set-array-class* ( c-type vocab-stem type-stem -- c-type )
+    {
+        [
+            [ "specialized-arrays." prepend ]
+            [ "-array" append ] bi* ?lookup >>array-class
+        ]
+        [
+            [ "specialized-arrays." prepend ]
+            [ "<" "-array>" surround ] bi* ?lookup >>array-constructor
+        ]
+        [
+            [ "specialized-arrays." prepend ]
+            [ "-sequence" append ] bi* ?lookup >>sequence-mixin-class
+        ]
+        [
+            [ "specialized-arrays.direct." prepend ]
+            [ "direct-" "-array" surround ] bi* ?lookup >>direct-array-class
+        ]
+        [
+            [ "specialized-arrays.direct." prepend ]
+            [ "<direct-" "-array>" surround ] bi* ?lookup >>direct-array-constructor
+        ]
+    } 2cleave ;
+
+: set-array-class ( c-type stem -- c-type )
+    dup set-array-class* ;
+
 CONSTANT: primitive-types
     {
         "char" "uchar"
@@ -300,6 +376,7 @@ CONSTANT: primitive-types
 [
     <c-type>
         c-ptr >>class
+        c-ptr >>boxed-class
         [ alien-cell ] >>getter
         [ [ >c-ptr ] 2dip set-alien-cell ] >>setter
         bootstrap-cell >>size
@@ -307,106 +384,127 @@ CONSTANT: primitive-types
         [ >c-ptr ] >>unboxer-quot
         "box_alien" >>boxer
         "alien_offset" >>unboxer
+        "alien" "void*" set-array-class*
     "void*" define-primitive-type
 
     <long-long-type>
         integer >>class
+        integer >>boxed-class
         [ alien-signed-8 ] >>getter
         [ set-alien-signed-8 ] >>setter
         8 >>size
         8 >>align
         "box_signed_8" >>boxer
         "to_signed_8" >>unboxer
+        "longlong" set-array-class
     "longlong" define-primitive-type
 
     <long-long-type>
         integer >>class
+        integer >>boxed-class
         [ alien-unsigned-8 ] >>getter
         [ set-alien-unsigned-8 ] >>setter
         8 >>size
         8 >>align
         "box_unsigned_8" >>boxer
         "to_unsigned_8" >>unboxer
+        "ulonglong" set-array-class
     "ulonglong" define-primitive-type
 
     <c-type>
         integer >>class
+        integer >>boxed-class
         [ alien-signed-cell ] >>getter
         [ set-alien-signed-cell ] >>setter
         bootstrap-cell >>size
         bootstrap-cell >>align
         "box_signed_cell" >>boxer
         "to_fixnum" >>unboxer
+        "long" set-array-class
     "long" define-primitive-type
 
     <c-type>
         integer >>class
+        integer >>boxed-class
         [ alien-unsigned-cell ] >>getter
         [ set-alien-unsigned-cell ] >>setter
         bootstrap-cell >>size
         bootstrap-cell >>align
         "box_unsigned_cell" >>boxer
         "to_cell" >>unboxer
+        "ulong" set-array-class
     "ulong" define-primitive-type
 
     <c-type>
         integer >>class
+        integer >>boxed-class
         [ alien-signed-4 ] >>getter
         [ set-alien-signed-4 ] >>setter
         4 >>size
         4 >>align
         "box_signed_4" >>boxer
         "to_fixnum" >>unboxer
+        "int" set-array-class
     "int" define-primitive-type
 
     <c-type>
         integer >>class
+        integer >>boxed-class
         [ alien-unsigned-4 ] >>getter
         [ set-alien-unsigned-4 ] >>setter
         4 >>size
         4 >>align
         "box_unsigned_4" >>boxer
         "to_cell" >>unboxer
+        "uint" set-array-class
     "uint" define-primitive-type
 
     <c-type>
         fixnum >>class
+        fixnum >>boxed-class
         [ alien-signed-2 ] >>getter
         [ set-alien-signed-2 ] >>setter
         2 >>size
         2 >>align
         "box_signed_2" >>boxer
         "to_fixnum" >>unboxer
+        "short" set-array-class
     "short" define-primitive-type
 
     <c-type>
         fixnum >>class
+        fixnum >>boxed-class
         [ alien-unsigned-2 ] >>getter
         [ set-alien-unsigned-2 ] >>setter
         2 >>size
         2 >>align
         "box_unsigned_2" >>boxer
         "to_cell" >>unboxer
+        "ushort" set-array-class
     "ushort" define-primitive-type
 
     <c-type>
         fixnum >>class
+        fixnum >>boxed-class
         [ alien-signed-1 ] >>getter
         [ set-alien-signed-1 ] >>setter
         1 >>size
         1 >>align
         "box_signed_1" >>boxer
         "to_fixnum" >>unboxer
+        "char" set-array-class
     "char" define-primitive-type
 
     <c-type>
         fixnum >>class
+        fixnum >>boxed-class
         [ alien-unsigned-1 ] >>getter
         [ set-alien-unsigned-1 ] >>setter
         1 >>size
         1 >>align
         "box_unsigned_1" >>boxer
         "to_cell" >>unboxer
+        "uchar" set-array-class
     "uchar" define-primitive-type
 
     <c-type>
@@ -416,33 +514,39 @@ CONSTANT: primitive-types
         1 >>align
         "box_boolean" >>boxer
         "to_boolean" >>unboxer
+        "bool" set-array-class
     "bool" define-primitive-type
 
     <c-type>
         float >>class
+        float >>boxed-class
         [ alien-float ] >>getter
         [ [ >float ] 2dip set-alien-float ] >>setter
         4 >>size
         4 >>align
         "box_float" >>boxer
         "to_float" >>unboxer
-        single-float-regs >>reg-class
+        single-float-rep >>rep
         [ >float ] >>unboxer-quot
+        "float" set-array-class
     "float" define-primitive-type
 
     <c-type>
         float >>class
+        float >>boxed-class
         [ alien-double ] >>getter
         [ [ >float ] 2dip set-alien-double ] >>setter
         8 >>size
         8 >>align
         "box_double" >>boxer
         "to_double" >>unboxer
-        double-float-regs >>reg-class
+        double-float-rep >>rep
         [ >float ] >>unboxer-quot
+        "double" set-array-class
     "double" define-primitive-type
 
     "long" "ptrdiff_t" typedef
     "long" "intptr_t" typedef
     "ulong" "size_t" typedef
 ] with-compilation-unit
+

basis/alien/complex/complex-tests.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: tools.test alien.complex kernel alien.c-types alien.syntax
-namespaces ;
+namespaces math ;
 IN: alien.complex.tests
 
 C-STRUCT: complex-holder
@@ -16,3 +16,7 @@ C-STRUCT: complex-holder
 ] unit-test
 
 [ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test
+
+[ number ] [ "complex-float" c-type-boxed-class ] unit-test
+
+[ number ] [ "complex-double" c-type-boxed-class ] unit-test

basis/alien/complex/complex.factor

@@ -10,4 +10,4 @@ IN: alien.complex
 ! This overrides the fact that small structures are never returned
 ! in registers on NetBSD, Linux and Solaris running on 32-bit x86.
 "complex-float" c-type t >>return-in-registers? drop
- >>
+>>

basis/alien/complex/functor/functor-tests.factor

@@ -1,4 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test alien.complex.functor ;
-IN: alien.complex.functor.tests

basis/alien/complex/functor/functor.factor

@@ -30,6 +30,8 @@ define-struct
 T c-type
 <T> 1quotation >>unboxer-quot
 *T 1quotation >>boxer-quot
+number >>boxed-class
+T set-array-class
 drop
 
 ;FUNCTOR

basis/alien/destructors/destructors-tests.factor

@@ -1,4 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test alien.destructors ;
-IN: alien.destructors.tests

basis/alien/destructors/destructors.factor

@@ -4,7 +4,7 @@ USING: functors destructors accessors kernel parser words
 effects generalizations sequences ;
 IN: alien.destructors
 
-SLOT: alien
+TUPLE: alien-destructor alien ;
 
 FUNCTOR: define-destructor ( F -- )
 
@@ -16,11 +16,12 @@ N [ F stack-effect out>> length ]
 
 WHERE
 
-TUPLE: F-destructor alien disposed ;
+TUPLE: F-destructor < alien-destructor ;
 
-: <F-destructor> ( alien -- destructor ) f F-destructor boa ; inline
+: <F-destructor> ( alien -- destructor )
+    F-destructor boa ; inline
 
-M: F-destructor dispose* alien>> F N ndrop ;
+M: F-destructor dispose alien>> F N ndrop ;
 
 : &F ( alien -- alien ) dup <F-destructor> &dispose drop ; inline
 

basis/alien/fortran/fortran.factor

@@ -357,15 +357,15 @@ M: character-type (<fortran-result>)
 
 : (shuffle-map) ( return parameters -- ret par )
     [
-        fortran-ret-type>c-type length swap "void" = [ 1+ ] unless
+        fortran-ret-type>c-type length swap "void" = [ 1 + ] unless
         letters swap head [ "ret" swap suffix ] map
     ] [
-        [ fortran-arg-type>c-type nip length 1+ ] map letters swap zip
+        [ fortran-arg-type>c-type nip length 1 + ] map letters swap zip
         [ first2 letters swap head [ "" 2sequence ] with map ] map concat
     ] bi* ;
 
 : (fortran-in-shuffle) ( ret par -- seq )
-    [ [ second ] bi@ <=> ] sort append ;
+    [ second ] sort-with append ;
 
 : (fortran-out-shuffle) ( ret par -- seq )
     append ;

basis/alien/libraries/libraries-tests.factor

@@ -1,5 +1,5 @@
-IN: alien.libraries.tests
 USING: alien.libraries alien.syntax tools.test kernel ;
+IN: alien.libraries.tests
 
 [ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test
 

basis/alien/structs/fields/fields.factor

@@ -7,16 +7,16 @@ IN: alien.structs.fields
 TUPLE: field-spec name offset type reader writer ;
 
 : reader-word ( class name vocab -- word )
-    [ "-" glue ] dip create ;
+    [ "-" glue ] dip create dup make-deprecated ;
 
 : writer-word ( class name vocab -- word )
-    [ [ swap "set-" % % "-" % % ] "" make ] dip create ;
+    [ [ swap "set-" % % "-" % % ] "" make ] dip create dup make-deprecated ;
 
 : <field-spec> ( struct-name vocab type field-name -- spec )
     field-spec new
         0 >>offset
         swap >>name
-        swap expand-constants >>type
+        swap >>type
         3dup name>> swap reader-word >>reader
         3dup name>> swap writer-word >>writer
     2nip ;

basis/alien/structs/structs-tests.factor

@@ -1,6 +1,6 @@
-IN: alien.structs.tests
 USING: alien alien.syntax alien.c-types kernel tools.test
 sequences system libc words vocabs namespaces layouts ;
+IN: alien.structs.tests
 
 C-STRUCT: bar
     { "int" "x" }

basis/alien/structs/structs.factor

@@ -6,30 +6,12 @@ alien.c-types alien.structs.fields cpu.architecture math.order
 quotations byte-arrays ;
 IN: alien.structs
 
-TUPLE: struct-type
+TUPLE: struct-type < abstract-c-type fields return-in-registers? ;
-size
-align
-fields
-{ boxer-quot callable }
-{ unboxer-quot callable }
-{ getter callable }
-{ setter callable }
-return-in-registers? ;
 
 M: struct-type c-type ;
 
-M: struct-type heap-size size>> ;
-
-M: struct-type c-type-class drop byte-array ;
-
-M: struct-type c-type-align align>> ;
-
 M: struct-type c-type-stack-align? drop f ;
 
-M: struct-type c-type-boxer-quot boxer-quot>> ;
-
-M: struct-type c-type-unboxer-quot unboxer-quot>> ;
-
 : if-value-struct ( ctype true false -- )
     [ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline
 
@@ -53,9 +35,10 @@ M: struct-type stack-size
 
 : c-struct? ( type -- ? ) (c-type) struct-type? ;
 
-: (define-struct) ( name size align fields -- )
+: (define-struct) ( name size align fields class -- )
-    [ [ align ] keep ] dip
+    [ [ align ] keep ] 2dip new
-    struct-type new
+        byte-array >>class
+        byte-array >>boxed-class
         swap >>fields
         swap >>align
         swap >>size
@@ -71,14 +54,16 @@ M: struct-type stack-size
     [ 2drop ] [ make-fields ] 3bi
     [ struct-offsets ] keep
     [ [ type>> ] map compute-struct-align ] keep
-    [ (define-struct) ] keep
+    [ struct-type (define-struct) ] keep
-    [ define-field ] each ;
+    [ define-field ] each ; deprecated
 
 : define-union ( name members -- )
-    [ expand-constants ] map
     [ [ heap-size ] [ max ] map-reduce ] keep
-    compute-struct-align f (define-struct) ;
+    compute-struct-align f struct-type (define-struct) ; deprecated
 
 : offset-of ( field struct -- offset )
     c-types get at fields>> 
     [ name>> = ] with find nip offset>> ;
+
+USE: vocabs.loader
+"struct-arrays" require

basis/alien/syntax/syntax-docs.factor

@@ -1,6 +1,6 @@
 IN: alien.syntax
 USING: alien alien.c-types alien.parser alien.structs
-help.markup help.syntax ;
+classes.struct help.markup help.syntax ;
 
 HELP: DLL"
 { $syntax "DLL\" path\"" }
@@ -55,12 +55,14 @@ HELP: TYPEDEF:
 { $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
 
 HELP: C-STRUCT:
+{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: STRUCT: } " word." }
 { $syntax "C-STRUCT: name pairs... ;" }
 { $values { "name" "a new C type name" } { "pairs" "C type / field name string pairs" } }
 { $description "Defines a C struct layout and accessor words." }
 { $notes "C type names are documented in " { $link "c-types-specs" } "." } ;
 
 HELP: C-UNION:
+{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: UNION-STRUCT: } " word." }
 { $syntax "C-UNION: name members... ;" }
 { $values { "name" "a new C type name" } { "members" "a sequence of C types" } }
 { $description "Defines a new C type sized to fit its largest member." }

basis/alien/syntax/syntax.factor

@@ -22,17 +22,19 @@ SYNTAX: TYPEDEF:
     scan scan typedef ;
 
 SYNTAX: C-STRUCT:
-    scan current-vocab parse-definition define-struct ;
+    scan current-vocab parse-definition define-struct ; deprecated
 
 SYNTAX: C-UNION:
-    scan parse-definition define-union ;
+    scan parse-definition define-union ; deprecated
 
 SYNTAX: C-ENUM:
     ";" parse-tokens
     [ [ create-in ] dip define-constant ] each-index ;
 
+ERROR: no-such-symbol name library ;
+
 : address-of ( name library -- value )
-    load-library dlsym [ "No such symbol" throw ] unless* ;
+    2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;
 
 SYNTAX: &:
     scan "c-library" get '[ _ _ address-of ] over push-all ;

basis/ascii/ascii-tests.factor

@@ -10,7 +10,7 @@ IN: ascii.tests
 
 [ 4 ] [
     0 "There are Four Upper Case characters"
-    [ LETTER? [ 1+ ] when ] each
+    [ LETTER? [ 1 + ] when ] each
 ] unit-test
 
 [ t f ] [ CHAR: \s ascii? 400 ascii? ] unit-test

basis/base64/base64.factor

@@ -34,7 +34,7 @@ SYMBOL: column
 : write1-lines ( ch -- )
     write1
     column get [
-        1+ [ 76 = [ crlf ] when ]
+        1 + [ 76 = [ crlf ] when ]
         [ 76 mod column set ] bi
     ] when* ;
 
@@ -48,7 +48,7 @@ SYMBOL: column
 
 : encode-pad ( seq n -- )
     [ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
-    [ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
+    [ 1 + ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
 
 : decode4 ( seq -- )
     [ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]

basis/biassocs/biassocs-tests.factor

@@ -1,5 +1,5 @@
+USING: biassocs assocs namespaces tools.test hashtables kernel ;
 IN: biassocs.tests
-USING: biassocs assocs namespaces tools.test ;
 
 <bihash> "h" set
 
@@ -30,3 +30,13 @@ H{ { "a" "A" } { "b" "B" } } "a" set
 [ "A" ] [ "a" "b" get at ] unit-test
 
 [ "a" ] [ "A" "b" get value-at ] unit-test
+
+[ ] [ H{ { 1 2 } } >biassoc "h" set ] unit-test
+
+[ ] [ "h" get clone "g" set ] unit-test
+
+[ ] [ 3 4 "g" get set-at ] unit-test
+
+[ H{ { 1 2 } } ] [ "h" get >hashtable ] unit-test
+
+[ H{ { 1 2 } { 4 3 } } ] [ "g" get >hashtable ] unit-test

basis/biassocs/biassocs.factor

@@ -44,3 +44,6 @@ INSTANCE: biassoc assoc
 
 : >biassoc ( assoc -- biassoc )
     T{ biassoc } assoc-clone-like ;
+
+M: biassoc clone
+    [ from>> ] [ to>> ] bi [ clone ] bi@ biassoc boa ;

basis/binary-search/binary-search-tests.factor

@@ -1,5 +1,5 @@
-IN: binary-search.tests
 USING: binary-search math.order vectors kernel tools.test ;
+IN: binary-search.tests
 
 [ f ] [ 3 { } [ <=> ] with search drop ] unit-test
 [ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test
@@ -9,7 +9,7 @@ USING: binary-search math.order vectors kernel tools.test ;
 [ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
 [ 10 ] [ 10 20 >vector [ <=> ] with search drop ] unit-test
 
-[ t ] [ "hello" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
+[ t ] [ "hello" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
-[ 3 ] [ "hey" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
+[ 3 ] [ "hey" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
-[ f ] [ "hello" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
+[ f ] [ "hello" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
-[ f ] [ "zebra" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
+[ f ] [ "zebra" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test

basis/bit-arrays/bit-arrays.factor

@@ -44,33 +44,33 @@ PRIVATE>
 : <bit-array> ( n -- bit-array )
     dup bits>bytes <byte-array> bit-array boa ; inline
 
-M: bit-array length length>> ;
+M: bit-array length length>> ; inline
 
 M: bit-array nth-unsafe
-    [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ;
+    [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; inline
 
 M: bit-array set-nth-unsafe
     [ >fixnum ] [ underlying>> ] bi*
     [ byte/bit set-bit ] 2keep
-    swap n>byte set-alien-unsigned-1 ;
+    swap n>byte set-alien-unsigned-1 ; inline
 
 GENERIC: clear-bits ( bit-array -- )
 
-M: bit-array clear-bits 0 (set-bits) ;
+M: bit-array clear-bits 0 (set-bits) ; inline
 
 GENERIC: set-bits ( bit-array -- )
 
-M: bit-array set-bits -1 (set-bits) ;
+M: bit-array set-bits -1 (set-bits) ; inline
 
 M: bit-array clone
-    [ length>> ] [ underlying>> clone ] bi bit-array boa ;
+    [ length>> ] [ underlying>> clone ] bi bit-array boa ; inline
 
 : >bit-array ( seq -- bit-array )
     T{ bit-array f 0 B{ } } clone-like ; inline
 
-M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
+M: bit-array like drop dup bit-array? [ >bit-array ] unless ; inline
 
-M: bit-array new-sequence drop <bit-array> ;
+M: bit-array new-sequence drop <bit-array> ; inline
 
 M: bit-array equal?
     over bit-array? [ [ underlying>> ] bi@ sequence= ] [ 2drop f ] if ;
@@ -81,9 +81,9 @@ M: bit-array resize
         resize-byte-array
     ] 2bi
     bit-array boa
-    dup clean-up ;
+    dup clean-up ; inline
 
-M: bit-array byte-length length 7 + -3 shift ;
+M: bit-array byte-length length 7 + -3 shift ; inline
 
 SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
 
@@ -91,10 +91,10 @@ SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
     dup 0 = [
         <bit-array>
     ] [
-        [ log2 1+ <bit-array> 0 ] keep
+        [ log2 1 + <bit-array> 0 ] keep
         [ dup 0 = ] [
             [ pick underlying>> pick set-alien-unsigned-1 ] keep
-            [ 1+ ] [ -8 shift ] bi*
+            [ 1 + ] [ -8 shift ] bi*
         ] until 2drop
     ] if ;
 

basis/bit-sets/bit-sets-tests.factor

@@ -1,5 +1,5 @@
-IN: bit-sets.tests
 USING: bit-sets tools.test bit-arrays ;
+IN: bit-sets.tests
 
 [ ?{ t f t f t f } ] [
     ?{ t f f f t f }

basis/bit-vectors/bit-vectors-tests.factor

@@ -1,5 +1,5 @@
-IN: bit-vectors.tests
 USING: tools.test bit-vectors vectors sequences kernel math ;
+IN: bit-vectors.tests
 
 [ 0 ] [ 123 <bit-vector> length ] unit-test
 

basis/bitstreams/bitstreams-tests.factor

@@ -5,7 +5,6 @@ grouping compression.lzw multiline byte-arrays io.encodings.binary
 io.streams.byte-array ;
 IN: bitstreams.tests
 
-
 [ BIN: 1111111111 ]
 [
     B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>

basis/bitstreams/bitstreams.factor

@@ -70,7 +70,7 @@ GENERIC: poke ( value n bitstream -- )
     [ get-abp + ] [ set-abp ] bi ; inline
     
 : (align) ( n m -- n' )
-    [ /mod 0 > [ 1+ ] when ] [ * ] bi ; inline
+    [ /mod 0 > [ 1 + ] when ] [ * ] bi ; inline
     
 : align ( n bitstream -- )
     [ get-abp swap (align) ] [ set-abp ] bi ; inline

basis/bootstrap/compiler/compiler.factor

@@ -35,82 +35,87 @@ gc
 : compile-unoptimized ( words -- )
     [ optimized? not ] filter compile ;
 
-nl
+"debug-compiler" get [
-"Compiling..." write flush
     
-! Compile a set of words ahead of the full compile.
+    nl
-! This set of words was determined semi-empirically
+    "Compiling..." write flush
-! using the profiler. It improves bootstrap time
-! significantly, because frequenly called words
-! which are also quick to compile are replaced by
-! compiled definitions as soon as possible.
-{
-    not ?
 
-    2over roll -roll
+    ! Compile a set of words ahead of the full compile.
+    ! This set of words was determined semi-empirically
+    ! using the profiler. It improves bootstrap time
+    ! significantly, because frequenly called words
+    ! which are also quick to compile are replaced by
+    ! compiled definitions as soon as possible.
+    {
+        not ?
 
-    array? hashtable? vector?
+        2over roll -roll
-    tuple? sbuf? tombstone?
-    curry? compose? callable?
-    quotation?
 
-    curry compose uncurry
+        array? hashtable? vector?
+        tuple? sbuf? tombstone?
+        curry? compose? callable?
+        quotation?
 
-    array-nth set-array-nth length>>
+        curry compose uncurry
 
-    wrap probe
+        array-nth set-array-nth length>>
 
-    namestack*
+        wrap probe
 
-    layout-of
+        namestack*
-} compile-unoptimized
 
-"." write flush
+        layout-of
+    } compile-unoptimized
 
-{
+    "." write flush
-    bitand bitor bitxor bitnot
-} compile-unoptimized
 
-"." write flush
+    {
+        bitand bitor bitxor bitnot
+    } compile-unoptimized
 
-{
+    "." write flush
-    + 1+ 1- 2/ < <= > >= shift
-} compile-unoptimized
 
-"." write flush
+    {
+        + 2/ < <= > >= shift
+    } compile-unoptimized
 
-{
+    "." write flush
-    new-sequence nth push pop last flip
-} compile-unoptimized
 
-"." write flush
+    {
+        new-sequence nth push pop last flip
+    } compile-unoptimized
 
-{
+    "." write flush
-    hashcode* = equal? assoc-stack (assoc-stack) get set
-} compile-unoptimized
 
-"." write flush
+    {
+        hashcode* = equal? assoc-stack (assoc-stack) get set
+    } compile-unoptimized
 
-{
+    "." write flush
-    memq? split harvest sift cut cut-slice start index clone
-    set-at reverse push-all class number>string string>number
-} compile-unoptimized
 
-"." write flush
+    {
+        memq? split harvest sift cut cut-slice start index clone
+        set-at reverse push-all class number>string string>number
+        like clone-like
+    } compile-unoptimized
 
-{
+    "." write flush
-    lines prefix suffix unclip new-assoc update
-    word-prop set-word-prop 1array 2array 3array ?nth
-} compile-unoptimized
 
-"." write flush
+    {
+        lines prefix suffix unclip new-assoc update
+        word-prop set-word-prop 1array 2array 3array ?nth
+    } compile-unoptimized
 
-{
+    "." write flush
-    malloc calloc free memcpy
-} compile-unoptimized
 
-"." write flush
+    {
+        malloc calloc free memcpy
+    } compile-unoptimized
 
-vocabs [ words compile-unoptimized "." write flush ] each
+    "." write flush
 
-" done" print flush
+    vocabs [ words compile-unoptimized "." write flush ] each
+
+    " done" print flush
+
+] unless

basis/bootstrap/compiler/timing/timing.factor

@@ -1,38 +1,42 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors compiler.cfg.builder compiler.cfg.linear-scan
+USING: accessors kernel make sequences tools.annotations tools.crossref ;
-compiler.cfg.liveness compiler.cfg.mr compiler.cfg.optimizer
+QUALIFIED: compiler.cfg.builder
-compiler.cfg.stacks.finalize compiler.cfg.stacks.global
+QUALIFIED: compiler.cfg.linear-scan
-compiler.codegen compiler.tree.builder compiler.tree.optimizer
+QUALIFIED: compiler.cfg.mr
-kernel make sequences tools.annotations tools.crossref ;
+QUALIFIED: compiler.cfg.optimizer
+QUALIFIED: compiler.cfg.stacks.finalize
+QUALIFIED: compiler.cfg.stacks.global
+QUALIFIED: compiler.codegen
+QUALIFIED: compiler.tree.builder
+QUALIFIED: compiler.tree.optimizer
 IN: bootstrap.compiler.timing
 
 : passes ( word -- seq )
     def>> uses [ vocabulary>> "compiler." head? ] filter ;
 
-: high-level-passes ( -- seq ) \ optimize-tree passes ;
+: high-level-passes ( -- seq ) \ compiler.tree.optimizer:optimize-tree passes ;
 
-: low-level-passes ( -- seq ) \ optimize-cfg passes ;
+: low-level-passes ( -- seq ) \ compiler.cfg.optimizer:optimize-cfg passes ;
 
-: machine-passes ( -- seq ) \ build-mr passes ;
+: machine-passes ( -- seq ) \ compiler.cfg.mr:build-mr passes ;
 
-: linear-scan-passes ( -- seq ) \ (linear-scan) passes ;
+: linear-scan-passes ( -- seq ) \ compiler.cfg.linear-scan:(linear-scan) passes ;
 
 : all-passes ( -- seq )
     [
-        \ build-tree ,
+        \ compiler.tree.builder:build-tree ,
-        \ optimize-tree ,
+        \ compiler.tree.optimizer:optimize-tree ,
         high-level-passes %
-        \ build-cfg ,
+        \ compiler.cfg.builder:build-cfg ,
-        \ compute-global-sets ,
+        \ compiler.cfg.stacks.global:compute-global-sets ,
-        \ finalize-stack-shuffling ,
+        \ compiler.cfg.stacks.finalize:finalize-stack-shuffling ,
-        \ optimize-cfg ,
+        \ compiler.cfg.optimizer:optimize-cfg ,
         low-level-passes %
-        \ compute-live-sets ,
+        \ compiler.cfg.mr:build-mr ,
-        \ build-mr ,
         machine-passes %
         linear-scan-passes %
-        \ generate ,
+        \ compiler.codegen:generate ,
     ] { } make ;
 
 all-passes [ [ reset ] [ add-timing ] bi ] each

basis/bootstrap/image/image-tests.factor

@@ -1,6 +1,6 @@
-IN: bootstrap.image.tests
 USING: bootstrap.image bootstrap.image.private tools.test
 kernel math ;
+IN: bootstrap.image.tests
 
 [ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test
 

basis/bootstrap/image/image.factor

@@ -38,11 +38,11 @@ IN: bootstrap.image
 
 ! Object cache; we only consider numbers equal if they have the
 ! same type
-TUPLE: id obj ;
+TUPLE: eql-wrapper obj ;
 
-C: <id> id
+C: <eql-wrapper> eql-wrapper
 
-M: id hashcode* obj>> hashcode* ;
+M: eql-wrapper hashcode* obj>> hashcode* ;
 
 GENERIC: (eql?) ( obj1 obj2 -- ? )
 
@@ -62,19 +62,27 @@ M: sequence (eql?)
 
 M: object (eql?) = ;
 
-M: id equal?
+M: eql-wrapper equal?
-    over id? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
+    over eql-wrapper? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
+
+TUPLE: eq-wrapper obj ;
+
+C: <eq-wrapper> eq-wrapper
+
+M: eq-wrapper equal?
+    over eq-wrapper? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
 
 SYMBOL: objects
 
-: (objects) ( obj -- id assoc ) <id> objects get ; inline
+: cache-eql-object ( obj quot -- value )
+    [ <eql-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
 
-: lookup-object ( obj -- n/f ) (objects) at ;
+: cache-eq-object ( obj quot -- value )
+    [ <eq-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
 
-: put-object ( n obj -- ) (objects) set-at ;
+: lookup-object ( obj -- n/f ) <eq-wrapper> objects get at ;
 
-: cache-object ( obj quot -- value )
+: put-object ( n obj -- ) <eq-wrapper> objects get set-at ;
-    [ (objects) ] dip '[ obj>> @ ] cache ; inline
 
 ! Constants
 
@@ -234,7 +242,7 @@ GENERIC: ' ( obj -- ptr )
 
 : bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
 
-: bignum-radix ( -- n ) bignum-bits 2^ 1- ;
+: bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
 
 : bignum>seq ( n -- seq )
     #! n is positive or zero.
@@ -244,7 +252,7 @@ GENERIC: ' ( obj -- ptr )
 
 : emit-bignum ( n -- )
     dup dup 0 < [ neg ] when bignum>seq
-    [ nip length 1+ emit-fixnum ]
+    [ nip length 1 + emit-fixnum ]
     [ drop 0 < 1 0 ? emit ]
     [ nip emit-seq ]
     2tri ;
@@ -252,7 +260,7 @@ GENERIC: ' ( obj -- ptr )
 M: bignum '
     [
         bignum [ emit-bignum ] emit-object
-    ] cache-object ;
+    ] cache-eql-object ;
 
 ! Fixnums
 
@@ -277,7 +285,7 @@ M: float '
         float [
             align-here double>bits emit-64
         ] emit-object
-    ] cache-object ;
+    ] cache-eql-object ;
 
 ! Special objects
 
@@ -340,7 +348,7 @@ M: word ' ;
 ! Wrappers
 
 M: wrapper '
-    wrapped>> ' wrapper [ emit ] emit-object ;
+    [ wrapped>> ' wrapper [ emit ] emit-object ] cache-eql-object ;
 
 ! Strings
 : native> ( object -- object )
@@ -379,7 +387,7 @@ M: wrapper '
 M: string '
     #! We pool strings so that each string is only written once
     #! to the image
-    [ emit-string ] cache-object ;
+    [ emit-string ] cache-eql-object ;
 
 : assert-empty ( seq -- )
     length 0 assert= ;
@@ -390,10 +398,12 @@ M: string '
     ] bi* ;
 
 M: byte-array '
-    byte-array [
+    [
-        dup length emit-fixnum
+        byte-array [
-        pad-bytes emit-bytes
+            dup length emit-fixnum
-    ] emit-object ;
+            pad-bytes emit-bytes
+        ] emit-object
+    ] cache-eq-object ;
 
 ! Tuples
 ERROR: tuple-removed class ;
@@ -408,20 +418,22 @@ ERROR: tuple-removed class ;
 
 : emit-tuple ( tuple -- pointer )
     dup class name>> "tombstone" =
-    [ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ;
+    [ [ (emit-tuple) ] cache-eql-object ]
+    [ [ (emit-tuple) ] cache-eq-object ]
+    if ;
 
 M: tuple ' emit-tuple ;
 
 M: tombstone '
     state>> "((tombstone))" "((empty))" ?
     "hashtables.private" lookup def>> first
-    [ emit-tuple ] cache-object ;
+    [ emit-tuple ] cache-eql-object ;
 
 ! Arrays
 : emit-array ( array -- offset )
     [ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
 
-M: array ' emit-array ;
+M: array ' [ emit-array ] cache-eq-object ;
 
 ! This is a hack. We need to detect arrays which are tuple
 ! layout arrays so that they can be internalized, but making
@@ -438,7 +450,7 @@ M: tuple-layout-array '
     [
         [ dup integer? [ <fake-bignum> ] when ] map
         emit-array
-    ] cache-object ;
+    ] cache-eql-object ;
 
 ! Quotations
 
@@ -452,7 +464,7 @@ M: quotation '
             0 emit ! xt
             0 emit ! code
         ] emit-object
-    ] cache-object ;
+    ] cache-eql-object ;
 
 ! End of the image
 

basis/bootstrap/image/upload/upload.factor

@@ -9,9 +9,9 @@ IN: bootstrap.image.upload
 SYMBOL: upload-images-destination
 
 : destination ( -- dest )
-  upload-images-destination get
+    upload-images-destination get
-  "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
+    "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
-  or ;
+    or ;
 
 : checksums ( -- temp ) "checksums.txt" temp-file ;
 

basis/bootstrap/tools/tools.factor

@@ -8,12 +8,14 @@ IN: bootstrap.tools
     "tools.crossref"
     "tools.errors"
     "tools.deploy"
+    "tools.destructors"
     "tools.disassembler"
     "tools.memory"
     "tools.profiler"
     "tools.test"
     "tools.time"
     "tools.threads"
+    "tools.deprecation"
     "vocabs.hierarchy"
     "vocabs.refresh"
     "vocabs.refresh.monitor"

basis/boxes/boxes-tests.factor

@@ -1,5 +1,5 @@
-IN: boxes.tests
 USING: boxes namespaces tools.test accessors ;
+IN: boxes.tests
 
 [ ] [ <box> "b" set ] unit-test
 

basis/byte-arrays/hex/hex.factor

@@ -8,4 +8,3 @@ SYNTAX: HEX{
     [ blank? not ] filter
     2 group [ hex> ] B{ } map-as
     parsed ;
-

basis/cache/cache-tests.factor

@@ -1,4 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test cache ;
-IN: cache.tests

basis/cache/cache.factor

@@ -3,10 +3,10 @@
 USING: kernel assocs math accessors destructors fry sequences ;
 IN: cache
 
-TUPLE: cache-assoc assoc max-age disposed ;
+TUPLE: cache-assoc < disposable assoc max-age ;
 
 : <cache-assoc> ( -- cache )
-    H{ } clone 10 f cache-assoc boa ;
+    cache-assoc new-disposable H{ } clone >>assoc 10 >>max-age ;
 
 <PRIVATE
 
@@ -38,6 +38,6 @@ PRIVATE>
 
 : purge-cache ( cache -- )
     dup max-age>> '[
-        [ nip [ 1+ ] change-age age>> _ >= ] assoc-partition
+        [ nip [ 1 + ] change-age age>> _ >= ] assoc-partition
         [ values dispose-each ] dip
     ] change-assoc drop ;

basis/cairo/cairo-tests.factor

@@ -1,5 +1,5 @@
-IN: cairo.tests
 USING: cairo tools.test math.rectangles accessors ;
+IN: cairo.tests
 
 [ { 10 20 } ] [
     { 10 20 } [

basis/calendar/calendar-docs.factor

@@ -20,14 +20,14 @@ HELP: <date>
 { $values { "year" integer } { "month" integer } { "day" integer } { "timestamp" timestamp } }
 { $description "Returns a timestamp object representing the start of the specified day in your current timezone." }
 { $examples
-    { $example "USING: calendar prettyprint ;"
+    { $example "USING: accessors calendar prettyprint ;"
-               "2010 12 25 <date> >gmt midnight ."
+               "2010 12 25 <date> instant >>gmt-offset ."
                "T{ timestamp { year 2010 } { month 12 } { day 25 } }"
     }
 } ;
 
 HELP: month-names
-{ $values { "array" array } }
+{ $values { "value" object } }
 { $description "Returns an array with the English names of all the months." }
 { $warning "Do not use this array for looking up a month name directly. Use month-name instead." } ;
 

basis/calendar/calendar.factor

@@ -34,25 +34,25 @@ C: <timestamp> timestamp
 : <date> ( year month day -- timestamp )
     0 0 0 gmt-offset-duration <timestamp> ;
 
-ERROR: not-a-month n ;
+ERROR: not-a-month ;
 M: not-a-month summary
     drop "Months are indexed starting at 1" ;
 
 <PRIVATE
 
 : check-month ( n -- n )
-    dup zero? [ not-a-month ] when ;
+    [ not-a-month ] when-zero ;
 
 PRIVATE>
 
-: month-names ( -- array )
+CONSTANT: month-names 
     {
         "January" "February" "March" "April" "May" "June"
         "July" "August" "September" "October" "November" "December"
-    } ;
+    }
 
 : month-name ( n -- string )
-    check-month 1- month-names nth ;
+    check-month 1 - month-names nth ;
 
 CONSTANT: month-abbreviations
     {
@@ -61,7 +61,7 @@ CONSTANT: month-abbreviations
     }
 
 : month-abbreviation ( n -- string )
-    check-month 1- month-abbreviations nth ;
+    check-month 1 - month-abbreviations nth ;
 
 CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
 
@@ -113,7 +113,7 @@ CONSTANT: day-abbreviations3
     100 b * d + 4800 -
     m 10 /i + m 3 +
     12 m 10 /i * -
-    e 153 m * 2 + 5 /i - 1+ ;
+    e 153 m * 2 + 5 /i - 1 + ;
 
 GENERIC: easter ( obj -- obj' )
 
@@ -186,9 +186,6 @@ GENERIC: +second ( timestamp x -- timestamp )
     { [ day>> 29 = ] [ month>> 2 = ] [ leap-year? not ] } 1&&
     [ 3 >>month 1 >>day ] when ;
 
-: unless-zero ( n quot -- )
-    [ dup zero? [ drop ] ] dip if ; inline
-
 M: integer +year ( timestamp n -- timestamp )
     [ [ + ] curry change-year adjust-leap-year ] unless-zero ;
 
@@ -196,7 +193,7 @@ M: real +year ( timestamp n -- timestamp )
     [ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ;
 
 : months/years ( n -- months years )
-    12 /rem dup zero? [ drop 1- 12 ] when swap ; inline
+    12 /rem [ 1 - 12 ] when-zero swap ; inline
 
 M: integer +month ( timestamp n -- timestamp )
     [ over month>> + months/years [ >>month ] dip +year ] unless-zero ;
@@ -371,10 +368,10 @@ M: duration time-
     #! http://web.textfiles.com/computers/formulas.txt
     #! good for any date since October 15, 1582
     [
-        dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when
+        dup 2 <= [ [ 1 - ] [ 12 + ] bi* ] when
         [ dup [ 4 /i + ] [ 100 /i - ] [ 400 /i + ] tri ] dip
-        [ 1+ 3 * 5 /i + ] keep 2 * +
+        [ 1 + 3 * 5 /i + ] keep 2 * +
-    ] dip 1+ + 7 mod ;
+    ] dip 1 + + 7 mod ;
 
 GENERIC: days-in-year ( obj -- n )
 
@@ -395,7 +392,7 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
     year leap-year? [
         year month day <date>
         year 3 1 <date>
-        after=? [ 1+ ] when
+        after=? [ 1 + ] when
     ] when ;
 
 : day-of-year ( timestamp -- n )

basis/calendar/format/format.factor

@@ -68,8 +68,8 @@ M: array month. ( pair -- )
     [ (days-in-month) day-abbreviations2 " " join print ] 2tri
     over "   " <repetition> concat write
     [
-        [ 1+ day. ] keep
+        [ 1 + day. ] keep
-        1+ + 7 mod zero? [ nl ] [ bl ] if
+        1 + + 7 mod zero? [ nl ] [ bl ] if
     ] with each nl ;
 
 M: timestamp month. ( timestamp -- )
@@ -78,7 +78,7 @@ M: timestamp month. ( timestamp -- )
 GENERIC: year. ( obj -- )
 
 M: integer year. ( n -- )
-    12 [ 1+ 2array month. nl ] with each ;
+    12 [ 1 + 2array month. nl ] with each ;
 
 M: timestamp year. ( timestamp -- )
     year>> year. ;
@@ -162,7 +162,7 @@ M: timestamp year. ( timestamp -- )
 
 : read-rfc3339-seconds ( s -- s' ch )
     "+-Z" read-until [
-        [ string>number ] [ length 10 swap ^ ] bi / +
+        [ string>number ] [ length 10^ ] bi / +
     ] dip ;
 
 : (rfc3339>timestamp) ( -- timestamp )
@@ -201,7 +201,7 @@ ERROR: invalid-timestamp-format ;
         "," read-token day-abbreviations3 member? check-timestamp drop
         read1 CHAR: \s assert=
         read-sp checked-number >>day
-        read-sp month-abbreviations index 1+ check-timestamp >>month
+        read-sp month-abbreviations index 1 + check-timestamp >>month
         read-sp checked-number >>year
         ":" read-token checked-number >>hour
         ":" read-token checked-number >>minute
@@ -220,7 +220,7 @@ ERROR: invalid-timestamp-format ;
         "," read-token check-day-name
         read1 CHAR: \s assert=
         "-" read-token checked-number >>day
-        "-" read-token month-abbreviations index 1+ check-timestamp >>month
+        "-" read-token month-abbreviations index 1 + check-timestamp >>month
         read-sp checked-number >>year
         ":" read-token checked-number >>hour
         ":" read-token checked-number >>minute
@@ -233,7 +233,7 @@ ERROR: invalid-timestamp-format ;
 : (cookie-string>timestamp-2) ( -- timestamp )
     timestamp new
         read-sp check-day-name
-        read-sp month-abbreviations index 1+ check-timestamp >>month
+        read-sp month-abbreviations index 1 + check-timestamp >>month
         read-sp checked-number >>day
         ":" read-token checked-number >>hour
         ":" read-token checked-number >>minute

basis/channels/examples/examples.factor

@@ -7,7 +7,7 @@ locals sequences ;
 IN: channels.examples
 
 : (counter) ( channel n -- )
-    [ swap to ] 2keep 1+ (counter) ;
+    [ swap to ] 2keep 1 + (counter) ;
     
 : counter ( channel -- )
     2 (counter) ;    

basis/checksums/fnv1/authors.txt

@@ -0,0 +1 @@
+Alaric Snell-Pym

basis/checksums/fnv1/fnv1-docs.factor

@@ -0,0 +1,67 @@
+USING: help.markup help.syntax ;
+IN: checksums.fnv1
+
+HELP: fnv1-32
+{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 32-bit." } ;
+
+HELP: fnv1a-32
+{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 32-bit." } ;
+
+
+HELP: fnv1-64
+{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 64-bit." } ;
+
+HELP: fnv1a-64
+{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 64-bit." } ;
+
+
+HELP: fnv1-128
+{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 128-bit." } ;
+
+HELP: fnv1a-128
+{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 128-bit." } ;
+
+
+HELP: fnv1-256
+{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 256-bit." } ;
+
+HELP: fnv1a-256
+{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 256-bit." } ;
+
+
+HELP: fnv1-512
+{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 512-bit." } ;
+
+HELP: fnv1a-512
+{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 512-bit." } ;
+
+
+HELP: fnv1-1024
+{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 1024-bit." } ;
+
+HELP: fnv1a-1024
+{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 1024-bit." } ;
+
+ARTICLE: "checksums.fnv1" "Fowler-Noll-Vo checksum"
+  "The Fowler-Noll-Vo checksum algorithm is another simple and fast checksum. It comes in 32, 64, 128, 256, 512 and 1024-bit versions, each in 1 and 1a variants. The 1a variants tend to produce a slightly better result. See http://en.wikipedia.org/wiki/Fowler_Noll_Vo_hash for more details."
+
+  { $subsection fnv1-32 }
+  { $subsection fnv1a-32 }
+
+  { $subsection fnv1-64 }
+  { $subsection fnv1a-64 }
+
+  { $subsection fnv1-128 }
+  { $subsection fnv1a-128 }
+
+  { $subsection fnv1-256 }
+  { $subsection fnv1a-256 }
+
+  { $subsection fnv1-512 }
+  { $subsection fnv1a-512 }
+
+  { $subsection fnv1-1024 }
+  { $subsection fnv1a-1024 }
+ ;
+
+ABOUT: "checksums.fnv1"

basis/checksums/fnv1/fnv1-tests.factor

@@ -0,0 +1,41 @@
+USING: checksums.fnv1 checksums strings tools.test ;
+IN: checksums.fnv1.tests
+
+! A few test vectors taken from http://www.isthe.com/chongo/src/fnv/test_fnv.c
+
+[ HEX: 811c9dc5 ] [ "" fnv1-32 checksum-bytes ] unit-test
+[ HEX: 811c9dc5 ] [ "" fnv1a-32 checksum-bytes ] unit-test
+[ HEX: cbf29ce484222325 ] [ "" fnv1-64 checksum-bytes ] unit-test
+[ HEX: cbf29ce484222325 ] [ "" fnv1a-64 checksum-bytes ] unit-test
+
+[ HEX: 050c5d7e ] [ "a" fnv1-32 checksum-bytes ] unit-test
+[ HEX: e40c292c ] [ "a" fnv1a-32 checksum-bytes ] unit-test
+[ HEX: af63bd4c8601b7be ] [ "a" fnv1-64 checksum-bytes ] unit-test
+[ HEX: af63dc4c8601ec8c ] [ "a" fnv1a-64 checksum-bytes ] unit-test
+
+[ HEX: 050c5d7d ] [ "b" fnv1-32 checksum-bytes ] unit-test
+[ HEX: e70c2de5 ] [ "b" fnv1a-32 checksum-bytes ] unit-test
+[ HEX: af63bd4c8601b7bd ] [ "b" fnv1-64 checksum-bytes ] unit-test
+[ HEX: af63df4c8601f1a5 ] [ "b" fnv1a-64 checksum-bytes ] unit-test
+
+[ HEX: 31f0b262 ] [ "foobar" fnv1-32 checksum-bytes ] unit-test
+[ HEX: bf9cf968 ] [ "foobar" fnv1a-32 checksum-bytes ] unit-test
+[ HEX: 340d8765a4dda9c2 ] [ "foobar" fnv1-64 checksum-bytes ] unit-test
+[ HEX: 85944171f73967e8 ] [ "foobar" fnv1a-64 checksum-bytes ] unit-test
+
+! I couldn't find any test vectors for 128, 256, 512, or 1024 versions of FNV1 hashes.
+! So, just to check that your maths works the same as my maths, here's a few samples computed on my laptop.
+! So they may be right or wrong, but either way, them failing is cause for concern somewhere...
+
+[ 3897470310 ] [ "Hello, world!" fnv1-32 checksum-bytes ] unit-test
+[ 3985698964 ] [ "Hello, world!" fnv1a-32 checksum-bytes ] unit-test
+[ 7285062107457560934 ] [ "Hello, world!" fnv1-64 checksum-bytes ] unit-test
+[ 4094109891673226228 ] [ "Hello, world!" fnv1a-64 checksum-bytes ] unit-test
+[ 281580511747867177735318995358496831158 ] [ "Hello, world!" fnv1-128 checksum-bytes ] unit-test
+[ 303126633380056630368940439484674414572 ] [ "Hello, world!" fnv1a-128 checksum-bytes ] unit-test
+[ 104295939182568077644846978685759236849634734810631820736486253421270219742822 ] [ "Hello, world!" fnv1-256 checksum-bytes ] unit-test
+[ 9495445728692795332446740615588417456874414534608540692485745371050033741380 ] [ "Hello, world!" fnv1a-256 checksum-bytes ] unit-test
+[ 3577308325596719252093726711895047340166329831006673109476042102918876665433235513101496175651226507162015890004121912850661561110326527625579463564626958 ] [ "Hello, world!" fnv1-512 checksum-bytes ] unit-test
+[ 3577308325596719162840652138474318309664256091923081930027929425092517582111473988451078821416039944023089883981242376700859598441397004715365740906054208 ] [ "Hello, world!" fnv1a-512 checksum-bytes ] unit-test
+[ 52692754922840008511959888105094366091401994235075816792707658326855733053286986999719949898492311786648795846192078757217437117165934438286601534984230194601365788544275827382423366672856972872132009691615382991251544423521887009322211754219117294019951276080952271766377222613325328591830596794468813260226 ] [ "Hello, world!" fnv1-1024 checksum-bytes ] unit-test
+[ 52692754922840008511959888105094366091401994235075816792707658326855804920671100511873485674717442819607149127986090276849364757610838433887624184145636764448608707614141109841761957788887305179569455221243999538336208648824673027111352338809582124430199044921035232455717748500524777795242051756321605065326 ] [ "Hello, world!" fnv1a-1024 checksum-bytes ] unit-test

basis/checksums/fnv1/fnv1.factor

@@ -0,0 +1,104 @@
+! Copyright (C) 2009 Alaric Snell-Pym
+! See http://factorcode.org/license.txt for BSD license.
+USING: checksums classes.singleton kernel math math.ranges
+math.vectors sequences ;
+IN: checksums.fnv1
+
+SINGLETON: fnv1-32
+SINGLETON: fnv1a-32
+SINGLETON: fnv1-64
+SINGLETON: fnv1a-64
+SINGLETON: fnv1-128
+SINGLETON: fnv1a-128
+SINGLETON: fnv1-256
+SINGLETON: fnv1a-256
+SINGLETON: fnv1-512
+SINGLETON: fnv1a-512
+SINGLETON: fnv1-1024
+SINGLETON: fnv1a-1024
+
+CONSTANT: fnv1-32-prime 16777619
+CONSTANT: fnv1-64-prime 1099511628211
+CONSTANT: fnv1-128-prime 309485009821345068724781371
+CONSTANT: fnv1-256-prime 374144419156711147060143317175368453031918731002211
+CONSTANT: fnv1-512-prime 35835915874844867368919076489095108449946327955754392558399825615420669938882575126094039892345713852759
+CONSTANT: fnv1-1024-prime 5016456510113118655434598811035278955030765345404790744303017523831112055108147451509157692220295382716162651878526895249385292291816524375083746691371804094271873160484737966720260389217684476157468082573
+
+CONSTANT: fnv1-32-mod HEX: ffffffff
+CONSTANT: fnv1-64-mod HEX: ffffffffffffffff
+CONSTANT: fnv1-128-mod HEX: ffffffffffffffffffffffffffffffff
+CONSTANT: fnv1-256-mod HEX: ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+CONSTANT: fnv1-512-mod HEX: ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+CONSTANT: fnv1-1024-mod HEX: ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+CONSTANT: fnv1-32-basis HEX: 811c9dc5
+CONSTANT: fnv1-64-basis HEX: cbf29ce484222325
+CONSTANT: fnv1-128-basis HEX: 6c62272e07bb014262b821756295c58d
+CONSTANT: fnv1-256-basis HEX: dd268dbcaac550362d98c384c4e576ccc8b1536847b6bbb31023b4c8caee0535
+CONSTANT: fnv1-512-basis HEX: b86db0b1171f4416dca1e50f309990acac87d059c90000000000000000000d21e948f68a34c192f62ea79bc942dbe7ce182036415f56e34bac982aac4afe9fd9
+CONSTANT: fnv1-1024-basis HEX: 5f7a76758ecc4d32e56d5a591028b74b29fc4223fdada16c3bf34eda3674da9a21d9000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004c6d7eb6e73802734510a555f256cc005ae556bde8cc9c6a93b21aff4b16c71ee90b3
+
+M: fnv1-32 checksum-bytes ( bytes checksum -- value )
+    drop
+    fnv1-32-basis swap
+    [ swap fnv1-32-prime * bitxor fnv1-32-mod bitand ] each ;
+
+M: fnv1a-32 checksum-bytes ( bytes checksum -- value )
+    drop
+    fnv1-32-basis swap
+    [ bitxor fnv1-32-prime * fnv1-32-mod bitand ] each ;
+
+
+M: fnv1-64 checksum-bytes ( bytes checksum -- value )
+    drop
+    fnv1-64-basis swap
+    [ swap fnv1-64-prime * bitxor fnv1-64-mod bitand ] each ;
+
+M: fnv1a-64 checksum-bytes ( bytes checksum -- value )
+    drop
+    fnv1-64-basis swap
+    [ bitxor fnv1-64-prime * fnv1-64-mod bitand ] each ;
+
+
+M: fnv1-128 checksum-bytes ( bytes checksum -- value )
+    drop
+    fnv1-128-basis swap
+    [ swap fnv1-128-prime * bitxor fnv1-128-mod bitand ] each ;
+
+M: fnv1a-128 checksum-bytes ( bytes checksum -- value )
+    drop
+    fnv1-128-basis swap
+    [ bitxor fnv1-128-prime * fnv1-128-mod bitand ] each ;
+
+
+M: fnv1-256 checksum-bytes ( bytes checksum -- value )
+    drop
+    fnv1-256-basis swap
+    [ swap fnv1-256-prime * bitxor fnv1-256-mod bitand ] each ;
+
+M: fnv1a-256 checksum-bytes ( bytes checksum -- value )
+    drop
+    fnv1-256-basis swap
+    [ bitxor fnv1-256-prime * fnv1-256-mod bitand ] each ;
+
+
+M: fnv1-512 checksum-bytes ( bytes checksum -- value )
+    drop
+    fnv1-512-basis swap
+    [ swap fnv1-512-prime * bitxor fnv1-512-mod bitand ] each ;
+
+M: fnv1a-512 checksum-bytes ( bytes checksum -- value )
+    drop
+    fnv1-512-basis swap
+    [ bitxor fnv1-512-prime * fnv1-512-mod bitand ] each ;
+
+
+M: fnv1-1024 checksum-bytes ( bytes checksum -- value )
+    drop
+    fnv1-1024-basis swap
+    [ swap fnv1-1024-prime * bitxor fnv1-1024-mod bitand ] each ;
+
+M: fnv1a-1024 checksum-bytes ( bytes checksum -- value )
+    drop
+    fnv1-1024-basis swap
+    [ bitxor fnv1-1024-prime * fnv1-1024-mod bitand ] each ;

basis/checksums/fnv1/summary.txt

@@ -0,0 +1 @@
+Fowler-Noll-Vo checksum algorithm

basis/checksums/md5/md5-tests.factor

@@ -1,6 +1,8 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
 USING: byte-arrays checksums checksums.md5 io.encodings.binary
 io.streams.byte-array kernel math namespaces tools.test ;
-
+IN: checksums.md5.tests 
 
 [ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test
 [ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array md5 checksum-bytes hex-string ] unit-test

basis/checksums/openssl/openssl.factor

@@ -19,13 +19,13 @@ C: <openssl-checksum> openssl-checksum
 
 <PRIVATE
 
-TUPLE: evp-md-context handle ;
+TUPLE: evp-md-context < disposable handle ;
 
 : <evp-md-context> ( -- ctx )
-    "EVP_MD_CTX" <c-object>
+    evp-md-context new-disposable
-    dup EVP_MD_CTX_init evp-md-context boa ;
+    "EVP_MD_CTX" <c-object> dup EVP_MD_CTX_init >>handle ;
 
-M: evp-md-context dispose
+M: evp-md-context dispose*
     handle>> EVP_MD_CTX_cleanup drop ;
 
 : with-evp-md-context ( quot -- )

basis/circular/circular-tests.factor

@@ -2,6 +2,7 @@
 ! See http;//factorcode.org/license.txt for BSD license
 USING: arrays kernel tools.test sequences sequences.private
 circular strings ;
+IN: circular.tests
 
 [ 0 ] [ { 0 1 2 3 4 } <circular> 0 swap virtual@ drop ] unit-test
 [ 2 ] [ { 0 1 2 3 4 } <circular> 2 swap virtual@ drop ] unit-test

basis/circular/circular.factor

@@ -51,7 +51,7 @@ PRIVATE>
 
 : push-growing-circular ( elt circular -- )
     dup full? [ push-circular ]
-    [ [ 1+ ] change-length set-last ] if ;
+    [ [ 1 + ] change-length set-last ] if ;
 
 : <growing-circular> ( capacity -- growing-circular )
     { } new-sequence 0 0 growing-circular boa ;

basis/classes/struct/prettyprint/prettyprint.factor

@@ -0,0 +1,41 @@
+! (c)Joe Groff bsd license
+USING: accessors assocs classes classes.struct combinators
+kernel math prettyprint.backend prettyprint.custom
+prettyprint.sections see.private sequences strings words ;
+IN: classes.struct.prettyprint
+
+<PRIVATE
+
+: struct-definer-word ( class -- word )
+    struct-slots dup length 2 >=
+    [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ]
+    [ drop \ STRUCT: ] if ;
+
+: struct>assoc ( struct -- assoc )
+    [ class struct-slots ] [ struct-slot-values ] bi zip filter-tuple-assoc ;
+
+: pprint-struct-slot ( slot -- )
+    <flow \ { pprint-word
+    {
+        [ name>> text ]
+        [ c-type>> dup string? [ text ] [ pprint* ] if ]
+        [ read-only>> [ \ read-only pprint-word ] when ]
+        [ initial>> [ \ initial: pprint-word pprint* ] when* ]
+    } cleave
+    \ } pprint-word block> ;
+
+PRIVATE>
+
+M: struct-class see-class*
+    <colon dup struct-definer-word pprint-word dup pprint-word
+    <block struct-slots [ pprint-struct-slot ] each
+    block> pprint-; block> ;
+
+M: struct pprint-delims
+    drop \ S{ \ } ;
+
+M: struct >pprint-sequence
+    [ class ] [ struct-slot-values ] bi class-slot-sequence ;
+
+M: struct pprint*
+    [ [ \ S{ ] dip [ class ] [ struct>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;

basis/classes/struct/struct-docs.factor

@@ -0,0 +1,89 @@
+! (c)Joe Groff bsd license
+USING: alien classes help.markup help.syntax kernel libc
+quotations slots ;
+IN: classes.struct
+
+HELP: <struct-boa>
+{ $values
+    { "class" class }
+}
+{ $description "This macro implements " { $link boa } " for " { $link struct } " classes. A struct of the given class is constructed, and its slots are initialized using values off the top of the datastack." } ;
+
+HELP: <struct>
+{ $values
+    { "class" class }
+    { "struct" struct }
+}
+{ $description "Allocates garbage-collected heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are initialized with the initial values specified in the struct definition." } ;
+
+{ <struct> <struct-boa> malloc-struct memory>struct } related-words
+
+HELP: STRUCT:
+{ $syntax "STRUCT: class { slot type } { slot type } ... ;" }
+{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
+{ $description "Defines a new " { $link struct } " type. The syntax is nearly identical to " { $link POSTPONE: TUPLE: } "; however, there are some additional restrictions on struct types:"
+{ $list
+{ "Struct classes cannot have a superclass defined." }
+{ "The slots of a struct must all have a type declared. The type must be a C type." } 
+{ { $link read-only } " slots on structs are not enforced, though they may be declared." }
+} } ;
+
+HELP: S{
+{ $syntax "S{ class slots... }" }
+{ $values { "class" "a " { $link struct } " class word" } { "slots" "slot values" } }
+{ $description "Marks the beginning of a literal struct. The syntax is identical to tuple literal syntax with " { $link POSTPONE: T{ } { $snippet " }" } "; either the assoc syntax (that is, " { $snippet "S{ class { slot value } { slot value } ... }" } ") or the simple syntax (" { $snippet "S{ class f value value ... }" } ") can be used." } ;
+
+HELP: UNION-STRUCT:
+{ $syntax "UNION-STRUCT: class { slot type } { slot type } ... ;" }
+{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
+{ $description "Defines a new " { $link struct } " type where all of the slots share the same storage. See " { $link POSTPONE: STRUCT: } " for details on the syntax." } ;
+
+HELP: define-struct-class
+{ $values
+    { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" }
+}
+{ $description "Defines a new " { $link struct } " class. This is the runtime equivalent of the " { $link POSTPONE: STRUCT: } " syntax." } ;
+
+HELP: define-union-struct-class
+{ $values
+    { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" }
+}
+{ $description "Defines a new " { $link struct } " class where all of the slots share the same storage. This is the runtime equivalent of the " { $link POSTPONE: UNION-STRUCT: } " syntax." } ;
+
+HELP: malloc-struct
+{ $values
+    { "class" class }
+    { "struct" struct }
+}
+{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized. The struct should be " { $link free } "d when it is no longer needed." } ;
+
+HELP: memory>struct
+{ $values
+    { "ptr" c-ptr } { "class" class }
+    { "struct" struct }
+}
+{ $description "Constructs a new " { $link struct } " of the specified " { $snippet "class" } " at the memory location referenced by " { $snippet "ptr" } ". The referenced memory is unchanged." } ;
+
+HELP: struct
+{ $class-description "The parent class of all struct types." } ;
+
+{ struct POSTPONE: STRUCT: POSTPONE: UNION-STRUCT: } related-words
+
+HELP: struct-class
+{ $class-description "The metaclass of all " { $link struct } " classes." } ;
+
+ARTICLE: "classes.struct" "Struct classes"
+{ $link struct } " classes are similar to " { $link tuple } "s, but their slots exhibit value semantics, and they are backed by a contiguous structured block of memory. Structs can be used for structured access to C memory or Factor byte arrays and for passing struct values in and out of the FFI. Struct types are defined using a syntax similar to tuple syntax:"
+{ $subsection POSTPONE: STRUCT: }
+"Structs can be allocated with " { $link new } "- and " { $link boa } "-like constructor words. Additional words are provided for building structs from C memory and from existing buffers:"
+{ $subsection <struct> }
+{ $subsection <struct-boa> }
+{ $subsection malloc-struct }
+{ $subsection memory>struct }
+"Structs have literal syntax like tuples:"
+{ $subsection POSTPONE: S{ }
+"Union structs are also supported, which behave like structs but share the same memory for all the type's slots."
+{ $subsection POSTPONE: UNION-STRUCT: }
+;
+
+ABOUT: "classes.struct"

basis/classes/struct/struct-tests.factor

@@ -0,0 +1,205 @@
+! (c)Joe Groff bsd license
+USING: accessors alien.c-types alien.libraries
+alien.structs.fields alien.syntax ascii classes.struct combinators
+destructors io.encodings.utf8 io.pathnames io.streams.string
+kernel libc literals math multiline namespaces prettyprint
+prettyprint.config see sequences specialized-arrays.ushort
+system tools.test compiler.tree.debugger struct-arrays
+classes.tuple.private specialized-arrays.direct.int
+compiler.units ;
+IN: classes.struct.tests
+
+<<
+: libfactor-ffi-tests-path ( -- string )
+    "resource:" (normalize-path)
+    {
+        { [ os winnt? ]  [ "libfactor-ffi-test.dll" ] }
+        { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
+        { [ os unix?  ]  [ "libfactor-ffi-test.so" ] }
+    } cond append-path ;
+
+"f-cdecl" libfactor-ffi-tests-path "cdecl" add-library
+
+"f-stdcall" libfactor-ffi-tests-path "stdcall" add-library
+>>
+
+SYMBOL: struct-test-empty
+
+[ [ struct-test-empty { } define-struct-class ] with-compilation-unit ]
+[ struct-must-have-slots? ] must-fail-with
+
+STRUCT: struct-test-foo
+    { x char }
+    { y int initial: 123 }
+    { z bool } ;
+
+STRUCT: struct-test-bar
+    { w ushort initial: HEX: ffff }
+    { foo struct-test-foo } ;
+
+[ 12 ] [ struct-test-foo heap-size ] unit-test
+[ 12 ] [ struct-test-foo <struct> byte-length ] unit-test
+[ 16 ] [ struct-test-bar heap-size ] unit-test
+[ 123 ] [ struct-test-foo <struct> y>> ] unit-test
+[ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test
+
+[ 1 2 3 t ] [
+    1   2 3 t struct-test-foo <struct-boa>   struct-test-bar <struct-boa>
+    {
+        [ w>> ] 
+        [ foo>> x>> ]
+        [ foo>> y>> ]
+        [ foo>> z>> ]
+    } cleave
+] unit-test
+
+[ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test
+[ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test
+
+UNION-STRUCT: struct-test-float-and-bits
+    { f float }
+    { bits uint } ;
+
+[ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
+[ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
+
+[ ] [ [ struct-test-foo malloc-struct &free drop ] with-destructors ] unit-test
+
+STRUCT: struct-test-string-ptr
+    { x char* } ;
+
+[ "hello world" ] [
+    [
+        struct-test-string-ptr <struct>
+        "hello world" utf8 malloc-string &free >>x
+        x>>
+    ] with-destructors
+] unit-test
+
+[ "S{ struct-test-foo { y 7654 } }" ]
+[
+    f boa-tuples?
+    [ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
+    with-variable
+] unit-test
+
+[ "S{ struct-test-foo f 0 7654 f }" ]
+[
+    t boa-tuples?
+    [ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
+    with-variable
+] unit-test
+
+[ <" USING: classes.struct ;
+IN: classes.struct.tests
+STRUCT: struct-test-foo
+    { x char initial: 0 } { y int initial: 123 } { z bool } ;
+"> ]
+[ [ struct-test-foo see ] with-string-writer ] unit-test
+
+[ <" USING: classes.struct ;
+IN: classes.struct.tests
+UNION-STRUCT: struct-test-float-and-bits
+    { f float initial: 0.0 } { bits uint initial: 0 } ;
+"> ]
+[ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
+
+[ {
+    T{ field-spec
+        { name "x" }
+        { offset 0 }
+        { type "char" }
+        { reader x>> }
+        { writer (>>x) }
+    }
+    T{ field-spec
+        { name "y" }
+        { offset 4 }
+        { type "int" }
+        { reader y>> }
+        { writer (>>y) }
+    }
+    T{ field-spec
+        { name "z" }
+        { offset 8 }
+        { type "bool" }
+        { reader z>> }
+        { writer (>>z) }
+    }
+} ] [ "struct-test-foo" c-type fields>> ] unit-test
+
+[ {
+    T{ field-spec
+        { name "f" }
+        { offset 0 }
+        { type "float" }
+        { reader f>> }
+        { writer (>>f) }
+    }
+    T{ field-spec
+        { name "bits" }
+        { offset 0 }
+        { type "uint" }
+        { reader bits>> }
+        { writer (>>bits) }
+    }
+} ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test
+
+STRUCT: struct-test-equality-1
+    { x int } ;
+STRUCT: struct-test-equality-2
+    { y int } ;
+
+[ t ] [
+    [
+        struct-test-equality-1 <struct> 5 >>x
+        struct-test-equality-1 malloc-struct &free 5 >>x =
+    ] with-destructors
+] unit-test
+
+[ f ] [
+    [
+        struct-test-equality-1 <struct> 5 >>x
+        struct-test-equality-2 malloc-struct &free 5 >>y =
+    ] with-destructors
+] unit-test
+
+STRUCT: struct-test-ffi-foo
+    { x int }
+    { y int } ;
+
+LIBRARY: f-cdecl
+FUNCTION: int ffi_test_11 ( int a, struct-test-ffi-foo b, int c ) ;
+
+[ 14 ] [ 1 2 3 struct-test-ffi-foo <struct-boa> 4 ffi_test_11 ] unit-test
+
+STRUCT: struct-test-array-slots
+    { x int }
+    { y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } }
+    { z int } ;
+
+[ 11 ] [ struct-test-array-slots <struct> y>> 4 swap nth ] unit-test
+
+[ t ] [
+    struct-test-array-slots <struct>
+    [ y>> [ 8 3 ] dip set-nth ]
+    [ y>> ushort-array{ 2 3 5 8 11 13 } sequence= ] bi
+] unit-test
+
+STRUCT: struct-test-optimization
+    { x { "int" 3 } } { y int } ;
+
+[ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
+[ t ] [
+    [ 3 struct-test-optimization <direct-struct-array> third y>> ]
+    { <tuple> <tuple-boa> memory>struct y>> } inlined?
+] unit-test
+
+[ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
+
+[ t ] [
+    [ struct-test-optimization memory>struct x>> second ]
+    { memory>struct x>> <direct-int-array> <tuple> <tuple-boa> } inlined?
+] unit-test
+
+[ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test

basis/classes/struct/struct.factor

@@ -0,0 +1,264 @@
+! (c)Joe Groff bsd license
+USING: accessors alien alien.c-types alien.structs
+alien.structs.fields arrays byte-arrays classes classes.parser
+classes.tuple classes.tuple.parser classes.tuple.private
+combinators combinators.short-circuit combinators.smart fry
+generalizations generic.parser kernel kernel.private lexer
+libc macros make math math.order parser quotations sequences
+slots slots.private struct-arrays vectors words
+compiler.tree.propagation.transforms ;
+FROM: slots => reader-word writer-word ;
+IN: classes.struct
+
+! struct class
+
+ERROR: struct-must-have-slots ;
+
+TUPLE: struct
+    { (underlying) c-ptr read-only } ;
+
+TUPLE: struct-slot-spec < slot-spec
+    c-type ;
+
+PREDICATE: struct-class < tuple-class
+    { [ \ struct subclass-of? ] [ all-slots length 1 = ] } 1&& ;
+
+: struct-slots ( struct -- slots )
+    "struct-slots" word-prop ;
+
+! struct allocation
+
+M: struct >c-ptr
+    2 slot { c-ptr } declare ; inline
+
+M: struct equal?
+    {
+        [ [ class ] bi@ = ]
+        [ [ >c-ptr ] [ [ >c-ptr ] [ byte-length ] bi ] bi* memory= ]
+    } 2&& ;
+
+: memory>struct ( ptr class -- struct )
+    [ 1array ] dip slots>tuple ;
+
+\ memory>struct [
+    dup struct-class? [ '[ _ boa ] ] [ drop f ] if
+] 1 define-partial-eval
+
+: malloc-struct ( class -- struct )
+    [ heap-size malloc ] keep memory>struct ; inline
+
+: (struct) ( class -- struct )
+    [ heap-size <byte-array> ] keep memory>struct ; inline
+
+: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
+
+: <struct> ( class -- struct )
+    dup struct-prototype
+    [ >c-ptr clone swap memory>struct ] [ (struct) ] if* ; inline
+
+MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
+    [
+        [ <wrapper> \ (struct) [ ] 2sequence ]
+        [
+            struct-slots
+            [ length \ ndip ]
+            [ [ name>> setter-word 1quotation ] map \ spread ] bi
+        ] bi
+    ] [ ] output>sequence ;
+
+: pad-struct-slots ( values class -- values' class )
+    [ struct-slots [ initial>> ] map over length tail append ] keep ;
+
+: (reader-quot) ( slot -- quot )
+    [ c-type>> c-type-getter-boxer ]
+    [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
+
+: (writer-quot) ( slot -- quot )
+    [ c-type>> c-setter ]
+    [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
+
+: (boxer-quot) ( class -- quot )
+    '[ _ memory>struct ] ;
+
+: (unboxer-quot) ( class -- quot )
+    drop [ >c-ptr ] ;
+
+M: struct-class boa>object
+    swap pad-struct-slots
+    [ (struct) ] [ struct-slots ] bi 
+    [ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
+
+! Struct slot accessors
+
+GENERIC: struct-slot-values ( struct -- sequence )
+
+M: struct-class reader-quot
+    nip (reader-quot) ;
+
+M: struct-class writer-quot
+    nip (writer-quot) ;
+
+: struct-slot-values-quot ( class -- quot )
+    struct-slots
+    [ name>> reader-word 1quotation ] map
+    \ cleave [ ] 2sequence
+    \ output>array [ ] 2sequence ;
+
+: (define-struct-slot-values-method) ( class -- )
+    [ \ struct-slot-values create-method-in ]
+    [ struct-slot-values-quot ] bi define ;
+
+: (define-byte-length-method) ( class -- )
+    [ \ byte-length create-method-in ]
+    [ heap-size \ drop swap [ ] 2sequence ] bi define ;
+
+! Struct as c-type
+
+: slot>field ( slot -- field )
+    field-spec new swap {
+        [ name>> >>name ]
+        [ offset>> >>offset ]
+        [ c-type>> >>type ]
+        [ name>> reader-word >>reader ]
+        [ name>> writer-word >>writer ]
+    } cleave ;
+
+: define-struct-for-class ( class -- )
+    [
+        {
+            [ name>> ]
+            [ "struct-size" word-prop ]
+            [ "struct-align" word-prop ]
+            [ struct-slots [ slot>field ] map ]
+        } cleave
+        struct-type (define-struct)
+    ] [
+        {
+            [ name>> c-type ]
+            [ (unboxer-quot) >>unboxer-quot ]
+            [ (boxer-quot) >>boxer-quot ]
+            [ >>boxed-class ]
+        } cleave drop
+    ] bi ;
+
+: align-offset ( offset class -- offset' )
+    c-type-align align ;
+
+: struct-offsets ( slots -- size )
+    0 [
+        [ c-type>> align-offset ] keep
+        [ (>>offset) ] [ c-type>> heap-size + ] 2bi
+    ] reduce ;
+
+: union-struct-offsets ( slots -- size )
+    [ 0 >>offset c-type>> heap-size ] [ max ] map-reduce ;
+
+: struct-align ( slots -- align )
+    [ c-type>> c-type-align ] [ max ] map-reduce ;
+
+M: struct-class c-type
+    name>> c-type ;
+
+M: struct-class c-type-align
+    "struct-align" word-prop ;
+
+M: struct-class c-type-getter
+    drop [ swap <displaced-alien> ] ;
+
+M: struct-class c-type-setter
+    [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
+    '[ @ swap @ _ memcpy ] ;
+
+M: struct-class c-type-boxer-quot
+    (boxer-quot) ;
+
+M: struct-class c-type-unboxer-quot
+    (unboxer-quot) ;
+
+M: struct-class heap-size
+    "struct-size" word-prop ;
+
+! class definition
+
+: make-struct-prototype ( class -- prototype )
+    [ heap-size <byte-array> ]
+    [ memory>struct ]
+    [ struct-slots ] tri
+    [
+        [ initial>> ]
+        [ (writer-quot) ] bi
+        over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if
+    ] each ;
+
+: (struct-methods) ( class -- )
+    [ (define-struct-slot-values-method) ]
+    [ (define-byte-length-method) ] bi ;
+
+: (struct-word-props) ( class slots size align -- )
+    [
+        [ "struct-slots" set-word-prop ]
+        [ define-accessors ] 2bi
+    ]
+    [ "struct-size" set-word-prop ]
+    [ "struct-align" set-word-prop ] tri-curry*
+    [ tri ] 3curry
+    [ dup make-struct-prototype "prototype" set-word-prop ]
+    [ (struct-methods) ] tri ;
+
+: check-struct-slots ( slots -- )
+    [ c-type>> c-type drop ] each ;
+
+: (define-struct-class) ( class slots offsets-quot -- )
+    [ 
+        [ struct-must-have-slots ]
+        [ drop struct f define-tuple-class ] if-empty
+    ]
+    swap '[
+        make-slots dup
+        [ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
+        (struct-word-props)
+    ]
+    [ drop define-struct-for-class ] 2tri ; inline
+
+: define-struct-class ( class slots -- )
+    [ struct-offsets ] (define-struct-class) ;
+
+: define-union-struct-class ( class slots -- )
+    [ union-struct-offsets ] (define-struct-class) ;
+
+ERROR: invalid-struct-slot token ;
+
+: struct-slot-class ( c-type -- class' )
+    c-type c-type-boxed-class
+    dup \ byte-array = [ drop \ c-ptr ] when ;
+
+: scan-c-type ( -- c-type )
+    scan dup "{" = [ drop \ } parse-until >array ] when ;
+
+: parse-struct-slot ( -- slot )
+    struct-slot-spec new
+    scan >>name
+    scan-c-type [ >>c-type ] [ struct-slot-class >>class ] bi
+    \ } parse-until [ dup empty? ] [ peel-off-attributes ] until drop ;
+    
+: parse-struct-slots ( slots -- slots' more? )
+    scan {
+        { ";" [ f ] }
+        { "{" [ parse-struct-slot over push t ] }
+        [ invalid-struct-slot ]
+    } case ;
+
+: parse-struct-definition ( -- class slots )
+    CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array ;
+
+SYNTAX: STRUCT:
+    parse-struct-definition define-struct-class ;
+SYNTAX: UNION-STRUCT:
+    parse-struct-definition define-union-struct-class ;
+
+SYNTAX: S{
+    scan-word dup struct-slots parse-tuple-literal-slots parsed ;
+
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [ "classes.struct.prettyprint" require ] when

basis/cocoa/application/application.factor

@@ -18,7 +18,7 @@ NSApplicationDelegateReplyFailure ;
 
 : NSApp ( -- app ) NSApplication -> sharedApplication ;
 
-: NSAnyEventMask ( -- mask ) HEX: ffffffff ; inline
+CONSTANT: NSAnyEventMask HEX: ffffffff
 
 FUNCTION: void NSBeep ( ) ;
 

basis/cocoa/callbacks/callbacks.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2006 Kevin Reid.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: cocoa.callbacks
 USING: assocs kernel namespaces cocoa cocoa.classes
 cocoa.subclassing debugger ;
+IN: cocoa.callbacks
 
 SYMBOL: callbacks
 

basis/cocoa/cocoa-tests.factor

@@ -1,7 +1,7 @@
-IN: cocoa.tests
 USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
 compiler kernel namespaces cocoa.classes tools.test memory
 compiler.units math core-graphics.types ;
+IN: cocoa.tests
 
 CLASS: {
     { +superclass+ "NSObject" }

basis/cocoa/messages/messages.factor

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

basis/cocoa/plists/plists-tests.factor

@@ -1,7 +1,7 @@
-IN: cocoa.plists.tests
 USING: tools.test cocoa.plists colors kernel hashtables
 core-foundation.utilities core-foundation destructors
 assocs cocoa.enumeration ;
+IN: cocoa.plists.tests
 
 [
     [ V{ } ] [ H{ } >cf &CFRelease [ ] NSFastEnumeration-map ] unit-test

basis/cocoa/views/views.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2006, 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: specialized-arrays.int arrays kernel math namespaces make
+USING: arrays kernel math namespaces make
 cocoa cocoa.messages cocoa.classes core-graphics
 core-graphics.types sequences continuations accessors ;
 IN: cocoa.views

basis/colors/constants/constants.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs math math.parser memoize
+USING: kernel assocs math math.parser memoize io.encodings.utf8
-io.encodings.ascii io.files lexer parser
+io.files lexer parser colors sequences splitting
-colors sequences splitting combinators.smart ascii ;
+combinators.smart ascii ;
 IN: colors.constants
 
 <PRIVATE
@@ -19,7 +19,7 @@ IN: colors.constants
     [ parse-color ] H{ } map>assoc ;
 
 MEMO: rgb.txt ( -- assoc )
-    "resource:basis/colors/constants/rgb.txt" ascii file-lines parse-rgb.txt ;
+    "resource:basis/colors/constants/rgb.txt" utf8 file-lines parse-rgb.txt ;
 
 PRIVATE>
 

basis/colors/hsv/hsv-tests.factor

@@ -1,5 +1,5 @@
-IN: colors.hsv.tests
 USING: accessors kernel colors colors.hsv tools.test math ;
+IN: colors.hsv.tests
 
 : hsv>rgb ( h s v -- r g b )
     [ 360 * ] 2dip

basis/columns/columns-tests.factor

@@ -1,5 +1,5 @@
-IN: columns.tests
 USING: columns sequences kernel namespaces arrays tools.test math ;
+IN: columns.tests
 
 ! Columns
 { { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set

basis/combinators/short-circuit/short-circuit-docs.factor

@@ -13,27 +13,27 @@ HELP: 0||
 { $description "If every quotation in the sequence outputs " { $link f } ", outputs " { $link f } ", otherwise outputs the result of the first quotation that did not yield " { $link f } "." } ;
 
 HELP: 1&&
-{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
+{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
 { $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
 
 HELP: 1||
-{ $values { "obj" object } { "quots" "a sequence of quotations" } { "?" "the first true result, or " { $link f } } }
+{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj -- )" } } { "?" "the first true result, or " { $link f } } }
 { $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same element from the datastack and must return a boolean." } ;
 
 HELP: 2&&
-{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
+{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
 { $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
 
 HELP: 2||
-{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations" } { "?" "the first true result, or " { $link f } } }
+{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 -- )" } } { "?" "the first true result, or " { $link f } } }
 { $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same two elements from the datastack and must return a boolean." } ;
 
 HELP: 3&&
-{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
+{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 obj3 -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
 { $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
 
 HELP: 3||
-{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations" } { "?" "the first true result, or " { $link f } } }
+{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 obj3 -- )" } } { "?" "the first true result, or " { $link f } } }
 { $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same three elements from the datastack and must return a boolean." } ;
 
 HELP: n&&

basis/combinators/short-circuit/smart/smart-tests.factor

@@ -1,32 +1,18 @@
-
 USING: kernel math tools.test combinators.short-circuit.smart ;
-
 IN: combinators.short-circuit.smart.tests
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+[ t ] [       { [ 1 ] [ 2 ] [ 3 ] }          &&  3 = ] unit-test
+[ t ] [ 3     { [ 0 > ] [ odd? ] [ 2 + ] }    &&  5 = ] unit-test
+[ t ] [ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] unit-test
 
-: must-be-t ( in -- ) [ t ] swap unit-test ;
+[ f ] [       { [ 1 ] [ f ] [ 3 ] } &&  3 = ]          unit-test
-: must-be-f ( in -- ) [ f ] swap unit-test ;
+[ f ] [ 3     { [ 0 > ] [ even? ] [ 2 + ] } && ]       unit-test
+[ f ] [ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] unit-test
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+[ t ] [ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] unit-test
 
-[       { [ 1 ] [ 2 ] [ 3 ] }          &&  3 = ] must-be-t
+[ t ] [ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ]       unit-test
-[ 3     { [ 0 > ] [ odd? ] [ 2 + ] }    &&  5 = ] must-be-t
-[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] must-be-t
 
-[       { [ 1 ] [ f ] [ 3 ] } &&  3 = ]          must-be-f
+[ t ] [ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ]  unit-test
-[ 3     { [ 0 > ] [ even? ] [ 2 + ] } && ]       must-be-f
-[ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] must-be-f
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-[ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] must-be-t
-
-[ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ]       must-be-t
-
-[ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ]  must-be-t
-
-[ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] must-be-f
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+[ f ] [ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] unit-test

basis/combinators/short-circuit/smart/smart.factor

@@ -1,13 +1,15 @@
-USING: kernel sequences math stack-checker effects accessors macros
+USING: kernel sequences math stack-checker effects accessors
-fry combinators.short-circuit ;
+macros fry combinators.short-circuit ;
 IN: combinators.short-circuit.smart
 
 <PRIVATE
 
+ERROR: cannot-determine-arity ;
+
 : arity ( quots -- n )
     first infer
-    dup terminated?>> [ "Cannot determine arity" throw ] when
+    dup terminated?>> [ cannot-determine-arity ] when
-    effect-height neg 1+ ;
+    effect-height neg 1 + ;
 
 PRIVATE>
 

basis/combinators/smart/smart-docs.factor

@@ -28,7 +28,7 @@ HELP: output>array
     { $example
         <" USING: combinators combinators.smart math prettyprint ;
 9 [
-    { [ 1- ] [ 1+ ] [ sq ] } cleave
+    { [ 1 - ] [ 1 + ] [ sq ] } cleave
 ] output>array .">
     "{ 8 10 81 }"
     }
@@ -71,7 +71,7 @@ HELP: sum-outputs
 { $examples
     { $example
         "USING: combinators.smart kernel math prettyprint ;"
-        "10 [ [ 1- ] [ 1+ ] bi ] sum-outputs ."
+        "10 [ [ 1 - ] [ 1 + ] bi ] sum-outputs ."
         "20"
     }
 } ;
@@ -106,11 +106,21 @@ HELP: append-outputs-as
 
 { append-outputs append-outputs-as } related-words
 
+HELP: drop-outputs
+{ $values { "quot" quotation } }
+{ $description "Calls a quotation and drops any values it leaves on the stack." } ;
+
+HELP: keep-inputs
+{ $values { "quot" quotation } }
+{ $description "Calls a quotation and preserves any values it takes off the stack." } ;
+
+{ drop-outputs keep-inputs } related-words
 
 ARTICLE: "combinators.smart" "Smart combinators"
 "A " { $emphasis "smart combinator" } " is a macro which reflects on the stack effect of an input quotation. The " { $vocab-link "combinators.smart" } " vocabulary implements a few simple smart combinators which look at the static stack effects of input quotations and generate code which produces or consumes the relevant number of stack values." $nl
-"Call a quotation and discard all output values:"
+"Call a quotation and discard all output values or preserve all input values:"
 { $subsection drop-outputs }
+{ $subsection keep-inputs }
 "Take all input values from a sequence:"
 { $subsection input<sequence }
 "Store all output values to a sequence:"

basis/combinators/smart/smart-tests.factor

@@ -4,7 +4,7 @@ USING: tools.test combinators.smart math kernel accessors ;
 IN: combinators.smart.tests
 
 : test-bi ( -- 9 11 )
-    10 [ 1- ] [ 1+ ] bi ;
+    10 [ 1 - ] [ 1 + ] bi ;
 
 [ [ test-bi ] output>array ] must-infer
 [ { 9 11 } ] [ [ test-bi ] output>array ] unit-test

basis/combinators/smart/smart.factor

@@ -1,12 +1,15 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors fry generalizations kernel macros math.order
-stack-checker math ;
+stack-checker math sequences ;
 IN: combinators.smart
 
 MACRO: drop-outputs ( quot -- quot' )
     dup infer out>> '[ @ _ ndrop ] ;
 
+MACRO: keep-inputs ( quot -- quot' )
+    dup infer in>> '[ _ _ nkeep ] ;
+
 MACRO: output>sequence ( quot exemplar -- newquot )
     [ dup infer out>> ] dip
     '[ @ _ _ nsequence ] ;
@@ -39,3 +42,9 @@ MACRO: append-outputs-as ( quot exemplar -- newquot )
 
 MACRO: append-outputs ( quot -- seq )
     '[ _ { } append-outputs-as ] ;
+
+MACRO: preserving ( quot -- )
+    [ infer in>> length ] keep '[ _ ndup @ ] ;
+
+MACRO: smart-if ( pred true false -- )
+    '[ _ preserving _ _ if ] ; inline

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

@@ -1 +0,0 @@
-IN: compiler.cfg.alias-analysis.tests

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

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math namespaces assocs hashtables sequences arrays
-accessors vectors combinators sets classes compiler.cfg
+accessors vectors combinators sets classes cpu.architecture compiler.cfg
 compiler.cfg.registers compiler.cfg.instructions
 compiler.cfg.copy-prop compiler.cfg.rpo compiler.cfg.liveness ;
 IN: compiler.cfg.alias-analysis
@@ -144,7 +144,7 @@ ERROR: vreg-has-no-slots vreg ;
 SYMBOL: ac-counter
 
 : next-ac ( -- n )
-    ac-counter [ dup 1+ ] change ;
+    ac-counter [ dup 1 + ] change ;
 
 ! Alias class for objects which are loaded from the data stack
 ! or other object slots. We pessimistically assume that they
@@ -226,7 +226,7 @@ M: ##read analyze-aliases*
     call-next-method
     dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
     2dup live-slot dup [
-        2nip \ ##copy new-insn analyze-aliases* nip
+        2nip any-rep \ ##copy new-insn analyze-aliases* nip
     ] [
         drop remember-slot
     ] if ;

basis/compiler/cfg/block-joining/block-joining.factor

@@ -2,12 +2,12 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators.short-circuit kernel sequences math
 compiler.utilities compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
-compiler.cfg.utilities ;
+compiler.cfg.predecessors compiler.cfg.utilities ;
 IN: compiler.cfg.block-joining
 
 ! Joining blocks that are not calls and are connected by a single CFG edge.
-! Predecessors must be recomputed after this. Also this pass does not
+! This pass does not update ##phi nodes and should therefore only run
-! update ##phi nodes and should therefore only run before stack analysis.
+! before stack analysis.
 : join-block? ( bb -- ? )
     {
         [ kill-block? not ]
@@ -27,8 +27,11 @@ IN: compiler.cfg.block-joining
     [ join-instructions ] [ update-successors ] 2bi ;
 
 : join-blocks ( cfg -- cfg' )
+    needs-predecessors
+
     dup post-order [
         dup join-block?
         [ dup predecessor join-block ] [ drop ] if
     ] each
-    cfg-changed ;
+
+    cfg-changed predecessors-changed ;

basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor

@@ -9,11 +9,11 @@ IN: compiler.cfg.branch-splitting.tests
 
 : check-predecessors ( cfg -- )
     [ get-predecessors ]
-    [ compute-predecessors drop ]
+    [ needs-predecessors drop ]
     [ get-predecessors ] tri assert= ;
 
 : check-branch-splitting ( cfg -- )
-    compute-predecessors
+    needs-predecessors
     split-branches
     check-predecessors ;
 
@@ -46,11 +46,11 @@ V{ T{ ##branch } } 4 test-bb
 
 V{ T{ ##branch } } 5 test-bb
 
-0 get 1 get 2 get V{ } 2sequence >>successors drop
+0 { 1 2 } edges
 
-1 get 3 get 4 get V{ } 2sequence >>successors drop
+1 { 3 4 } edges
 
-2 get 3 get 4 get V{ } 2sequence >>successors drop
+2 { 3 4 } edges
 
 [ ] [ test-branch-splitting ] unit-test
 
@@ -64,11 +64,11 @@ V{ T{ ##branch } } 3 test-bb
 
 V{ T{ ##branch } } 4 test-bb
 
-0 get 1 get 2 get V{ } 2sequence >>successors drop
+0 { 1 2 } edges
 
-1 get 3 get 4 get V{ } 2sequence >>successors drop
+1 { 3 4 } edges
 
-2 get 4 get 1vector >>successors drop
+2 4 edge
 
 [ ] [ test-branch-splitting ] unit-test
 
@@ -78,8 +78,8 @@ V{ T{ ##branch } } 1 test-bb
 
 V{ T{ ##branch } } 2 test-bb
 
-0 get 1 get 2 get V{ } 2sequence >>successors drop
+0 { 1 2 } edges
 
-1 get 2 get 1vector >>successors drop
+1 2 edge
 
 [ ] [ test-branch-splitting ] unit-test

basis/compiler/cfg/branch-splitting/branch-splitting.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators.short-circuit kernel math math.order
 sequences assocs namespaces vectors fry arrays splitting
-compiler.cfg.def-use compiler.cfg compiler.cfg.rpo
+compiler.cfg.def-use compiler.cfg compiler.cfg.rpo compiler.cfg.predecessors
 compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ;
 IN: compiler.cfg.branch-splitting
 
@@ -81,7 +81,10 @@ UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ;
     ] if ;
 
 : split-branches ( cfg -- cfg' )
+    needs-predecessors
+    
     dup [
         dup split-branch? [ split-branch ] [ drop ] if
     ] each-basic-block
+
     cfg-changed ;

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

@@ -1,15 +1,13 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces accessors math.order assocs kernel sequences
-combinators make classes words cpu.architecture
+combinators make classes words cpu.architecture layouts
 compiler.cfg.instructions compiler.cfg.registers
 compiler.cfg.stack-frame ;
 IN: compiler.cfg.build-stack-frame
 
 SYMBOL: frame-required?
 
-SYMBOL: spill-counts
-
 GENERIC: compute-stack-frame* ( insn -- )
 
 : request-stack-frame ( stack-frame -- )
@@ -30,11 +28,11 @@ M: ##call compute-stack-frame*
 
 M: _gc compute-stack-frame*
     frame-required? on
-    stack-frame new swap gc-root-size>> >>gc-root-size
+    stack-frame new swap tagged-values>> length cells >>gc-root-size
     request-stack-frame ;
 
-M: _spill-counts compute-stack-frame*
+M: _spill-area-size compute-stack-frame*
-    counts>> stack-frame get (>>spill-counts) ;
+    n>> stack-frame get (>>spill-area-size) ;
 
 M: insn compute-stack-frame*
     class frame-required? word-prop [
@@ -45,7 +43,7 @@ M: insn compute-stack-frame*
 
 : compute-stack-frame ( insns -- )
     frame-required? off
-    T{ stack-frame } clone stack-frame set
+    stack-frame new stack-frame set
     [ compute-stack-frame* ] each
     stack-frame get dup stack-frame-size >>total-size drop ;
 

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

@@ -1,14 +1,15 @@
-IN: compiler.cfg.builder.tests
 USING: tools.test kernel sequences words sequences.private fry
 prettyprint alien alien.accessors math.private compiler.tree.builder
 compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
 compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
-arrays locals byte-arrays kernel.private math slots.private vectors sbufs
+compiler.cfg arrays locals byte-arrays kernel.private math
-strings math.partial-dispatch strings.private ;
+slots.private vectors sbufs strings math.partial-dispatch
+strings.private accessors compiler.cfg.instructions ;
+IN: compiler.cfg.builder.tests
 
 ! Just ensure that various CFGs build correctly.
 : unit-test-cfg ( quot -- )
-    '[ _ test-cfg [ optimize-cfg check-cfg ] each ] [ ] swap unit-test ;
+    '[ _ test-cfg [ [ optimize-cfg check-cfg ] with-cfg ] each ] [ ] swap unit-test ;
 
 : blahblah ( nodes -- ? )
     { fixnum } declare [
@@ -156,3 +157,37 @@ strings math.partial-dispatch strings.private ;
     { pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-cfg
     { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg
 ] each
+
+: contains-insn? ( quot insn-check -- ? )
+    [ test-mr [ instructions>> ] map ] dip
+    '[ _ any? ] any? ; inline
+
+[ t ] [ [ swap ] [ ##replace? ] contains-insn? ] unit-test
+
+[ f ] [ [ swap swap ] [ ##replace? ] contains-insn? ] unit-test
+
+[ t ] [
+    [ { fixnum byte-array fixnum } declare set-alien-unsigned-1 ]
+    [ ##set-alien-integer-1? ] contains-insn?
+] unit-test
+
+[ t ] [
+    [ { fixnum byte-array fixnum } declare [ dup * dup * ] 2dip set-alien-unsigned-1 ]
+    [ ##set-alien-integer-1? ] contains-insn?
+] unit-test
+
+[ f ] [
+    [ { byte-array fixnum } declare set-alien-unsigned-1 ]
+    [ ##set-alien-integer-1? ] contains-insn?
+] unit-test
+
+[ f ] [
+    [ 1000 [ ] times ]
+    [ [ ##peek? ] [ ##replace? ] bi or ] contains-insn?
+] unit-test
+
+[ f t ] [
+    [ { fixnum simple-alien } declare <displaced-alien> 0 alien-cell ]
+    [ [ ##unbox-any-c-ptr? ] contains-insn? ]
+    [ [ ##slot-imm? ] contains-insn? ] bi
+] unit-test

basis/compiler/cfg/builder/builder.factor

@@ -19,6 +19,7 @@ compiler.cfg.instructions
 compiler.cfg.predecessors
 compiler.cfg.builder.blocks
 compiler.cfg.stacks
+compiler.cfg.stacks.local
 compiler.alien ;
 IN: compiler.cfg.builder
 
@@ -144,7 +145,7 @@ M: #dispatch emit-node
     ! Inputs to the final instruction need to be copied because of
     ! loc>vreg sync. ^^offset>slot always returns a fresh vreg,
     ! though.
-    ds-pop ^^offset>slot i ##dispatch emit-if ;
+    ds-pop ^^offset>slot next-vreg ##dispatch emit-if ;
 
 ! #call
 M: #call emit-node
@@ -159,14 +160,32 @@ M: #push emit-node
     literal>> ^^load-literal ds-push ;
 
 ! #shuffle
+
+! Even though low level IR has its own dead code elimination pass,
+! we try not to introduce useless ##peeks here, since this reduces
+! the accuracy of global stack analysis.
+
+: make-input-map ( #shuffle -- assoc )
+    ! Assoc maps high-level IR values to stack locations.
+    [
+        [ in-d>> <reversed> [ <ds-loc> swap set ] each-index ]
+        [ in-r>> <reversed> [ <rs-loc> swap set ] each-index ] bi
+    ] H{ } make-assoc ;
+
+: make-output-seq ( values mapping input-map -- vregs )
+    '[ _ at _ at peek-loc ] map ;
+
+: load-shuffle ( #shuffle mapping input-map -- ds-vregs rs-vregs )
+    [ [ out-d>> ] 2dip make-output-seq ]
+    [ [ out-r>> ] 2dip make-output-seq ] 3bi ;
+
+: store-shuffle ( #shuffle ds-vregs rs-vregs -- )
+    [ [ in-d>> length neg inc-d ] dip ds-store ]
+    [ [ in-r>> length neg inc-r ] dip rs-store ]
+    bi-curry* bi ;
+
 M: #shuffle emit-node
-    dup
+    dup dup [ mapping>> ] [ make-input-map ] bi load-shuffle store-shuffle ;
-    H{ } clone
-    [ [ in-d>> [ length ds-load ] keep ] dip '[ _ set-at ] 2each ]
-    [ [ in-r>> [ length rs-load ] keep ] dip '[ _ set-at ] 2each ]
-    [ nip ] 2tri
-    [ [ [ out-d>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map ds-store ]
-    [ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi ;
 
 ! #return
 : emit-return ( -- )
@@ -227,3 +246,5 @@ M: #copy emit-node drop ;
 M: #enter-recursive emit-node drop ;
 
 M: #phi emit-node drop ;
+
+M: #declare emit-node drop ;

basis/compiler/cfg/cfg.factor

@@ -19,11 +19,28 @@ M: basic-block hashcode* nip id>> ;
         V{ } clone >>predecessors
         \ basic-block counter >>id ;
 
-TUPLE: cfg { entry basic-block } word label spill-counts post-order ;
+TUPLE: cfg { entry basic-block } word label
+spill-area-size reps
+post-order linear-order
+predecessors-valid? dominance-valid? loops-valid? ;
 
-: <cfg> ( entry word label -- cfg ) f f cfg boa ;
+: <cfg> ( entry word label -- cfg )
+    cfg new
+        swap >>label
+        swap >>word
+        swap >>entry ;
 
-: cfg-changed ( cfg -- cfg ) f >>post-order ; inline
+: cfg-changed ( cfg -- cfg )
+    f >>post-order
+    f >>linear-order
+    f >>dominance-valid?
+    f >>loops-valid? ; inline
+
+: predecessors-changed ( cfg -- cfg )
+    f >>predecessors-valid? ;
+
+: with-cfg ( cfg quot: ( cfg -- ) -- )
+    [ dup cfg ] dip with-variable ; inline
 
 TUPLE: mr { instructions array } word label ;
 

basis/compiler/cfg/copy-prop/copy-prop.factor

@@ -1,12 +1,17 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces assocs accessors sequences grouping
-compiler.cfg.rpo compiler.cfg.renaming compiler.cfg.instructions ;
+combinators compiler.cfg.rpo compiler.cfg.renaming
+compiler.cfg.instructions compiler.cfg.predecessors ;
 IN: compiler.cfg.copy-prop
 
 ! The first three definitions are also used in compiler.cfg.alias-analysis.
 SYMBOL: copies
 
+! Initialized per-basic-block; a mapping from inputs to dst for eliminating
+! redundant phi instructions
+SYMBOL: phis
+
 : resolve ( vreg -- vreg )
     copies get ?at drop ;
 
@@ -22,17 +27,27 @@ GENERIC: visit-insn ( insn -- )
 
 M: ##copy visit-insn record-copy ;
 
+: useless-phi ( dst inputs -- ) first (record-copy) ;
+
+: redundant-phi ( dst inputs -- ) phis get at (record-copy) ;
+
+: record-phi ( dst inputs -- ) phis get set-at ;
+
 M: ##phi visit-insn
     [ dst>> ] [ inputs>> values [ resolve ] map ] bi
-    dup all-equal? [ first (record-copy) ] [ 2drop ] if ;
+    {
+        { [ dup all-equal? ] [ useless-phi ] }
+        { [ dup phis get key? ] [ redundant-phi ] }
+        [ record-phi ]
+    } cond ;
 
 M: insn visit-insn drop ;
 
 : collect-copies ( cfg -- )
     H{ } clone copies set
     [
-        instructions>>
+        H{ } clone phis set
-        [ visit-insn ] each
+        instructions>> [ visit-insn ] each
     ] each-basic-block ;
 
 GENERIC: update-insn ( insn -- keep? )
@@ -48,14 +63,15 @@ M: insn update-insn rename-insn-uses t ;
     copies get dup assoc-empty? [ 2drop ] [
         renamings set
         [
-            instructions>>
+            instructions>> [ update-insn ] filter-here
-            [ update-insn ] filter-here
         ] each-basic-block
     ] if ;
 
 PRIVATE>
 
 : copy-propagation ( cfg -- cfg' )
+    needs-predecessors
+
     [ collect-copies ]
     [ rename-copies ]
     [ ]

basis/compiler/cfg/critical-edges/critical-edges.factor

@@ -1,21 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math accessors sequences
-compiler.cfg compiler.cfg.rpo compiler.cfg.utilities ;
-IN: compiler.cfg.critical-edges
-
-: critical-edge? ( from to -- ? )
-    [ successors>> length 1 > ] [ predecessors>> length 1 > ] bi* and ;
-
-: split-critical-edge ( from to -- )
-    f <simple-block> insert-basic-block ;
-
-: split-critical-edges ( cfg -- )
-    dup [
-        dup successors>> [
-            2dup critical-edge?
-            [ split-critical-edge ] [ 2drop ] if
-        ] with each
-    ] each-basic-block
-    cfg-changed
-    drop ;

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

@@ -2,10 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs deques dlists kernel locals sequences lexer
 namespaces functors compiler.cfg.rpo compiler.cfg.utilities
-compiler.cfg ;
+compiler.cfg.predecessors compiler.cfg ;
 IN: compiler.cfg.dataflow-analysis
 
-GENERIC: join-sets ( sets dfa -- set )
+GENERIC: join-sets ( sets bb dfa -- set )
 GENERIC: transfer-set ( in-set bb dfa -- out-set )
 GENERIC: block-order ( cfg dfa -- bbs )
 GENERIC: successors ( bb dfa -- seq )
@@ -23,7 +23,11 @@ GENERIC# compute-in-set 2 ( bb out-sets dfa -- set )
 M: kill-block compute-in-set 3drop f ;
 
 M:: basic-block compute-in-set ( bb out-sets dfa -- set )
-    bb dfa predecessors [ out-sets at ] map dfa join-sets ;
+    ! Only consider initialized sets.
+    bb dfa predecessors
+    [ out-sets key? ] filter
+    [ out-sets at ] map
+    bb dfa join-sets ;
 
 :: update-in-set ( bb in-sets out-sets dfa -- ? )
     bb out-sets dfa compute-in-set
@@ -48,6 +52,7 @@ M:: basic-block compute-out-set ( bb in-sets dfa -- set )
     ] when ; inline
 
 :: run-dataflow-analysis ( cfg dfa -- in-sets out-sets )
+    cfg needs-predecessors drop
     H{ } clone :> in-sets
     H{ } clone :> out-sets
     cfg dfa <dfa-worklist> :> work-list
@@ -55,7 +60,7 @@ M:: basic-block compute-out-set ( bb in-sets dfa -- set )
     in-sets
     out-sets ; inline
 
-M: dataflow-analysis join-sets drop assoc-refine ;
+M: dataflow-analysis join-sets 2drop assoc-refine ;
 
 FUNCTOR: define-analysis ( name -- )
 

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

@@ -11,62 +11,62 @@ IN: compiler.cfg.dce.tests
     entry>> instructions>> ; 
 
 [ V{
-    T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
+    T{ ##load-immediate { dst 1 } { val 8 } }
-    T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
+    T{ ##load-immediate { dst 2 } { val 16 } }
-    T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
+    T{ ##add { dst 3 } { src1 1 } { src2 2 } }
-    T{ ##replace { src V int-regs 3 } { loc D 0 } }
+    T{ ##replace { src 3 } { loc D 0 } }
 } ] [ V{
-    T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
+    T{ ##load-immediate { dst 1 } { val 8 } }
-    T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
+    T{ ##load-immediate { dst 2 } { val 16 } }
-    T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
+    T{ ##add { dst 3 } { src1 1 } { src2 2 } }
-    T{ ##replace { src V int-regs 3 } { loc D 0 } }
+    T{ ##replace { src 3 } { loc D 0 } }
 } test-dce ] unit-test
 
 [ V{ } ] [ V{
-    T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
+    T{ ##load-immediate { dst 1 } { val 8 } }
-    T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
+    T{ ##load-immediate { dst 2 } { val 16 } }
-    T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
+    T{ ##add { dst 3 } { src1 1 } { src2 2 } }
 } test-dce ] unit-test
 
 [ V{ } ] [ V{
-    T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+    T{ ##load-immediate { dst 3 } { val 8 } }
-    T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+    T{ ##allot { dst 1 } { temp 2 } }
 } test-dce ] unit-test
 
 [ V{ } ] [ V{
-    T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+    T{ ##load-immediate { dst 3 } { val 8 } }
-    T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+    T{ ##allot { dst 1 } { temp 2 } }
-    T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+    T{ ##set-slot-imm { obj 1 } { src 3 } }
 } test-dce ] unit-test
 
 [ V{
-    T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+    T{ ##load-immediate { dst 3 } { val 8 } }
-    T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+    T{ ##allot { dst 1 } { temp 2 } }
-    T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+    T{ ##set-slot-imm { obj 1 } { src 3 } }
-    T{ ##replace { src V int-regs 1 } { loc D 0 } }
+    T{ ##replace { src 1 } { loc D 0 } }
 } ] [ V{
-    T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+    T{ ##load-immediate { dst 3 } { val 8 } }
-    T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+    T{ ##allot { dst 1 } { temp 2 } }
-    T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+    T{ ##set-slot-imm { obj 1 } { src 3 } }
-    T{ ##replace { src V int-regs 1 } { loc D 0 } }
+    T{ ##replace { src 1 } { loc D 0 } }
 } test-dce ] unit-test
 
 [ V{
-    T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+    T{ ##allot { dst 1 } { temp 2 } }
-    T{ ##replace { src V int-regs 1 } { loc D 0 } }
+    T{ ##replace { src 1 } { loc D 0 } }
 } ] [ V{
-    T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+    T{ ##allot { dst 1 } { temp 2 } }
-    T{ ##replace { src V int-regs 1 } { loc D 0 } }
+    T{ ##replace { src 1 } { loc D 0 } }
 } test-dce ] unit-test
 
 [ V{
-    T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+    T{ ##allot { dst 1 } { temp 2 } }
-    T{ ##replace { src V int-regs 1 } { loc D 0 } }
+    T{ ##replace { src 1 } { loc D 0 } }
-    T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+    T{ ##load-immediate { dst 3 } { val 8 } }
-    T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+    T{ ##set-slot-imm { obj 1 } { src 3 } }
 } ] [ V{
-    T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+    T{ ##allot { dst 1 } { temp 2 } }
-    T{ ##replace { src V int-regs 1 } { loc D 0 } }
+    T{ ##replace { src 1 } { loc D 0 } }
-    T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+    T{ ##load-immediate { dst 3 } { val 8 } }
-    T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+    T{ ##set-slot-imm { obj 1 } { src 3 } }
 } test-dce ] unit-test

basis/compiler/cfg/dce/dce.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs sets kernel namespaces sequences
 compiler.cfg.instructions compiler.cfg.def-use
-compiler.cfg.rpo ;
+compiler.cfg.rpo compiler.cfg.predecessors ;
 IN: compiler.cfg.dce
 
 ! Maps vregs to sequences of vregs
@@ -95,6 +95,8 @@ M: ##write-barrier live-insn? src>> live-vreg? ;
 M: insn live-insn? drop t ;
 
 : eliminate-dead-code ( cfg -- cfg' )
+    needs-predecessors
+
     init-dead-code
     dup
     [ [ instructions>> [ build-liveness-graph ] each ] each-basic-block ]

basis/compiler/cfg/debugger/debugger.factor

@@ -1,14 +1,16 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel words sequences quotations namespaces io vectors
-classes.tuple accessors prettyprint prettyprint.config
+arrays hashtables classes.tuple accessors prettyprint
-prettyprint.backend prettyprint.custom prettyprint.sections
+prettyprint.config assocs prettyprint.backend prettyprint.custom
-parser compiler.tree.builder compiler.tree.optimizer
+prettyprint.sections parser compiler.tree.builder
-compiler.cfg.builder compiler.cfg.linearization
+compiler.tree.optimizer cpu.architecture compiler.cfg.builder
-compiler.cfg.registers compiler.cfg.stack-frame
+compiler.cfg.linearization compiler.cfg.registers
-compiler.cfg.linear-scan compiler.cfg.two-operand
+compiler.cfg.stack-frame compiler.cfg.linear-scan
-compiler.cfg.optimizer
+compiler.cfg.two-operand compiler.cfg.optimizer
-compiler.cfg.mr compiler.cfg ;
+compiler.cfg.instructions compiler.cfg.utilities
+compiler.cfg.def-use compiler.cfg.rpo compiler.cfg.mr
+compiler.cfg.representations.preferred compiler.cfg ;
 IN: compiler.cfg.debugger
 
 GENERIC: test-cfg ( quot -- cfgs )
@@ -23,8 +25,10 @@ M: word test-cfg
 
 : test-mr ( quot -- mrs )
     test-cfg [
-        optimize-cfg
+        [
-        build-mr
+            optimize-cfg
+            build-mr
+        ] with-cfg
     ] map ;
 
 : insn. ( insn -- )
@@ -41,22 +45,38 @@ M: word test-cfg
     ] each ;
 
 ! Prettyprinting
-M: vreg pprint*
-    <block
-    \ V pprint-word [ reg-class>> pprint* ] [ n>> pprint* ] bi
-    block> ;
-
 : pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
 
 M: ds-loc pprint* \ D pprint-loc ;
 
 M: rs-loc pprint* \ R pprint-loc ;
 
+: resolve-phis ( bb -- )
+    [
+        [ [ [ get ] dip ] assoc-map ] change-inputs drop
+    ] each-phi ;
+
 : test-bb ( insns n -- )
-    [ <basic-block> swap >>number swap >>instructions ] keep set ;
+    [ <basic-block> swap >>number swap >>instructions dup ] keep set
+    resolve-phis ;
+
+: edge ( from to -- )
+    [ get ] bi@ 1vector >>successors drop ;
+
+: edges ( from tos -- )
+    [ get ] [ [ get ] V{ } map-as ] bi* >>successors drop ;
 
 : test-diamond ( -- )
-    1 get 1vector 0 get (>>successors)
+    0 1 edge
-    2 get 3 get V{ } 2sequence 1 get (>>successors)
+    1 { 2 3 } edges
-    4 get 1vector 2 get (>>successors)
+    2 4 edge
-    4 get 1vector 3 get (>>successors) ;
+    3 4 edge ;
+
+: fake-representations ( cfg -- )
+    post-order [
+        instructions>> [
+            [ [ temp-vregs ] [ temp-vreg-reps ] bi zip ]
+            [ [ defs-vreg ] [ defs-vreg-rep ] bi 2dup and [ 2array ] [ 2drop f ] if ]
+            bi [ suffix ] when*
+        ] map concat
+    ] map concat >hashtable representations set ;

basis/compiler/cfg/def-use/authors.txt

@@ -0,0 +1,2 @@
+Slava Pestov
+Daniel Ehrenberg

basis/compiler/cfg/def-use/def-use-tests.factor

@@ -0,0 +1,36 @@
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel tools.test accessors vectors sequences namespaces
+arrays
+cpu.architecture
+compiler.cfg.def-use
+compiler.cfg
+compiler.cfg.debugger
+compiler.cfg.instructions
+compiler.cfg.registers ;
+IN: compiler.cfg.def-use.tests
+
+V{
+    T{ ##peek f 0 D 0 }
+    T{ ##peek f 1 D 0 }
+    T{ ##peek f 2 D 0 }
+} 1 test-bb
+V{
+    T{ ##replace f 2 D 0 }
+} 2 test-bb
+1 2 edge
+V{
+    T{ ##replace f 0 D 0 }
+} 3 test-bb
+2 3 edge
+V{ } 4 test-bb
+V{ } 5 test-bb
+3 { 4 5 } edges
+V{
+    T{ ##phi f 2 H{ { 2 0 } { 3 1 } } }
+} 6 test-bb
+4 6 edge
+5 6 edge
+
+cfg new 1 get >>entry 0 set
+[ ] [ 0 get [ compute-defs ] [ compute-uses ] bi ] unit-test

basis/compiler/cfg/def-use/def-use.factor

@@ -1,7 +1,7 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays kernel assocs sequences namespaces fry
-sets compiler.cfg.rpo compiler.cfg.instructions ;
+sets compiler.cfg.rpo compiler.cfg.instructions locals ;
 IN: compiler.cfg.def-use
 
 GENERIC: defs-vreg ( insn -- vreg/f )
@@ -21,6 +21,7 @@ M: ##slot temp-vregs temp>> 1array ;
 M: ##set-slot temp-vregs temp>> 1array ;
 M: ##string-nth temp-vregs temp>> 1array ;
 M: ##set-string-nth-fast temp-vregs temp>> 1array ;
+M: ##box-displaced-alien temp-vregs temp>> 1array ;
 M: ##compare temp-vregs temp>> 1array ;
 M: ##compare-imm temp-vregs temp>> 1array ;
 M: ##compare-float temp-vregs temp>> 1array ;
@@ -80,18 +81,15 @@ SYMBOLS: defs insns uses ;
         ] each-basic-block
     ] keep insns set ;
 
-: compute-uses ( cfg -- )
+:: compute-uses ( cfg -- )
-    H{ } clone [
+    ! Here, a phi node uses its argument in the block that it comes from.
-        '[
+    H{ } clone :> use
-            dup instructions>> [
+    cfg [| block |
-                uses-vregs [
+        block instructions>> [
-                    _ conjoin-at
+            dup ##phi?
-                ] with each
+            [ inputs>> [ use conjoin-at ] assoc-each ]
-            ] with each
+            [ uses-vregs [ block swap use conjoin-at ] each ]
-        ] each-basic-block
+            if
-    ] keep
+        ] each
-    [ keys ] assoc-map
+    ] each-basic-block
-    uses set ;
+    use [ keys ] assoc-map uses set ;
-
-: compute-def-use ( cfg -- )
-    [ compute-defs ] [ compute-uses ] [ compute-insns ] tri ;

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

@@ -1,12 +1,11 @@
-IN: compiler.cfg.dominance.tests
 USING: tools.test sequences vectors namespaces kernel accessors assocs sets
 math.ranges arrays compiler.cfg compiler.cfg.dominance compiler.cfg.debugger
 compiler.cfg.predecessors ;
+IN: compiler.cfg.dominance.tests
 
 : test-dominance ( -- )
     cfg new 0 get >>entry
-    compute-predecessors
+    needs-dominance drop ;
-    compute-dominance ;
 
 ! Example with no back edges
 V{ } 0 test-bb
@@ -16,11 +15,11 @@ V{ } 3 test-bb
 V{ } 4 test-bb
 V{ } 5 test-bb
 
-0 get 1 get 2 get V{ } 2sequence >>successors drop
+0 { 1 2 } edges
-1 get 3 get 1vector >>successors drop
+1 3 edge
-2 get 4 get 1vector >>successors drop
+2 4 edge
-3 get 4 get 1vector >>successors drop
+3 4 edge
-4 get 5 get 1vector >>successors drop
+4 5 edge
 
 [ ] [ test-dominance ] unit-test
 
@@ -46,11 +45,11 @@ V{ } 2 test-bb
 V{ } 3 test-bb
 V{ } 4 test-bb
 
-0 get 1 get 2 get V{ } 2sequence >>successors drop
+0 { 1 2 } edges
-1 get 3 get 1vector >>successors drop
+1 3 edge
-2 get 4 get 1vector >>successors drop
+2 4 edge
-3 get 4 get 1vector >>successors drop
+3 4 edge
-4 get 3 get 1vector >>successors drop
+4 3 edge
 
 [ ] [ test-dominance ] unit-test
 
@@ -64,12 +63,12 @@ V{ } 3 test-bb
 V{ } 4 test-bb
 V{ } 5 test-bb
 
-0 get 1 get 2 get V{ } 2sequence >>successors drop
+0 { 1 2 } edges
-1 get 5 get 1vector >>successors drop
+1 5 edge
-2 get 4 get 3 get V{ } 2sequence >>successors drop
+2 { 4 3 } edges
-5 get 4 get 1vector >>successors drop
+5 4 edge
-4 get 5 get 3 get V{ } 2sequence >>successors drop
+4 { 5 3 } edges
-3 get 4 get 1vector >>successors drop
+3 4 edge
 
 [ ] [ test-dominance ] unit-test
 

basis/compiler/cfg/dominance/dominance.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs combinators sets math fry kernel math.order
 dlists deques vectors namespaces sequences sorting locals
-compiler.cfg.rpo ;
+compiler.cfg.rpo compiler.cfg.predecessors ;
 IN: compiler.cfg.dominance
 
 ! Reference:
@@ -83,10 +83,14 @@ PRIVATE>
     H{ } clone maxpreorder set
     [ 0 ] dip entry>> (compute-dfs) drop ;
 
+: compute-dominance ( cfg -- cfg' )
+    [ compute-dom-parents compute-dom-children ] [ compute-dfs ] [ ] tri ;
+
 PRIVATE>
 
-: compute-dominance ( cfg -- )
+: needs-dominance ( cfg -- cfg' )
-    [ compute-dom-parents compute-dom-children ] [ compute-dfs ] bi ;
+    needs-predecessors
+    dup dominance-valid?>> [ compute-dominance t >>dominance-valid? ] unless ;
 
 : dominates? ( bb1 bb2 -- ? )
     swap [ pre-of ] [ [ pre-of ] [ maxpre-of ] bi ] bi* between? ;

basis/compiler/cfg/empty-blocks/empty-blocks.factor

@@ -1,9 +1,12 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences combinators combinators.short-circuit
+USING: kernel accessors sequences namespaces combinators
-classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
+combinators.short-circuit classes vectors compiler.cfg
+compiler.cfg.instructions compiler.cfg.rpo ;
 IN: compiler.cfg.empty-blocks
 
+<PRIVATE
+
 : update-predecessor ( bb -- )
     ! We have to replace occurrences of bb with bb's successor
     ! in bb's predecessor's list of successors.
@@ -22,8 +25,11 @@ IN: compiler.cfg.empty-blocks
         ] with map
     ] change-predecessors drop ;
 
+SYMBOL: changed?
+
 : delete-basic-block ( bb -- )
-    [ update-predecessor ] [ update-successor ] bi ;
+    [ update-predecessor ] [ update-successor ] bi
+    changed? on ;
  
 : delete-basic-block? ( bb -- ? )
     {
@@ -33,6 +39,9 @@ IN: compiler.cfg.empty-blocks
         [ instructions>> first ##branch? ]
     } 1&& ;
 
+PRIVATE>
+
 : delete-empty-blocks ( cfg -- cfg' )
+    changed? off
     dup [ dup delete-basic-block? [ delete-basic-block ] [ drop ] if ] each-basic-block
-    cfg-changed ;
+    changed? get [ cfg-changed ] when ;

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

@@ -1,25 +1,25 @@
-IN: compiler.cfg.gc-checks.tests
 USING: compiler.cfg.gc-checks compiler.cfg.debugger
 compiler.cfg.registers compiler.cfg.instructions compiler.cfg
 compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
 namespaces accessors sequences ;
+IN: compiler.cfg.gc-checks.tests
 
 : test-gc-checks ( -- )
+    H{ } clone representations set
     cfg new 0 get >>entry
-    compute-predecessors
     insert-gc-checks
     drop ;
 
 V{
     T{ ##inc-d f 3 }
-    T{ ##replace f V int-regs 0 D 1 }
+    T{ ##replace f 0 D 1 }
 } 0 test-bb
 
 V{
-    T{ ##box-float f V int-regs 0 V int-regs 1 }
+    T{ ##box-float f 0 1 }
 } 1 test-bb
 
-0 get 1 get 1vector >>successors drop
+0 1 edge
 
 [ ] [ test-gc-checks ] unit-test
 

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

@@ -1,13 +1,16 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel sequences assocs fry
+cpu.architecture
 compiler.cfg.rpo
-compiler.cfg.hats
 compiler.cfg.registers
 compiler.cfg.instructions
 compiler.cfg.stacks.uninitialized ;
 IN: compiler.cfg.gc-checks
 
+! Garbage collection check insertion. This pass runs after representation
+! selection, so it must keep track of representations.
+
 : insert-gc-check? ( bb -- ? )
     instructions>> [ ##allocation? ] any? ;
 
@@ -16,7 +19,9 @@ IN: compiler.cfg.gc-checks
 
 : insert-gc-check ( bb -- )
     dup '[
-        i i f _ uninitialized-locs \ ##gc new-insn
+        int-rep next-vreg-rep
+        int-rep next-vreg-rep
+        f f _ uninitialized-locs \ ##gc new-insn
         prefix
     ] change-instructions drop ;
 

basis/compiler/cfg/hats/hats.factor

@@ -1,83 +1,81 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays byte-arrays kernel layouts math namespaces
+USING: accessors arrays byte-arrays kernel layouts math namespaces
 sequences classes.tuple cpu.architecture compiler.cfg.registers
 compiler.cfg.instructions ;
 IN: compiler.cfg.hats
 
-: i ( -- vreg ) int-regs next-vreg ; inline
+: ^^r ( -- vreg vreg ) next-vreg dup ; inline
-: ^^i ( -- vreg vreg ) i dup ; inline
+: ^^r1 ( obj -- vreg vreg obj ) [ ^^r ] dip ; inline
-: ^^i1 ( obj -- vreg vreg obj ) [ ^^i ] dip ; inline
+: ^^r2 ( obj obj -- vreg vreg obj obj ) [ ^^r ] 2dip ; inline
-: ^^i2 ( obj obj -- vreg vreg obj obj ) [ ^^i ] 2dip ; inline
+: ^^r3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^r ] 3dip ; inline
-: ^^i3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^i ] 3dip ; inline
 
-: d ( -- vreg ) double-float-regs next-vreg ; inline
+: ^^load-literal ( obj -- dst ) ^^r1 ##load-literal ; inline
-: ^^d  ( -- vreg vreg ) d dup ; inline
+: ^^copy ( src -- dst ) ^^r1 any-rep ##copy ; inline
-: ^^d1 ( obj -- vreg vreg obj ) [ ^^d ] dip ; inline
+: ^^slot ( obj slot tag -- dst ) ^^r3 next-vreg ##slot ; inline
-: ^^d2 ( obj obj -- vreg vreg obj obj ) [ ^^d ] 2dip ; inline
+: ^^slot-imm ( obj slot tag -- dst ) ^^r3 ##slot-imm ; inline
-: ^^d3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^d ] 3dip ; inline
+: ^^set-slot ( src obj slot tag -- ) next-vreg ##set-slot ; inline
-
+: ^^string-nth ( obj index -- dst ) ^^r2 next-vreg ##string-nth ; inline
-: ^^load-literal ( obj -- dst ) ^^i1 ##load-literal ; inline
+: ^^add ( src1 src2 -- dst ) ^^r2 ##add ; inline
-: ^^copy ( src -- dst ) ^^i1 ##copy ; inline
+: ^^add-imm ( src1 src2 -- dst ) ^^r2 ##add-imm ; inline
-: ^^slot ( obj slot tag -- dst ) ^^i3 i ##slot ; inline
+: ^^sub ( src1 src2 -- dst ) ^^r2 ##sub ; inline
-: ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline
+: ^^sub-imm ( src1 src2 -- dst ) ^^r2 ##sub-imm ; inline
-: ^^set-slot ( src obj slot tag -- ) i ##set-slot ; inline
-: ^^string-nth ( obj index -- dst ) ^^i2 i ##string-nth ; inline
-: ^^add ( src1 src2 -- dst ) ^^i2 ##add ; inline
-: ^^add-imm ( src1 src2 -- dst ) ^^i2 ##add-imm ; inline
-: ^^sub ( src1 src2 -- dst ) ^^i2 ##sub ; inline
-: ^^sub-imm ( src1 src2 -- dst ) ^^i2 ##sub-imm ; inline
 : ^^neg ( src -- dst ) [ 0 ^^load-literal ] dip ^^sub ; inline
-: ^^mul ( src1 src2 -- dst ) ^^i2 ##mul ; inline
+: ^^mul ( src1 src2 -- dst ) ^^r2 ##mul ; inline
-: ^^mul-imm ( src1 src2 -- dst ) ^^i2 ##mul-imm ; inline
+: ^^mul-imm ( src1 src2 -- dst ) ^^r2 ##mul-imm ; inline
-: ^^and ( input mask -- output ) ^^i2 ##and ; inline
+: ^^and ( input mask -- output ) ^^r2 ##and ; inline
-: ^^and-imm ( input mask -- output ) ^^i2 ##and-imm ; inline
+: ^^and-imm ( input mask -- output ) ^^r2 ##and-imm ; inline
-: ^^or ( src1 src2 -- dst ) ^^i2 ##or ; inline
+: ^^or ( src1 src2 -- dst ) ^^r2 ##or ; inline
-: ^^or-imm ( src1 src2 -- dst ) ^^i2 ##or-imm ; inline
+: ^^or-imm ( src1 src2 -- dst ) ^^r2 ##or-imm ; inline
-: ^^xor ( src1 src2 -- dst ) ^^i2 ##xor ; inline
+: ^^xor ( src1 src2 -- dst ) ^^r2 ##xor ; inline
-: ^^xor-imm ( src1 src2 -- dst ) ^^i2 ##xor-imm ; inline
+: ^^xor-imm ( src1 src2 -- dst ) ^^r2 ##xor-imm ; inline
-: ^^shl ( src1 src2 -- dst ) ^^i2 ##shl ; inline
+: ^^shl ( src1 src2 -- dst ) ^^r2 ##shl ; inline
-: ^^shl-imm ( src1 src2 -- dst ) ^^i2 ##shl-imm ; inline
+: ^^shl-imm ( src1 src2 -- dst ) ^^r2 ##shl-imm ; inline
-: ^^shr ( src1 src2 -- dst ) ^^i2 ##shr ; inline
+: ^^shr ( src1 src2 -- dst ) ^^r2 ##shr ; inline
-: ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline
+: ^^shr-imm ( src1 src2 -- dst ) ^^r2 ##shr-imm ; inline
-: ^^sar ( src1 src2 -- dst ) ^^i2 ##sar ; inline
+: ^^sar ( src1 src2 -- dst ) ^^r2 ##sar ; inline
-: ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline
+: ^^sar-imm ( src1 src2 -- dst ) ^^r2 ##sar-imm ; inline
-: ^^not ( src -- dst ) ^^i1 ##not ; inline
+: ^^min ( src1 src2 -- dst ) ^^r2 ##min ; inline
-: ^^log2 ( src -- dst ) ^^i1 ##log2 ; inline
+: ^^max ( src1 src2 -- dst ) ^^r2 ##max ; inline
-: ^^bignum>integer ( src -- dst ) ^^i1 i ##bignum>integer ; inline
+: ^^not ( src -- dst ) ^^r1 ##not ; inline
-: ^^integer>bignum ( src -- dst ) ^^i1 i ##integer>bignum ; inline
+: ^^log2 ( src -- dst ) ^^r1 ##log2 ; inline
-: ^^add-float ( src1 src2 -- dst ) ^^d2 ##add-float ; inline
+: ^^bignum>integer ( src -- dst ) ^^r1 next-vreg ##bignum>integer ; inline
-: ^^sub-float ( src1 src2 -- dst ) ^^d2 ##sub-float ; inline
+: ^^integer>bignum ( src -- dst ) ^^r1 next-vreg ##integer>bignum ; inline
-: ^^mul-float ( src1 src2 -- dst ) ^^d2 ##mul-float ; inline
+: ^^add-float ( src1 src2 -- dst ) ^^r2 ##add-float ; inline
-: ^^div-float ( src1 src2 -- dst ) ^^d2 ##div-float ; inline
+: ^^sub-float ( src1 src2 -- dst ) ^^r2 ##sub-float ; inline
-: ^^float>integer ( src -- dst ) ^^i1 ##float>integer ; inline
+: ^^mul-float ( src1 src2 -- dst ) ^^r2 ##mul-float ; inline
-: ^^integer>float ( src -- dst ) ^^d1 ##integer>float ; inline
+: ^^div-float ( src1 src2 -- dst ) ^^r2 ##div-float ; inline
-: ^^allot ( size class -- dst ) ^^i2 i ##allot ; inline
+: ^^max-float ( src1 src2 -- dst ) ^^r2 ##max-float ; inline
+: ^^min-float ( src1 src2 -- dst ) ^^r2 ##min-float ; inline
+: ^^sqrt ( src -- dst ) ^^r1 ##sqrt ; inline
+: ^^float>integer ( src -- dst ) ^^r1 ##float>integer ; inline
+: ^^integer>float ( src -- dst ) ^^r1 ##integer>float ; inline
+: ^^allot ( size class -- dst ) ^^r2 next-vreg ##allot ; inline
 : ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline
 : ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
 : ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
-: ^^box-float ( src -- dst ) ^^i1 i ##box-float ; inline
+: ^^box-alien ( src -- dst ) ^^r1 next-vreg ##box-alien ; inline
-: ^^unbox-float ( src -- dst ) ^^d1 ##unbox-float ; inline
+: ^^box-displaced-alien ( base displacement base-class -- dst )
-: ^^box-alien ( src -- dst ) ^^i1 i ##box-alien ; inline
+    ^^r3 [ next-vreg ] dip ##box-displaced-alien ; inline
-: ^^unbox-alien ( src -- dst ) ^^i1 ##unbox-alien ; inline
+: ^^unbox-alien ( src -- dst ) ^^r1 ##unbox-alien ; inline
-: ^^unbox-c-ptr ( src class -- dst ) ^^i2 i ##unbox-c-ptr ;
+: ^^unbox-c-ptr ( src class -- dst ) ^^r2 next-vreg ##unbox-c-ptr ;
-: ^^alien-unsigned-1 ( src -- dst ) ^^i1 ##alien-unsigned-1 ; inline
+: ^^alien-unsigned-1 ( src -- dst ) ^^r1 ##alien-unsigned-1 ; inline
-: ^^alien-unsigned-2 ( src -- dst ) ^^i1 ##alien-unsigned-2 ; inline
+: ^^alien-unsigned-2 ( src -- dst ) ^^r1 ##alien-unsigned-2 ; inline
-: ^^alien-unsigned-4 ( src -- dst ) ^^i1 ##alien-unsigned-4 ; inline
+: ^^alien-unsigned-4 ( src -- dst ) ^^r1 ##alien-unsigned-4 ; inline
-: ^^alien-signed-1 ( src -- dst ) ^^i1 ##alien-signed-1 ; inline
+: ^^alien-signed-1 ( src -- dst ) ^^r1 ##alien-signed-1 ; inline
-: ^^alien-signed-2 ( src -- dst ) ^^i1 ##alien-signed-2 ; inline
+: ^^alien-signed-2 ( src -- dst ) ^^r1 ##alien-signed-2 ; inline
-: ^^alien-signed-4 ( src -- dst ) ^^i1 ##alien-signed-4 ; inline
+: ^^alien-signed-4 ( src -- dst ) ^^r1 ##alien-signed-4 ; inline
-: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
+: ^^alien-cell ( src -- dst ) ^^r1 ##alien-cell ; inline
-: ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline
+: ^^alien-float ( src -- dst ) ^^r1 ##alien-float ; inline
-: ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline
+: ^^alien-double ( src -- dst ) ^^r1 ##alien-double ; inline
-: ^^alien-global ( symbol library -- dst ) ^^i2 ##alien-global ; inline
+: ^^alien-global ( symbol library -- dst ) ^^r2 ##alien-global ; inline
-: ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline
+: ^^compare ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare ; inline
-: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline
+: ^^compare-imm ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare-imm ; inline
-: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline
+: ^^compare-float ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare-float ; inline
 : ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ ^^copy ] if ; inline
-: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
+: ^^tag-fixnum ( src -- dst ) ^^r1 ##tag-fixnum ; inline
-: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
+: ^^untag-fixnum ( src -- dst ) ^^r1 ##untag-fixnum ; inline
-: ^^fixnum-add ( src1 src2 -- dst ) ^^i2 ##fixnum-add ; inline
+: ^^fixnum-add ( src1 src2 -- dst ) ^^r2 ##fixnum-add ; inline
-: ^^fixnum-sub ( src1 src2 -- dst ) ^^i2 ##fixnum-sub ; inline
+: ^^fixnum-sub ( src1 src2 -- dst ) ^^r2 ##fixnum-sub ; inline
-: ^^fixnum-mul ( src1 src2 -- dst ) ^^i2 ##fixnum-mul ; inline
+: ^^fixnum-mul ( src1 src2 -- dst ) ^^r2 ##fixnum-mul ; inline
-: ^^phi ( inputs -- dst ) ^^i1 ##phi ; inline
+: ^^phi ( inputs -- dst ) ^^r1 ##phi ; inline

basis/compiler/cfg/instructions/instructions.factor

@@ -91,6 +91,8 @@ INSN: ##shr < ##binary ;
 INSN: ##shr-imm < ##binary-imm ;
 INSN: ##sar < ##binary ;
 INSN: ##sar-imm < ##binary-imm ;
+INSN: ##min < ##binary ;
+INSN: ##max < ##binary ;
 INSN: ##not < ##unary ;
 INSN: ##log2 < ##unary ;
 
@@ -106,18 +108,21 @@ INSN: ##add-float < ##commutative ;
 INSN: ##sub-float < ##binary ;
 INSN: ##mul-float < ##commutative ;
 INSN: ##div-float < ##binary ;
+INSN: ##min-float < ##binary ;
+INSN: ##max-float < ##binary ;
+INSN: ##sqrt < ##unary ;
 
 ! Float/integer conversion
 INSN: ##float>integer < ##unary ;
 INSN: ##integer>float < ##unary ;
 
 ! Boxing and unboxing
-INSN: ##copy < ##unary ;
+INSN: ##copy < ##unary rep ;
-INSN: ##copy-float < ##unary ;
 INSN: ##unbox-float < ##unary ;
 INSN: ##unbox-any-c-ptr < ##unary/temp ;
 INSN: ##box-float < ##unary/temp ;
 INSN: ##box-alien < ##unary/temp ;
+INSN: ##box-displaced-alien < ##binary temp base-class ;
 
 : ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
 : ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
@@ -152,7 +157,12 @@ INSN: ##set-alien-double < ##alien-setter ;
 ! Memory allocation
 INSN: ##allot < ##flushable size class temp ;
 
-UNION: ##allocation ##allot ##box-float ##box-alien ##integer>bignum ;
+UNION: ##allocation
+##allot
+##box-float
+##box-alien
+##box-displaced-alien
+##integer>bignum ;
 
 INSN: ##write-barrier < ##effect card# table ;
 
@@ -190,7 +200,7 @@ INSN: ##fixnum-add < ##fixnum-overflow ;
 INSN: ##fixnum-sub < ##fixnum-overflow ;
 INSN: ##fixnum-mul < ##fixnum-overflow ;
 
-INSN: ##gc temp1 temp2 live-values uninitialized-locs ;
+INSN: ##gc temp1 temp2 data-values tagged-values uninitialized-locs ;
 
 ! Instructions used by machine IR only.
 INSN: _prologue stack-frame ;
@@ -219,14 +229,13 @@ INSN: _fixnum-mul < _fixnum-overflow ;
 
 TUPLE: spill-slot n ; C: <spill-slot> spill-slot
 
-INSN: _gc temp1 temp2 gc-roots gc-root-count gc-root-size uninitialized-locs ;
+INSN: _gc temp1 temp2 data-values tagged-values uninitialized-locs ;
 
 ! These instructions operate on machine registers and not
 ! virtual registers
-INSN: _spill src class n ;
+INSN: _spill src rep n ;
-INSN: _reload dst class n ;
+INSN: _reload dst rep n ;
-INSN: _copy dst src class ;
+INSN: _spill-area-size n ;
-INSN: _spill-counts counts ;
 
 ! Instructions that use vregs
 UNION: vreg-insn
@@ -252,6 +261,40 @@ UNION: kill-vreg-insn
     ##alien-indirect
     ##alien-callback ;
 
+! Instructions that output floats
+UNION: output-float-insn
+    ##add-float
+    ##sub-float
+    ##mul-float
+    ##div-float
+    ##min-float
+    ##max-float
+    ##sqrt
+    ##integer>float
+    ##unbox-float
+    ##alien-float
+    ##alien-double ;
+
+! Instructions that take floats as inputs
+UNION: input-float-insn
+    ##add-float
+    ##sub-float
+    ##mul-float
+    ##div-float
+    ##min-float
+    ##max-float
+    ##sqrt
+    ##float>integer
+    ##box-float
+    ##set-alien-float
+    ##set-alien-double
+    ##compare-float
+    ##compare-float-branch ;
+
+! Smackdown
+INTERSECTION: ##unary-float ##unary input-float-insn ;
+INTERSECTION: ##binary-float ##binary input-float-insn ;
+
 ! Instructions that have complex expansions and require that the
 ! output registers are not equal to any of the input registers
 UNION: def-is-use-insn

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

@@ -1,11 +1,25 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel sequences alien math classes.algebra fry
-locals combinators cpu.architecture compiler.tree.propagation.info
+locals combinators combinators.short-circuit cpu.architecture
-compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions
+compiler.tree.propagation.info compiler.cfg.hats
+compiler.cfg.stacks compiler.cfg.instructions
 compiler.cfg.utilities compiler.cfg.builder.blocks ;
 IN: compiler.cfg.intrinsics.alien
 
+: emit-<displaced-alien>? ( node -- ? )
+    node-input-infos {
+        [ first class>> fixnum class<= ]
+        [ second class>> c-ptr class<= ]
+    } 1&& ;
+
+: emit-<displaced-alien> ( node -- )
+    dup emit-<displaced-alien>? [
+        [ 2inputs [ ^^untag-fixnum ] dip ] dip
+        node-input-infos second class>>
+        ^^box-displaced-alien ds-push
+    ] [ emit-primitive ] if ;
+
 : (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
     ds-drop [ ds-pop swap ^^unbox-c-ptr ] dip ^^add-imm ;
 
@@ -53,7 +67,7 @@ IN: compiler.cfg.intrinsics.alien
     inline-alien ; inline
 
 : inline-alien-float-setter ( node quot -- )
-    '[ ds-pop ^^unbox-float @ ]
+    '[ ds-pop @ ]
     [ float inline-alien-setter? ]
     inline-alien ; inline
 
@@ -90,18 +104,18 @@ IN: compiler.cfg.intrinsics.alien
 : emit-alien-cell-setter ( node -- )
     [ ##set-alien-cell ] inline-alien-cell-setter ;
 
-: emit-alien-float-getter ( node reg-class -- )
+: emit-alien-float-getter ( node rep -- )
     '[
         _ {
-            { single-float-regs [ ^^alien-float ] }
+            { single-float-rep [ ^^alien-float ] }
-            { double-float-regs [ ^^alien-double ] }
+            { double-float-rep [ ^^alien-double ] }
-        } case ^^box-float
+        } case
     ] inline-alien-getter ;
 
-: emit-alien-float-setter ( node reg-class -- )
+: emit-alien-float-setter ( node rep -- )
     '[
         _ {
-            { single-float-regs [ ##set-alien-float ] }
+            { single-float-rep [ ##set-alien-float ] }
-            { double-float-regs [ ##set-alien-double ] }
+            { double-float-rep [ ##set-alien-double ] }
         } case
     ] inline-alien-float-setter ;