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.factor

@@ -11,6 +11,8 @@ M: array c-type ;
 
 M: array c-type-class drop object ;
 
+M: array c-type-boxed-class drop object ;
+
 M: array heap-size unclip [ product ] [ heap-size ] bi* * ;
 
 M: array c-type-align first c-type-align ;
@@ -31,7 +33,7 @@ M: array c-type-boxer-quot drop [ ] ;
 
 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 +47,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 +75,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-tests.factor

@@ -1,6 +1,6 @@
-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
 

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

@@ -13,17 +13,20 @@ 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
+align ;
+
+TUPLE: c-type < abstract-c-type
+boxer
+unboxer
+{ rep initial: int-rep }
 stack-align? ;
 
 : <c-type> ( -- type )
@@ -70,10 +73,16 @@ M: string c-type ( name -- type )
 
 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 +91,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 +103,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 +127,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 +138,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 +176,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
 
@@ -300,6 +307,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
@@ -311,6 +319,7 @@ CONSTANT: primitive-types
 
     <long-long-type>
         integer >>class
+        integer >>boxed-class
         [ alien-signed-8 ] >>getter
         [ set-alien-signed-8 ] >>setter
         8 >>size
@@ -321,6 +330,7 @@ CONSTANT: primitive-types
 
     <long-long-type>
         integer >>class
+        integer >>boxed-class
         [ alien-unsigned-8 ] >>getter
         [ set-alien-unsigned-8 ] >>setter
         8 >>size
@@ -331,6 +341,7 @@ CONSTANT: primitive-types
 
     <c-type>
         integer >>class
+        integer >>boxed-class
         [ alien-signed-cell ] >>getter
         [ set-alien-signed-cell ] >>setter
         bootstrap-cell >>size
@@ -341,6 +352,7 @@ CONSTANT: primitive-types
 
     <c-type>
         integer >>class
+        integer >>boxed-class
         [ alien-unsigned-cell ] >>getter
         [ set-alien-unsigned-cell ] >>setter
         bootstrap-cell >>size
@@ -351,6 +363,7 @@ CONSTANT: primitive-types
 
     <c-type>
         integer >>class
+        integer >>boxed-class
         [ alien-signed-4 ] >>getter
         [ set-alien-signed-4 ] >>setter
         4 >>size
@@ -361,6 +374,7 @@ CONSTANT: primitive-types
 
     <c-type>
         integer >>class
+        integer >>boxed-class
         [ alien-unsigned-4 ] >>getter
         [ set-alien-unsigned-4 ] >>setter
         4 >>size
@@ -371,6 +385,7 @@ CONSTANT: primitive-types
 
     <c-type>
         fixnum >>class
+        fixnum >>boxed-class
         [ alien-signed-2 ] >>getter
         [ set-alien-signed-2 ] >>setter
         2 >>size
@@ -381,6 +396,7 @@ CONSTANT: primitive-types
 
     <c-type>
         fixnum >>class
+        fixnum >>boxed-class
         [ alien-unsigned-2 ] >>getter
         [ set-alien-unsigned-2 ] >>setter
         2 >>size
@@ -391,6 +407,7 @@ CONSTANT: primitive-types
 
     <c-type>
         fixnum >>class
+        fixnum >>boxed-class
         [ alien-signed-1 ] >>getter
         [ set-alien-signed-1 ] >>setter
         1 >>size
@@ -401,6 +418,7 @@ CONSTANT: primitive-types
 
     <c-type>
         fixnum >>class
+        fixnum >>boxed-class
         [ alien-unsigned-1 ] >>getter
         [ set-alien-unsigned-1 ] >>setter
         1 >>size
@@ -420,25 +438,27 @@ CONSTANT: primitive-types
 
     <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" 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" define-primitive-type
 

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/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,7 @@ define-struct
 T c-type
 <T> 1quotation >>unboxer-quot
 *T 1quotation >>boxer-quot
+number >>boxed-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/fortran/fortran.factor

@@ -365,7 +365,7 @@ M: character-type (<fortran-result>)
     ] 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/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
 
@@ -56,6 +38,8 @@ M: struct-type stack-size
 : (define-struct) ( name size align fields -- )
     [ [ align ] keep ] dip
     struct-type new
+        byte-array >>class
+        byte-array >>boxed-class
         swap >>fields
         swap >>align
         swap >>size

basis/alien/syntax/syntax.factor

@@ -31,8 +31,10 @@ 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/biassocs/biassocs-tests.factor

@@ -1,5 +1,5 @@
-IN: biassocs.tests
 USING: biassocs assocs namespaces tools.test ;
+IN: biassocs.tests
 
 <bihash> "h" set
 

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-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/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/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/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,22 +34,22 @@ 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 ;
@@ -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 ;

basis/calendar/format/format.factor

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

basis/checksums/fnv1/fnv1.factor

@@ -1,9 +1,7 @@
 ! 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

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/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/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/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/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,12 +1,14 @@
-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 + ;
 
 PRIVATE>

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

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 ;
+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 [

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

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces assocs accessors sequences grouping
 combinators compiler.cfg.rpo compiler.cfg.renaming
-compiler.cfg.instructions ;
+compiler.cfg.instructions compiler.cfg.predecessors ;
 IN: compiler.cfg.copy-prop
 
 ! The first three definitions are also used in compiler.cfg.alias-analysis.
@@ -70,6 +70,8 @@ M: insn update-insn rename-insn-uses t ;
 PRIVATE>
 
 : copy-propagation ( cfg -- cfg' )
+    needs-predecessors
+
     [ collect-copies ]
     [ rename-copies ]
     [ ]

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

@@ -1,37 +0,0 @@
-USING: accessors assocs compiler.cfg
-compiler.cfg.critical-edges compiler.cfg.debugger
-compiler.cfg.instructions compiler.cfg.predecessors
-compiler.cfg.registers cpu.architecture kernel namespaces
-sequences tools.test compiler.cfg.utilities ;
-IN: compiler.cfg.critical-edges.tests
-
-! Make sure we update phi nodes when splitting critical edges
-
-: test-critical-edges ( -- )
-    cfg new 0 get >>entry
-    compute-predecessors
-    split-critical-edges ;
-
-V{
-    T{ ##peek f V int-regs 0 D 0 }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##peek f V int-regs 1 D 1 }
-    T{ ##branch }
-} 1 test-bb
-
-V{
-    T{ ##phi f V int-regs 2 H{ { 0 V int-regs 0 } { 1 V int-regs 1 } } }
-    T{ ##return }
-} 2 test-bb
-
-0 { 1 2 } edges
-1 2 edge
-
-[ ] [ test-critical-edges ] unit-test
-
-[ t ] [ 0 get successors>> second successors>> first 2 get eq? ] unit-test
-
-[ V int-regs 0 ] [ 2 get instructions>> first inputs>> 0 get successors>> second swap at ] unit-test

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

@@ -1,29 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math accessors sequences locals assocs fry
-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 ;
-
-: new-key ( new-key old-key assoc -- )
-    [ delete-at* ] keep '[ swap _ set-at ] [ 2drop ] if ;
-
-:: update-phis ( from to bb -- )
-    ! Any phi nodes in 'to' which reference 'from'
-    ! should now reference 'bb'.
-    to [ [ bb from ] dip inputs>> new-key ] each-phi ;
-
-: split-critical-edge ( from to -- )
-    f <simple-block> [ insert-basic-block ] [ update-phis ] 3bi ; 
-
-: 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,7 @@ 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 ;
+    bb dfa predecessors [ 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 +48,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 +56,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

@@ -4,11 +4,12 @@ USING: kernel words sequences quotations namespaces io vectors
 classes.tuple accessors prettyprint prettyprint.config assocs
 prettyprint.backend prettyprint.custom prettyprint.sections
 parser compiler.tree.builder compiler.tree.optimizer
-compiler.cfg.builder compiler.cfg.linearization
+cpu.architecture compiler.cfg.builder compiler.cfg.linearization
 compiler.cfg.registers compiler.cfg.stack-frame
 compiler.cfg.linear-scan compiler.cfg.two-operand
 compiler.cfg.optimizer compiler.cfg.instructions
-compiler.cfg.utilities compiler.cfg.mr compiler.cfg ;
+compiler.cfg.utilities compiler.cfg.def-use
+compiler.cfg.rpo compiler.cfg.mr compiler.cfg ;
 IN: compiler.cfg.debugger
 
 GENERIC: test-cfg ( quot -- cfgs )
@@ -23,8 +24,10 @@ M: word test-cfg
 
 : test-mr ( quot -- mrs )
     test-cfg [
+        [
             optimize-cfg
             build-mr
+        ] with-cfg
     ] map ;
 
 : insn. ( insn -- )
@@ -41,11 +44,6 @@ 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 ;
@@ -72,3 +70,11 @@ M: rs-loc pprint* \ R pprint-loc ;
     1 { 2 3 } edges
     2 4 edge
     3 4 edge ;
+
+: fake-representations ( cfg -- )
+    post-order [
+        instructions>>
+        [ [ temp-vregs ] [ defs-vreg ] bi [ suffix ] when* ]
+        map concat
+    ] map concat
+    [ int-rep ] H{ } map>assoc representations set ;

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

@@ -8,30 +8,29 @@ compiler.cfg
 compiler.cfg.debugger
 compiler.cfg.instructions
 compiler.cfg.registers ;
+IN: compiler.cfg.def-use.tests
 
 V{
-    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##peek f 0 D 0 }
-    T{ ##peek f V int-regs 1 D 0 }
+    T{ ##peek f 1 D 0 }
-    T{ ##peek f V int-regs 2 D 0 }
+    T{ ##peek f 2 D 0 }
 } 1 test-bb
 V{
-    T{ ##replace f V int-regs 2 D 0 }
+    T{ ##replace f 2 D 0 }
 } 2 test-bb
-1 get 2 get 1vector >>successors drop
+1 2 edge
 V{
-    T{ ##replace f V int-regs 0 D 0 }
+    T{ ##replace f 0 D 0 }
 } 3 test-bb
-2 get 3 get 1vector >>successors drop
+2 3 edge
 V{ } 4 test-bb
 V{ } 5 test-bb
-3 get 4 get 5 get V{ } 2sequence >>successors drop
+3 { 4 5 } edges
-V int-regs 2
+V{
-    2 get V int-regs 0 2array
+    T{ ##phi f 2 H{ { 2 0 } { 3 1 } } }
-    3 get V int-regs 1 2array
+} 6 test-bb
-2array \ ##phi new-insn 1vector
+4 6 edge
-6 test-bb
+5 6 edge
-4 get 6 get 1vector >>successors drop
-5 get 6 get 1vector >>successors drop
 
 cfg new 1 get >>entry 0 set
-[ ] [ 0 get compute-def-use ] unit-test
+[ ] [ 0 get [ compute-defs ] [ compute-uses ] bi ] unit-test

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

@@ -92,6 +92,3 @@ SYMBOLS: defs insns uses ;
         ] each
     ] each-basic-block
     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

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,22 +1,22 @@
-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 1 edge

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,74 @@
-! 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
+: ^^not ( src -- dst ) ^^r1 ##not ; inline
-: ^^log2 ( src -- dst ) ^^i1 ##log2 ; inline
+: ^^log2 ( src -- dst ) ^^r1 ##log2 ; inline
-: ^^bignum>integer ( src -- dst ) ^^i1 i ##bignum>integer ; inline
+: ^^bignum>integer ( src -- dst ) ^^r1 next-vreg ##bignum>integer ; inline
-: ^^integer>bignum ( src -- dst ) ^^i1 i ##integer>bignum ; inline
+: ^^integer>bignum ( src -- dst ) ^^r1 next-vreg ##integer>bignum ; inline
-: ^^add-float ( src1 src2 -- dst ) ^^d2 ##add-float ; inline
+: ^^add-float ( src1 src2 -- dst ) ^^r2 ##add-float ; inline
-: ^^sub-float ( src1 src2 -- dst ) ^^d2 ##sub-float ; inline
+: ^^sub-float ( src1 src2 -- dst ) ^^r2 ##sub-float ; inline
-: ^^mul-float ( src1 src2 -- dst ) ^^d2 ##mul-float ; inline
+: ^^mul-float ( src1 src2 -- dst ) ^^r2 ##mul-float ; inline
-: ^^div-float ( src1 src2 -- dst ) ^^d2 ##div-float ; inline
+: ^^div-float ( src1 src2 -- dst ) ^^r2 ##div-float ; inline
-: ^^float>integer ( src -- dst ) ^^i1 ##float>integer ; inline
+: ^^float>integer ( src -- dst ) ^^r1 ##float>integer ; inline
-: ^^integer>float ( src -- dst ) ^^d1 ##integer>float ; inline
+: ^^integer>float ( src -- dst ) ^^r1 ##integer>float ; inline
-: ^^allot ( size class -- dst ) ^^i2 i ##allot ; 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
+: ^^unbox-alien ( src -- dst ) ^^r1 ##unbox-alien ; inline
-: ^^box-alien ( src -- dst ) ^^i1 i ##box-alien ; inline
+: ^^unbox-c-ptr ( src class -- dst ) ^^r2 next-vreg ##unbox-c-ptr ;
-: ^^unbox-alien ( src -- dst ) ^^i1 ##unbox-alien ; inline
+: ^^alien-unsigned-1 ( src -- dst ) ^^r1 ##alien-unsigned-1 ; inline
-: ^^unbox-c-ptr ( src class -- dst ) ^^i2 i ##unbox-c-ptr ;
+: ^^alien-unsigned-2 ( src -- dst ) ^^r1 ##alien-unsigned-2 ; inline
-: ^^alien-unsigned-1 ( src -- dst ) ^^i1 ##alien-unsigned-1 ; inline
+: ^^alien-unsigned-4 ( src -- dst ) ^^r1 ##alien-unsigned-4 ; inline
-: ^^alien-unsigned-2 ( src -- dst ) ^^i1 ##alien-unsigned-2 ; inline
+: ^^alien-signed-1 ( src -- dst ) ^^r1 ##alien-signed-1 ; inline
-: ^^alien-unsigned-4 ( src -- dst ) ^^i1 ##alien-unsigned-4 ; inline
+: ^^alien-signed-2 ( src -- dst ) ^^r1 ##alien-signed-2 ; inline
-: ^^alien-signed-1 ( src -- dst ) ^^i1 ##alien-signed-1 ; inline
+: ^^alien-signed-4 ( src -- dst ) ^^r1 ##alien-signed-4 ; inline
-: ^^alien-signed-2 ( src -- dst ) ^^i1 ##alien-signed-2 ; inline
+: ^^alien-cell ( src -- dst ) ^^r1 ##alien-cell ; inline
-: ^^alien-signed-4 ( src -- dst ) ^^i1 ##alien-signed-4 ; inline
+: ^^alien-float ( src -- dst ) ^^r1 ##alien-float ; inline
-: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
+: ^^alien-double ( src -- dst ) ^^r1 ##alien-double ; inline
-: ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline
+: ^^alien-global ( symbol library -- dst ) ^^r2 ##alien-global ; inline
-: ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline
+: ^^compare ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare ; inline
-: ^^alien-global ( symbol library -- dst ) ^^i2 ##alien-global ; inline
+: ^^compare-imm ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare-imm ; inline
-: ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline
+: ^^compare-float ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare-float ; inline
-: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline
-: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##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

@@ -112,8 +112,7 @@ 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 ;
@@ -190,7 +189,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 +218,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 +250,34 @@ UNION: kill-vreg-insn
     ##alien-indirect
     ##alien-callback ;
 
+! Instructions that output floats
+UNION: output-float-insn
+    ##add-float
+    ##sub-float
+    ##mul-float
+    ##div-float
+    ##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
+    ##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

@@ -53,7 +53,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 +90,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 ;

basis/compiler/cfg/intrinsics/float/float.factor

@@ -1,19 +1,17 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel compiler.cfg.stacks compiler.cfg.hats
 compiler.cfg.instructions compiler.cfg.utilities ;
 IN: compiler.cfg.intrinsics.float
 
 : emit-float-op ( insn -- )
-    [ 2inputs [ ^^unbox-float ] bi@ ] dip call ^^box-float
+    [ 2inputs ] dip call ds-push ; inline
-    ds-push ; inline
 
 : emit-float-comparison ( cc -- )
-    [ 2inputs [ ^^unbox-float ] bi@ ] dip ^^compare-float
+    [ 2inputs ] dip ^^compare-float ds-push ; inline
-    ds-push ; inline
 
 : emit-float>fixnum ( -- )
-    ds-pop ^^unbox-float ^^float>integer ^^tag-fixnum ds-push ;
+    ds-pop ^^float>integer ^^tag-fixnum ds-push ;
 
 : emit-fixnum>float ( -- )
-    ds-pop ^^untag-fixnum ^^integer>float ^^box-float ds-push ;
+    ds-pop ^^untag-fixnum ^^integer>float ds-push ;

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -153,8 +153,8 @@ IN: compiler.cfg.intrinsics
         { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
         { \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
         { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
-        { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] }
+        { \ alien.accessors:alien-float [ single-float-rep emit-alien-float-getter ] }
-        { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] }
+        { \ alien.accessors:set-alien-float [ single-float-rep emit-alien-float-setter ] }
-        { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] }
+        { \ alien.accessors:alien-double [ double-float-rep emit-alien-float-getter ] }
-        { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] }
+        { \ alien.accessors:set-alien-double [ double-float-rep emit-alien-float-setter ] }
     } case ;

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

@@ -1,8 +1,8 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: layouts namespaces kernel accessors sequences
+USING: layouts namespaces kernel accessors sequences classes.algebra
-classes.algebra compiler.tree.propagation.info
+compiler.tree.propagation.info compiler.cfg.stacks compiler.cfg.hats
-compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
+compiler.cfg.registers compiler.cfg.instructions
 compiler.cfg.utilities compiler.cfg.builder.blocks ;
 IN: compiler.cfg.intrinsics.slots
 
@@ -45,7 +45,7 @@ IN: compiler.cfg.intrinsics.slots
             dup third value-info-small-fixnum?
             [ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
         ] [ first class>> immediate class<= ] bi
-        [ drop ] [ i i ##write-barrier ] if
+        [ drop ] [ next-vreg next-vreg ##write-barrier ] if
     ] [ drop emit-primitive ] if ;
 
 : emit-string-nth ( -- )
@@ -53,4 +53,4 @@ IN: compiler.cfg.intrinsics.slots
 
 : emit-set-string-nth-fast ( -- )
     3inputs [ ^^untag-fixnum ] [ ^^untag-fixnum ] [ ] tri*
-    swap i ##set-string-nth-fast ;
+    swap next-vreg ##set-string-nth-fast ;

basis/compiler/cfg/linear-scan/allocation/allocation.factor

@@ -3,7 +3,6 @@
 USING: accessors assocs heaps kernel namespaces sequences fry math
 math.order combinators arrays sorting compiler.utilities
 compiler.cfg.linear-scan.live-intervals
-compiler.cfg.linear-scan.allocation.coalescing
 compiler.cfg.linear-scan.allocation.spilling
 compiler.cfg.linear-scan.allocation.splitting
 compiler.cfg.linear-scan.allocation.state ;
@@ -29,13 +28,11 @@ IN: compiler.cfg.linear-scan.allocation
     second 0 = ; inline
 
 : assign-register ( new -- )
-    dup coalesce? [ coalesce ] [
     dup register-status {
         { [ dup no-free-registers? ] [ drop assign-blocked-register ] }
         { [ 2dup register-available? ] [ register-available ] }
         [ drop assign-blocked-register ]
-        } cond
+    } cond ;
-    ] if ;
 
 : handle-interval ( live-interval -- )
     [

basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor

@@ -1,35 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences namespaces assocs fry
-combinators.short-circuit
-compiler.cfg.linear-scan.live-intervals
-compiler.cfg.linear-scan.allocation.state ;
-IN: compiler.cfg.linear-scan.allocation.coalescing
-
-: active-interval ( vreg -- live-interval )
-    dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
-
-: avoids-inactive-intervals? ( live-interval -- ? )
-    dup vreg>> inactive-intervals-for
-    [ intervals-intersect? not ] with all? ;
-
-: coalesce? ( live-interval -- ? )
-    {
-        [ copy-from>> active-interval ]
-        [ [ start>> ] [ copy-from>> active-interval end>> ] bi = ]
-        [ avoids-inactive-intervals? ]
-    } 1&& ;
-
-: reuse-spill-slot ( old new -- )
-    [ vreg>> spill-slots get at ] dip '[ _ vreg>> spill-slots get set-at ] when* ;
-
-: reuse-register ( old new -- )
-    reg>> >>reg drop ;
-
-: (coalesce) ( old new -- )
-    [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ;
-
-: coalesce ( live-interval -- )
-    dup copy-from>> active-interval
-    [ reuse-spill-slot ] [ reuse-register ] [ (coalesce) ] 2tri ;
- 

basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor

@@ -45,7 +45,7 @@ ERROR: splitting-atomic-interval ;
     f >>spill-to ; inline
 
 : split-after ( after -- after' )
-    f >>copy-from f >>reg f >>reload-from ; inline
+    f >>reg f >>reload-from ; inline
 
 :: split-interval ( live-interval n -- before after )
     live-interval n check-split

basis/compiler/cfg/linear-scan/allocation/state/state.factor

@@ -2,6 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs combinators cpu.architecture fry heaps
 kernel math math.order namespaces sequences vectors
+compiler.cfg compiler.cfg.registers
 compiler.cfg.linear-scan.live-intervals ;
 IN: compiler.cfg.linear-scan.allocation.state
 
@@ -26,7 +27,7 @@ SYMBOL: registers
 SYMBOL: active-intervals
 
 : active-intervals-for ( vreg -- seq )
-    reg-class>> active-intervals get at ;
+    rep-of reg-class-of active-intervals get at ;
 
 : add-active ( live-interval -- )
     dup vreg>> active-intervals-for push ;
@@ -41,7 +42,7 @@ SYMBOL: active-intervals
 SYMBOL: inactive-intervals
 
 : inactive-intervals-for ( vreg -- seq )
-    reg-class>> inactive-intervals get at ;
+    rep-of reg-class-of inactive-intervals get at ;
 
 : add-inactive ( live-interval -- )
     dup vreg>> inactive-intervals-for push ;
@@ -112,22 +113,18 @@ SYMBOL: unhandled-intervals
     [ dup start>> unhandled-intervals get heap-push ]
     bi ;
 
-CONSTANT: reg-classes { int-regs double-float-regs }
-
 : reg-class-assoc ( quot -- assoc )
     [ reg-classes ] dip { } map>assoc ; inline
 
-! Mapping from register classes to spill counts
+: next-spill-slot ( rep -- n )
-SYMBOL: spill-counts
+    rep-size cfg get
-
+    [ swap [ align dup ] [ + ] bi ] change-spill-area-size drop ;
-: next-spill-slot ( reg-class -- n )
-    spill-counts get [ dup 1 + ] change-at ;
 
 ! Mapping from vregs to spill slots
 SYMBOL: spill-slots
 
 : assign-spill-slot ( vreg -- n )
-    spill-slots get [ reg-class>> next-spill-slot ] cache ;
+    spill-slots get [ rep-of next-spill-slot ] cache ;
 
 : init-allocator ( registers -- )
     registers set
@@ -135,7 +132,7 @@ SYMBOL: spill-slots
     [ V{ } clone ] reg-class-assoc active-intervals set
     [ V{ } clone ] reg-class-assoc inactive-intervals set
     V{ } clone handled-intervals set
-    [ 0 ] reg-class-assoc spill-counts set
+    cfg get 0 >>spill-area-size drop
     H{ } clone spill-slots set
     -1 progress set ;
 
@@ -145,7 +142,7 @@ SYMBOL: spill-slots
 
 ! A utility used by register-status and spill-status words
 : free-positions ( new -- assoc )
-    vreg>> reg-class>> registers get at [ 1/0. ] H{ } map>assoc ;
+    vreg>> rep-of reg-class-of registers get at [ 1/0. ] H{ } map>assoc ;
 
 : add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ;
 

basis/compiler/cfg/linear-scan/assignment/assignment.factor

@@ -1,15 +1,15 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel math assocs namespaces sequences heaps
-fry make combinators sets locals
+fry make combinators sets locals arrays
 cpu.architecture
 compiler.cfg
-compiler.cfg.rpo
 compiler.cfg.def-use
 compiler.cfg.liveness
 compiler.cfg.registers
 compiler.cfg.instructions
 compiler.cfg.renaming.functor
+compiler.cfg.linearization.order
 compiler.cfg.linear-scan.allocation
 compiler.cfg.linear-scan.allocation.state
 compiler.cfg.linear-scan.live-intervals ;
@@ -52,7 +52,7 @@ SYMBOL: register-live-outs
     init-unhandled ;
 
 : insert-spill ( live-interval -- )
-    [ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri _spill ;
+    [ reg>> ] [ vreg>> rep-of ] [ spill-to>> ] tri _spill ;
 
 : handle-spill ( live-interval -- )
     dup spill-to>> [ insert-spill ] [ drop ] if ;
@@ -72,7 +72,7 @@ SYMBOL: register-live-outs
     pending-interval-heap get (expire-old-intervals) ;
 
 : insert-reload ( live-interval -- )
-    [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ;
+    [ reg>> ] [ vreg>> rep-of ] [ reload-from>> ] tri _reload ;
 
 : handle-reload ( live-interval -- )
     dup reload-from>> [ insert-reload ] [ drop ] if ;
@@ -103,11 +103,36 @@ RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
 M: vreg-insn assign-registers-in-insn
     [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
 
+! TODO: needs tagged-rep
+
+: trace-on-gc ( assoc -- assoc' )
+    ! When a GC occurs, virtual registers which contain tagged data
+    ! are traced by the GC. Outputs a sequence physical registers.
+    [ drop rep-of int-rep eq? ] { } assoc-filter-as values ;
+
+: spill-on-gc? ( vreg reg -- ? )
+    [ rep-of int-rep? not ] [ spill-slot? not ] bi* and ;
+
+: spill-on-gc ( assoc -- assoc' )
+    ! When a GC occurs, virtual registers which contain untagged data,
+    ! and are stored in physical registers, are saved to their spill
+    ! slots. Outputs sequence of triples:
+    ! - physical register
+    ! - spill slot
+    ! - representation
+    [
+        [
+            2dup spill-on-gc?
+            [ swap [ assign-spill-slot ] [ rep-of ] bi 3array , ] [ 2drop ] if
+        ] assoc-each
+    ] { } make ;
+
 M: ##gc assign-registers-in-insn
-    ! This works because ##gc is always the first instruction
+    ! Since ##gc is always the first instruction in a block, the set of
-    ! in a block.
+    ! values live at the ##gc is just live-in.
     dup call-next-method
-    basic-block get register-live-ins get at >>live-values
+    basic-block get register-live-ins get at
+    [ trace-on-gc >>tagged-values ] [ spill-on-gc >>data-values ] bi
     drop ;
 
 M: insn assign-registers-in-insn drop ;
@@ -156,4 +181,4 @@ ERROR: bad-vreg vreg ;
 
 : assign-registers ( live-intervals cfg -- )
     [ init-assignment ] dip
-    [ assign-registers-in-block ] each-basic-block ;
+    linearization-order [ assign-registers-in-block ] each ;

basis/compiler/cfg/linear-scan/debugger/debugger.factor

@@ -18,9 +18,8 @@ IN: compiler.cfg.linear-scan.debugger
 
 : interval-picture ( interval -- str )
     [ uses>> picture ]
-    [ copy-from>> unparse ]
     [ vreg>> unparse ]
-    tri 3array ;
+    bi 2array ;
 
 : live-intervals. ( seq -- )
     [ interval-picture ] map simple-table. ;

basis/compiler/cfg/linear-scan/linear-scan.factor

@@ -5,6 +5,7 @@ cpu.architecture
 compiler.cfg
 compiler.cfg.rpo
 compiler.cfg.liveness
+compiler.cfg.registers
 compiler.cfg.instructions
 compiler.cfg.linear-scan.numbering
 compiler.cfg.linear-scan.live-intervals
@@ -37,8 +38,4 @@ IN: compiler.cfg.linear-scan
     cfg check-numbering ;
 
 : linear-scan ( cfg -- cfg' )
-    [
+    dup machine-registers (linear-scan) ;
-        dup machine-registers (linear-scan)
-        spill-counts get >>spill-counts
-        cfg-changed
-    ] with-scope ;

basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces kernel assocs accessors sequences math math.order fry
 combinators binary-search compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.def-use compiler.cfg.liveness compiler.cfg.rpo
+compiler.cfg.def-use compiler.cfg.liveness compiler.cfg.linearization.order
 compiler.cfg ;
 IN: compiler.cfg.linear-scan.live-intervals
 
@@ -13,8 +13,7 @@ C: <live-range> live-range
 TUPLE: live-interval
 vreg
 reg spill-to reload-from
-start end ranges uses
+start end ranges uses ;
-copy-from ;
 
 GENERIC: covers? ( insn# obj -- ? )
 
@@ -102,15 +101,6 @@ M: vreg-insn compute-live-intervals*
     [ [ temp-vregs ] 2dip '[ [ _ ] dip _ handle-temp ] each ]
     3tri ;
 
-: record-copy ( insn -- )
-    [ dst>> live-intervals get at ] [ src>> ] bi >>copy-from drop ;
-
-M: ##copy compute-live-intervals*
-    [ call-next-method ] [ record-copy ] bi ;
-
-M: ##copy-float compute-live-intervals*
-    [ call-next-method ] [ record-copy ] bi ;
-
 : handle-live-out ( bb -- )
     live-out keys
     basic-block get [ block-from ] [ block-to ] bi
@@ -147,7 +137,8 @@ ERROR: bad-live-interval live-interval ;
 : compute-live-intervals ( cfg -- live-intervals )
     H{ } clone [
         live-intervals set
-        post-order [ compute-live-intervals-step ] each
+        linearization-order <reversed>
+        [ compute-live-intervals-step ] each
     ] keep values dup finish-live-intervals ;
 
 : relevant-ranges ( interval1 interval2 -- ranges1 ranges2 )

basis/compiler/cfg/linear-scan/numbering/numbering.factor

@@ -1,15 +1,15 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors math sequences grouping namespaces
-compiler.cfg.rpo ;
+compiler.cfg.linearization.order ;
 IN: compiler.cfg.linear-scan.numbering
 
 : number-instructions ( rpo -- )
-    [ 0 ] dip [
+    linearization-order 0 [
         instructions>> [
             [ (>>insn#) ] [ drop 2 + ] 2bi
         ] each
-    ] each-basic-block drop ;
+    ] reduce drop ;
 
 SYMBOL: check-numbering?
 
@@ -20,4 +20,5 @@ ERROR: bad-numbering bb ;
     [ drop ] [ bad-numbering ] if ;
 
 : check-numbering ( cfg -- )
-    check-numbering? get [ [ check-block-numbering ] each-basic-block ] [ drop ] if ;
+    check-numbering? get
+    [ linearization-order [ check-block-numbering ] each ] [ drop ] if ;

basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor

@@ -1,65 +1,67 @@
-IN: compiler.cfg.linear-scan.resolve.tests
 USING: compiler.cfg.linear-scan.resolve tools.test kernel namespaces
+accessors
+compiler.cfg
 compiler.cfg.instructions cpu.architecture make sequences
 compiler.cfg.linear-scan.allocation.state ;
+IN: compiler.cfg.linear-scan.resolve.tests
 
 [
     {
-        { { T{ spill-slot f 0 } int-regs } { 1 int-regs } }
+        { { T{ spill-slot f 0 } int-rep } { 1 int-rep } }
     }
 ] [
     [
-        0 <spill-slot> 1 int-regs add-mapping
+        0 <spill-slot> 1 int-rep add-mapping
     ] { } make
 ] unit-test
 
 [
     {
-        T{ _reload { dst 1 } { class int-regs } { n 0 } }
+        T{ _reload { dst 1 } { rep int-rep } { n 0 } }
     }
 ] [
     [
-        { T{ spill-slot f 0 } int-regs } { 1 int-regs } >insn
+        { T{ spill-slot f 0 } int-rep } { 1 int-rep } >insn
     ] { } make
 ] unit-test
 
 [
     {
-        T{ _spill { src 1 } { class int-regs } { n 0 } }
+        T{ _spill { src 1 } { rep int-rep } { n 0 } }
     }
 ] [
     [
-        { 1 int-regs } { T{ spill-slot f 0 } int-regs } >insn
+        { 1 int-rep } { T{ spill-slot f 0 } int-rep } >insn
     ] { } make
 ] unit-test
 
 [
     {
-        T{ _copy { src 1 } { dst 2 } { class int-regs } }
+        T{ ##copy { src 1 } { dst 2 } { rep int-rep } }
     }
 ] [
     [
-        { 1 int-regs } { 2 int-regs } >insn
+        { 1 int-rep } { 2 int-rep } >insn
     ] { } make
 ] unit-test
 
-H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set
+cfg new 8 >>spill-area-size cfg set
 H{ } clone spill-temps set
 
 [
     t
 ] [
-    { { { 0 int-regs } { 1 int-regs } } { { 1 int-regs } { 0 int-regs } } }
+    { { { 0 int-rep } { 1 int-rep } } { { 1 int-rep } { 0 int-rep } } }
     mapping-instructions {
         {
-            T{ _spill { src 0 } { class int-regs } { n 10 } }
+            T{ _spill { src 0 } { rep int-rep } { n 8 } }
-            T{ _copy { dst 0 } { src 1 } { class int-regs } }
+            T{ ##copy { dst 0 } { src 1 } { rep int-rep } }
-            T{ _reload { dst 1 } { class int-regs } { n 10 } }
+            T{ _reload { dst 1 } { rep int-rep } { n 8 } }
         }
         {
-            T{ _spill { src 1 } { class int-regs } { n 10 } }
+            T{ _spill { src 1 } { rep int-rep } { n 8 } }
-            T{ _copy { dst 1 } { src 0 } { class int-regs } }
+            T{ ##copy { dst 1 } { src 0 } { rep int-rep } }
-            T{ _reload { dst 0 } { class int-regs } { n 10 } }
+            T{ _reload { dst 0 } { rep int-rep } { n 8 } }
         }
     } member?
 ] unit-test

basis/compiler/cfg/linear-scan/resolve/resolve.factor

@@ -3,10 +3,13 @@
 USING: accessors arrays assocs combinators
 combinators.short-circuit fry kernel locals namespaces
 make math sequences hashtables
+compiler.cfg
 compiler.cfg.rpo
 compiler.cfg.liveness
+compiler.cfg.registers
 compiler.cfg.utilities
 compiler.cfg.instructions
+compiler.cfg.predecessors
 compiler.cfg.parallel-copy
 compiler.cfg.linear-scan.assignment
 compiler.cfg.linear-scan.allocation.state ;
@@ -14,16 +17,16 @@ IN: compiler.cfg.linear-scan.resolve
 
 SYMBOL: spill-temps
 
-: spill-temp ( reg-class -- n )
+: spill-temp ( rep -- n )
     spill-temps get [ next-spill-slot ] cache ;
 
-: add-mapping ( from to reg-class -- )
+: add-mapping ( from to rep -- )
     '[ _ 2array ] bi@ 2array , ;
 
 :: resolve-value-data-flow ( bb to vreg -- )
     vreg bb vreg-at-end
     vreg to vreg-at-start
-    2dup = [ 2drop ] [ vreg reg-class>> add-mapping ] if ;
+    2dup = [ 2drop ] [ vreg rep-of add-mapping ] if ;
 
 : compute-mappings ( bb to -- mappings )
     dup live-in dup assoc-empty? [ 3drop f ] [
@@ -43,7 +46,7 @@ SYMBOL: spill-temps
     drop [ first2 ] [ second spill-temp ] bi _spill ;
 
 : register->register ( from to -- )
-    swap [ first ] [ first2 ] bi* _copy ;
+    swap [ first ] [ first2 ] bi* ##copy ;
 
 SYMBOL: temp
 
@@ -62,8 +65,8 @@ SYMBOL: temp
 
 : perform-mappings ( bb to mappings -- )
     dup empty? [ 3drop ] [
-        mapping-instructions <simple-block>
+        mapping-instructions <simple-block> insert-basic-block
-        insert-basic-block
+        cfg get cfg-changed drop
     ] if ;
 
 : resolve-edge-data-flow ( bb to -- )
@@ -73,5 +76,7 @@ SYMBOL: temp
     dup successors>> [ resolve-edge-data-flow ] with each ;
 
 : resolve-data-flow ( cfg -- )
+    needs-predecessors
+
     H{ } clone spill-temps set
     [ resolve-block-data-flow ] each-basic-block ;

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

@@ -1,4 +0,0 @@
-IN: compiler.cfg.linearization.tests
-USING: compiler.cfg.linearization tools.test ;
-
-

basis/compiler/cfg/linearization/linearization.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math accessors sequences namespaces make
-combinators assocs arrays locals cpu.architecture
+combinators assocs arrays locals layouts hashtables
+cpu.architecture
 compiler.cfg
 compiler.cfg.comparisons
 compiler.cfg.stack-frame
@@ -10,6 +11,14 @@ compiler.cfg.utilities
 compiler.cfg.linearization.order ;
 IN: compiler.cfg.linearization
 
+<PRIVATE
+
+SYMBOL: numbers
+
+: block-number ( bb -- n ) numbers get at ;
+
+: number-blocks ( bbs -- ) [ 2array ] map-index >hashtable numbers set ;
+
 ! Convert CFG IR to machine IR.
 GENERIC: linearize-insn ( basic-block insn -- )
 
@@ -70,55 +79,32 @@ M: ##dispatch linearize-insn
     [ successors>> [ block-number _dispatch-label ] each ]
     bi* ;
 
-: (compute-gc-roots) ( n live-values -- n )
+: gc-root-offsets ( registers -- alist )
-    [
+    ! Outputs a sequence of { offset register/spill-slot } pairs
-        [ nip 2array , ]
+    [ length iota [ cell * ] map ] keep zip ;
-        [ drop reg-class>> reg-size + ]
-        3bi
-    ] assoc-each ;
-
-: oop-values ( regs -- regs' )
-    [ drop reg-class>> int-regs eq? ] assoc-filter ;
-
-: data-values ( regs -- regs' )
-    [ drop reg-class>> double-float-regs eq? ] assoc-filter ;
-
-: compute-gc-roots ( live-values -- alist )
-    [
-        [ 0 ] dip
-        ! we put float registers last; the GC doesn't actually scan them
-        [ oop-values (compute-gc-roots) ]
-        [ data-values (compute-gc-roots) ] bi
-        drop
-    ] { } make ;
-
-: count-gc-roots ( live-values -- n )
-    ! Size of GC root area, minus the float registers
-    oop-values assoc-size ;
 
 M: ##gc linearize-insn
     nip
     {
         [ temp1>> ]
         [ temp2>> ]
-        [
+        [ data-values>> ]
-            live-values>>
+        [ tagged-values>> gc-root-offsets ]
-            [ compute-gc-roots ]
-            [ count-gc-roots ]
-            [ gc-roots-size ]
-            tri
-        ]
         [ uninitialized-locs>> ]
     } cleave
     _gc ;
 
 : linearize-basic-blocks ( cfg -- insns )
     [
-        [ linearization-order [ linearize-basic-block ] each ]
+        [
-        [ spill-counts>> _spill-counts ]
+            linearization-order
-        bi
+            [ number-blocks ]
+            [ [ linearize-basic-block ] each ] bi
+        ] [ spill-area-size>> _spill-area-size ] bi
     ] { } make ;
 
+PRIVATE>
+        
 : flatten-cfg ( cfg -- mr )
     [ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
     <mr> ;

basis/compiler/cfg/linearization/order/order.factor

@@ -1,15 +1,16 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs deques dlists kernel make
+USING: accessors assocs deques dlists kernel make sorting
 namespaces sequences combinators combinators.short-circuit
-fry math sets compiler.cfg.rpo compiler.cfg.utilities ;
+fry math sets compiler.cfg.rpo compiler.cfg.utilities
+compiler.cfg.loop-detection ;
 IN: compiler.cfg.linearization.order
 
 ! This is RPO except loops are rotated. Based on SBCL's src/compiler/control.lisp
 
 <PRIVATE
 
-SYMBOLS: work-list loop-heads visited numbers next-number ;
+SYMBOLS: work-list loop-heads visited ;
 
 : visited? ( bb -- ? ) visited get key? ;
 
@@ -18,6 +19,11 @@ SYMBOLS: work-list loop-heads visited numbers next-number ;
         work-list get push-back
     ] if ;
 
+: init-linearization-order ( cfg -- )
+    <dlist> work-list set
+    H{ } clone visited set
+    entry>> add-to-work-list ;
+
 : (find-alternate-loop-head) ( bb -- bb' )
     dup {
         [ predecessor visited? not ]
@@ -46,28 +52,26 @@ SYMBOLS: work-list loop-heads visited numbers next-number ;
         add-to-work-list
     ] [ drop ] if ;
 
-: assign-number ( bb -- )
+: sorted-successors ( bb -- seq )
-    next-number [ get ] [ inc ] bi swap numbers get set-at ;
+    successors>> <reversed> [ loop-nesting-at ] sort-with ;
 
 : process-block ( bb -- )
-    {
     [ , ]
-        [ assign-number ]
     [ visited get conjoin ]
-        [ successors>> <reversed> [ process-successor ] each ]
+    [ sorted-successors [ process-successor ] each ]
-    } cleave ;
+    tri ;
+
+: (linearization-order) ( cfg -- bbs )
+    init-linearization-order
+
+    [ work-list get [ process-block ] slurp-deque ] { } make ;
 
 PRIVATE>
 
 : linearization-order ( cfg -- bbs )
-    ! We call 'post-order drop' to ensure blocks receive their
+    needs-post-order needs-loops
-    ! RPO numbers.
-    <dlist> work-list set
-    H{ } clone visited set
-    H{ } clone numbers set
-    0 next-number set
-    [ post-order drop ]
-    [ entry>> add-to-work-list ] bi
-    [ work-list get [ process-block ] slurp-deque ] { } make ;
 
-: block-number ( bb -- n ) numbers get at ;
+    dup linear-order>> [ ] [
+        dup (linearization-order)
+        >>linear-order linear-order>>
+    ] ?if ;

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

@@ -6,26 +6,25 @@ IN: compiler.cfg.liveness.tests
 
 : test-liveness ( -- )
     cfg new 1 get >>entry
-    compute-predecessors
     compute-live-sets ;
 
 ! Sanity check...
 
 V{
-    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##peek f 0 D 0 }
-    T{ ##replace f V int-regs 0 D 0 }
+    T{ ##replace f 0 D 0 }
-    T{ ##replace f V int-regs 1 D 1 }
+    T{ ##replace f 1 D 1 }
-    T{ ##peek f V int-regs 1 D 1 }
+    T{ ##peek f 1 D 1 }
     T{ ##branch }
 } 1 test-bb
 
 V{
-    T{ ##replace f V int-regs 2 D 0 }
+    T{ ##replace f 2 D 0 }
     T{ ##branch }
 } 2 test-bb
 
 V{
-    T{ ##replace f V int-regs 3 D 0 }
+    T{ ##replace f 3 D 0 }
     T{ ##return }
 } 3 test-bb
 
@@ -35,9 +34,9 @@ test-liveness
 
 [
     H{
-        { V int-regs 1 V int-regs 1 }
+        { 1 1 }
-        { V int-regs 2 V int-regs 2 }
+        { 2 2 }
-        { V int-regs 3 V int-regs 3 }
+        { 3 3 }
     }
 ]
 [ 1 get live-in ]
@@ -46,12 +45,12 @@ unit-test
 ! Tricky case; defs must be killed before uses
 
 V{
-    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##peek f 0 D 0 }
     T{ ##branch }
 } 1 test-bb
 
 V{
-    T{ ##add-imm f V int-regs 0 V int-regs 0 10 }
+    T{ ##add-imm f 0 0 10 }
     T{ ##return }
 } 2 test-bb
 
@@ -59,4 +58,4 @@ V{
 
 test-liveness
 
-[ H{ { V int-regs 0 V int-regs 0 } } ] [ 2 get live-in ] unit-test
+[ H{ { 0 0 } } ] [ 2 get live-in ] unit-test

basis/compiler/cfg/liveness/liveness.factor

@@ -28,4 +28,4 @@ M: live-analysis transfer-set
     drop instructions>> transfer-liveness ;
 
 M: live-analysis join-sets
-    drop assoc-combine ;
+    2drop assoc-combine ;

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

@@ -0,0 +1,62 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces deques accessors sets sequences assocs fry
+hashtables dlists compiler.cfg.def-use compiler.cfg.instructions
+compiler.cfg.rpo compiler.cfg.liveness compiler.cfg.utilities
+compiler.cfg.predecessors ;
+IN: compiler.cfg.liveness.ssa
+
+! TODO: merge with compiler.cfg.liveness
+
+! Assoc mapping basic blocks to sequences of sets of vregs; each sequence
+! is in correspondence with a predecessor
+SYMBOL: phi-live-ins
+
+: phi-live-in ( predecessor basic-block -- set ) phi-live-ins get at at ;
+
+SYMBOL: work-list
+
+: add-to-work-list ( basic-blocks -- )
+    work-list get '[ _ push-front ] each ;
+
+: compute-live-in ( basic-block -- live-in )
+    [ live-out ] keep instructions>> transfer-liveness ;
+
+: compute-phi-live-in ( basic-block -- phi-live-in )
+    H{ } clone [
+        '[ inputs>> [ swap _ conjoin-at ] assoc-each ] each-phi
+    ] keep ;
+
+: update-live-in ( basic-block -- changed? )
+    [ [ compute-live-in ] keep live-ins get maybe-set-at ]
+    [ [ compute-phi-live-in ] keep phi-live-ins get maybe-set-at ]
+    bi or ;
+
+: compute-live-out ( basic-block -- live-out )
+    [ successors>> [ live-in ] map ]
+    [ dup successors>> [ phi-live-in ] with map ] bi
+    append assoc-combine ;
+
+: update-live-out ( basic-block -- changed? )
+    [ compute-live-out ] keep
+    live-outs get maybe-set-at ;
+
+: liveness-step ( basic-block -- )
+    dup update-live-out [
+        dup update-live-in
+        [ predecessors>> add-to-work-list ] [ drop ] if
+    ] [ drop ] if ;
+
+: compute-ssa-live-sets ( cfg -- cfg' )
+    needs-predecessors
+
+    <hashed-dlist> work-list set
+    H{ } clone live-ins set
+    H{ } clone phi-live-ins set
+    H{ } clone live-outs set
+    dup post-order add-to-work-list
+    work-list get [ liveness-step ] slurp-deque ;
+
+: live-in? ( vreg bb -- ? ) live-in key? ;
+
+: live-out? ( vreg bb -- ? ) live-out key? ;

basis/compiler/cfg/loop-detection/loop-detection-tests.factor

@@ -0,0 +1,20 @@
+USING: compiler.cfg compiler.cfg.loop-detection
+compiler.cfg.predecessors
+compiler.cfg.debugger
+tools.test kernel namespaces accessors ;
+IN: compiler.cfg.loop-detection.tests
+
+V{ } 0 test-bb
+V{ } 1 test-bb
+V{ } 2 test-bb
+
+0 { 1 2 } edges
+2 0 edge
+
+: test-loop-detection ( -- ) cfg new 0 get >>entry needs-loops drop ;
+
+[ ] [ test-loop-detection ] unit-test
+
+[ 1 ] [ 0 get loop-nesting-at ] unit-test
+[ 0 ] [ 1 get loop-nesting-at ] unit-test
+[ 1 ] [ 2 get loop-nesting-at ] unit-test

basis/compiler/cfg/loop-detection/loop-detection.factor

@@ -0,0 +1,83 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators deques dlists fry kernel
+namespaces sequences sets compiler.cfg compiler.cfg.predecessors ;
+IN: compiler.cfg.loop-detection
+
+TUPLE: natural-loop header index ends blocks ;
+
+<PRIVATE
+
+SYMBOL: loops
+
+: <natural-loop> ( header index -- loop )
+    H{ } clone H{ } clone natural-loop boa ;
+
+: lookup-header ( header -- loop )
+    loops get [
+        loops get assoc-size <natural-loop>
+    ] cache ;
+
+SYMBOLS: visited active ;
+
+: record-back-edge ( from to -- )
+    lookup-header ends>> conjoin ;
+
+DEFER: find-loop-headers
+
+: visit-edge ( from to -- )
+    dup active get key?
+    [ record-back-edge ]
+    [ nip find-loop-headers ]
+    if ;
+
+: find-loop-headers ( bb -- )
+    dup visited get key? [ drop ] [
+        {
+            [ visited get conjoin ]
+            [ active get conjoin ]
+            [ dup successors>> [ visit-edge ] with each ]
+            [ active get delete-at ]
+        } cleave
+    ] if ;
+
+SYMBOL: work-list
+
+: process-loop-block ( bb loop -- )
+    2dup blocks>> key? [ 2drop ] [
+        [ blocks>> conjoin ] [
+            2dup header>> eq? [ 2drop ] [
+                drop predecessors>> work-list get push-all-front
+            ] if
+        ] 2bi
+    ] if ;
+
+: process-loop-ends ( loop -- )
+    [ ends>> keys <dlist> [ push-all-front ] [ work-list set ] [ ] tri ] keep
+    '[ _ process-loop-block ] slurp-deque ;
+
+: process-loop-headers ( -- )
+    loops get values [ process-loop-ends ] each ;
+
+SYMBOL: loop-nesting
+
+: compute-loop-nesting ( -- )
+    loops get H{ } clone [
+        [ values ] dip '[ blocks>> values [ _ inc-at ] each ] each
+    ] keep loop-nesting set ;
+
+: detect-loops ( cfg -- cfg' )
+    needs-predecessors
+    H{ } clone loops set
+    H{ } clone visited set
+    H{ } clone active set
+    H{ } clone loop-nesting set
+    dup entry>> find-loop-headers process-loop-headers compute-loop-nesting ;
+
+PRIVATE>
+
+: loop-nesting-at ( bb -- n ) loop-nesting get at 0 or ;
+
+: needs-loops ( cfg -- cfg' )
+    needs-predecessors
+    dup loops-valid?>> [ detect-loops t >>loops-valid? ] unless ;

basis/compiler/cfg/mr/mr.factor

@@ -1,12 +1,11 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.cfg.linearization compiler.cfg.two-operand
+USING: kernel namespaces accessors compiler.cfg
-compiler.cfg.gc-checks compiler.cfg.linear-scan
+compiler.cfg.linearization compiler.cfg.gc-checks
-compiler.cfg.build-stack-frame compiler.cfg.rpo ;
+compiler.cfg.linear-scan compiler.cfg.build-stack-frame ;
 IN: compiler.cfg.mr
 
 : build-mr ( cfg -- mr )
-    convert-two-operand
     insert-gc-checks
     linear-scan
     flatten-cfg

basis/compiler/cfg/optimizer/optimizer.factor

@@ -11,10 +11,10 @@ compiler.cfg.value-numbering
 compiler.cfg.copy-prop
 compiler.cfg.dce
 compiler.cfg.write-barrier
+compiler.cfg.representations
+compiler.cfg.two-operand
 compiler.cfg.ssa.destruction
 compiler.cfg.empty-blocks
-compiler.cfg.predecessors
-compiler.cfg.rpo
 compiler.cfg.checker ;
 IN: compiler.cfg.optimizer
 
@@ -26,23 +26,18 @@ SYMBOL: check-optimizer?
     ] when ;
 
 : optimize-cfg ( cfg -- cfg' )
-    ! Note that compute-predecessors has to be called several times.
-    ! The passes that need this document it.
-    [
     optimize-tail-calls
     delete-useless-conditionals
-        compute-predecessors
     split-branches
     join-blocks
-        compute-predecessors
     construct-ssa
     alias-analysis
     value-numbering
-        compute-predecessors
     copy-propagation
     eliminate-dead-code
     eliminate-write-barriers
+    select-representations
+    convert-two-operand
     destruct-ssa
     delete-empty-blocks
-        ?check
+    ?check ;
-    ] with-scope ;

basis/compiler/cfg/parallel-copy/parallel-copy-tests.factor

@@ -11,53 +11,53 @@ SYMBOL: temp
 
 [
     {
-        T{ ##copy f V int-regs 4 V int-regs 2 }
+        T{ ##copy f 4 2 any-rep }
-        T{ ##copy f V int-regs 2 V int-regs 1 }
+        T{ ##copy f 2 1 any-rep }
-        T{ ##copy f V int-regs 1 V int-regs 4 }
+        T{ ##copy f 1 4 any-rep }
     }
 ] [
     H{
-        { V int-regs 1 V int-regs 2 }
+        { 1 2 }
-        { V int-regs 2 V int-regs 1 }
+        { 2 1 }
     } test-parallel-copy
 ] unit-test
 
 [
     {
-        T{ ##copy f V int-regs 1 V int-regs 2 }
+        T{ ##copy f 1 2 any-rep }
-        T{ ##copy f V int-regs 3 V int-regs 4 }
+        T{ ##copy f 3 4 any-rep }
     }
 ] [
     H{
-        { V int-regs 1 V int-regs 2 }
+        { 1 2 }
-        { V int-regs 3 V int-regs 4 }
+        { 3 4 }
     } test-parallel-copy
 ] unit-test
 
 [
     {
-        T{ ##copy f V int-regs 1 V int-regs 3 }
+        T{ ##copy f 1 3 any-rep }
-        T{ ##copy f V int-regs 2 V int-regs 1 }
+        T{ ##copy f 2 1 any-rep }
     }
 ] [
     H{
-        { V int-regs 1 V int-regs 3 }
+        { 1 3 }
-        { V int-regs 2 V int-regs 3 }
+        { 2 3 }
     } test-parallel-copy
 ] unit-test
 
 [
     {
-        T{ ##copy f V int-regs 4 V int-regs 3 }
+        T{ ##copy f 4 3 any-rep }
-        T{ ##copy f V int-regs 3 V int-regs 2 }
+        T{ ##copy f 3 2 any-rep }
-        T{ ##copy f V int-regs 2 V int-regs 1 }
+        T{ ##copy f 2 1 any-rep }
-        T{ ##copy f V int-regs 1 V int-regs 4 }
+        T{ ##copy f 1 4 any-rep }
     }
 ] [
     {
-        { V int-regs 2 V int-regs 1 }
+        { 2 1 }
-        { V int-regs 3 V int-regs 2 }
+        { 3 2 }
-        { V int-regs 1 V int-regs 3 }
+        { 1 3 }
-        { V int-regs 4 V int-regs 3 }
+        { 4 3 }
     } test-parallel-copy
 ] unit-test

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

@@ -1,8 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs compiler.cfg.hats compiler.cfg.instructions
+USING: assocs cpu.architecture compiler.cfg.registers
-deques dlists fry kernel locals namespaces sequences
+compiler.cfg.instructions deques dlists fry kernel locals namespaces
-hashtables ;
+sequences hashtables ;
 IN: compiler.cfg.parallel-copy
 
 ! Revisiting Out-of-SSA Translation for Correctness, Code Quality, and Efficiency
@@ -57,4 +57,5 @@ PRIVATE>
         ] slurp-deque
     ] with-scope ; inline
 
-: parallel-copy ( mapping -- ) i [ ##copy ] parallel-mapping ;
+: parallel-copy ( mapping -- )
+    next-vreg [ any-rep ##copy ] parallel-mapping ;

basis/compiler/cfg/predecessors/predecessors.factor

@@ -4,6 +4,8 @@ USING: kernel accessors combinators fry sequences assocs compiler.cfg.rpo
 compiler.cfg.instructions compiler.cfg.utilities ;
 IN: compiler.cfg.predecessors
 
+<PRIVATE
+
 : update-predecessors ( bb -- )
     dup successors>> [ predecessors>> push ] with each ;
 
@@ -23,3 +25,9 @@ IN: compiler.cfg.predecessors
         [ [ update-phis ] each-basic-block ]
         [ ]
     } cleave ;
+
+PRIVATE>
+
+: needs-predecessors ( cfg -- cfg' )
+    dup predecessors-valid?>>
+    [ compute-predecessors t >>predecessors-valid? ] unless ;

basis/compiler/cfg/registers/registers.factor

@@ -1,18 +1,32 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces kernel arrays parser math math.order ;
+USING: accessors namespaces kernel parser assocs ;
 IN: compiler.cfg.registers
 
-! Virtual registers, used by CFG and machine IRs
+! Virtual registers, used by CFG and machine IRs, are just integers
-TUPLE: vreg { reg-class read-only } { n fixnum read-only } ;
-
-M: vreg equal? over vreg? [ [ n>> ] bi@ eq? ] [ 2drop f ] if ;
-
-M: vreg hashcode* nip n>> ;
-
 SYMBOL: vreg-counter
 
-: next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
+: next-vreg ( -- vreg )
+    ! This word cannot be called AFTER representation selection has run;
+    ! use next-vreg-rep in that case
+    \ vreg-counter counter ;
+
+SYMBOL: representations
+
+ERROR: bad-vreg vreg ;
+
+: rep-of ( vreg -- rep )
+    ! This word cannot be called BEFORE representation selection has run;
+    ! use any-rep for ##copy instructions and so on
+    representations get ?at [ bad-vreg ] unless ;
+
+: set-rep-of ( rep vreg -- )
+    representations get set-at ;
+
+: next-vreg-rep ( rep -- vreg )
+    ! This word cannot be called BEFORE representation selection has run;
+    ! use next-vreg in that case
+    next-vreg [ set-rep-of ] keep ;
 
 ! Stack locations -- 'n' is an index starting from the top of the stack
 ! going down. So 0 is the top of the stack, 1 is what would be the top
@@ -28,6 +42,5 @@ C: <ds-loc> ds-loc
 TUPLE: rs-loc < loc ;
 C: <rs-loc> rs-loc
 
-SYNTAX: V scan-word scan-word vreg boa parsed ;
 SYNTAX: D scan-word <ds-loc> parsed ;
 SYNTAX: R scan-word <rs-loc> parsed ;

basis/compiler/cfg/renaming/renaming.factor

@@ -10,7 +10,4 @@ SYMBOL: renamings
 : rename-value ( vreg -- vreg' )
     renamings get ?at drop ;
 
-: fresh-value ( vreg -- vreg' )
+RENAMING: rename [ rename-value ] [ rename-value ] [ drop next-vreg ]
-    reg-class>> next-vreg ;
-
-RENAMING: rename [ rename-value ] [ rename-value ] [ fresh-value ]

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

@@ -0,0 +1,83 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences arrays fry namespaces
+cpu.architecture compiler.cfg.utilities compiler.cfg compiler.cfg.rpo
+compiler.cfg.instructions compiler.cfg.def-use ;
+IN: compiler.cfg.representations.preferred
+
+GENERIC: defs-vreg-rep ( insn -- rep/f )
+GENERIC: temp-vreg-reps ( insn -- reps )
+GENERIC: uses-vreg-reps ( insn -- reps )
+
+M: ##flushable defs-vreg-rep drop int-rep ;
+M: ##copy defs-vreg-rep rep>> ;
+M: output-float-insn defs-vreg-rep drop double-float-rep ;
+M: ##fixnum-overflow defs-vreg-rep drop int-rep ;
+M: _fixnum-overflow defs-vreg-rep drop int-rep ;
+M: ##phi defs-vreg-rep drop "##phi must be special-cased" throw ;
+M: insn defs-vreg-rep drop f ;
+
+M: ##write-barrier temp-vreg-reps drop { int-rep int-rep } ;
+M: ##unary/temp temp-vreg-reps drop { int-rep } ;
+M: ##allot temp-vreg-reps drop { int-rep } ;
+M: ##dispatch temp-vreg-reps drop { int-rep } ;
+M: ##slot temp-vreg-reps drop { int-rep } ;
+M: ##set-slot temp-vreg-reps drop { int-rep } ;
+M: ##string-nth temp-vreg-reps drop { int-rep } ;
+M: ##set-string-nth-fast temp-vreg-reps drop { int-rep } ;
+M: ##compare temp-vreg-reps drop { int-rep } ;
+M: ##compare-imm temp-vreg-reps drop { int-rep } ;
+M: ##compare-float temp-vreg-reps drop { int-rep } ;
+M: ##gc temp-vreg-reps drop { int-rep int-rep } ;
+M: _dispatch temp-vreg-reps drop { int-rep } ;
+M: insn temp-vreg-reps drop f ;
+
+M: ##copy uses-vreg-reps rep>> 1array ;
+M: ##unary uses-vreg-reps drop { int-rep } ;
+M: ##unary-float uses-vreg-reps drop { double-float-rep } ;
+M: ##binary uses-vreg-reps drop { int-rep int-rep } ;
+M: ##binary-imm uses-vreg-reps drop { int-rep } ;
+M: ##binary-float uses-vreg-reps drop { double-float-rep double-float-rep } ;
+M: ##effect uses-vreg-reps drop { int-rep } ;
+M: ##slot uses-vreg-reps drop { int-rep int-rep } ;
+M: ##slot-imm uses-vreg-reps drop { int-rep } ;
+M: ##set-slot uses-vreg-reps drop { int-rep int-rep int-rep } ;
+M: ##set-slot-imm uses-vreg-reps drop { int-rep int-rep } ;
+M: ##string-nth uses-vreg-reps drop { int-rep int-rep } ;
+M: ##set-string-nth-fast uses-vreg-reps drop { int-rep int-rep int-rep } ;
+M: ##compare-branch uses-vreg-reps drop { int-rep int-rep } ;
+M: ##compare-imm-branch uses-vreg-reps drop { int-rep } ;
+M: ##compare-float-branch uses-vreg-reps drop { double-float-rep double-float-rep } ;
+M: ##dispatch uses-vreg-reps drop { int-rep } ;
+M: ##alien-getter uses-vreg-reps drop { int-rep } ;
+M: ##alien-setter uses-vreg-reps drop { int-rep int-rep } ;
+M: ##set-alien-float uses-vreg-reps drop { int-rep double-float-rep } ;
+M: ##set-alien-double uses-vreg-reps drop { int-rep double-float-rep } ;
+M: ##fixnum-overflow uses-vreg-reps drop { int-rep int-rep } ;
+M: _compare-imm-branch uses-vreg-reps drop { int-rep } ;
+M: _compare-branch uses-vreg-reps drop { int-rep int-rep } ;
+M: _compare-float-branch uses-vreg-reps drop { double-float-rep double-float-rep } ;
+M: _dispatch uses-vreg-reps drop { int-rep } ;
+M: ##phi uses-vreg-reps drop "##phi must be special-cased" throw ;
+M: insn uses-vreg-reps drop f ;
+
+: each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- )
+    [ [ defs-vreg ] [ defs-vreg-rep ] bi ] dip with when* ; inline
+
+: each-use-rep ( insn vreg-quot: ( vreg rep -- ) -- )
+    [ [ uses-vregs ] [ uses-vreg-reps ] bi ] dip 2each ; inline
+
+: each-temp-rep ( insn vreg-quot: ( vreg rep -- ) -- )
+    [ [ temp-vregs ] [ temp-vreg-reps ] bi ] dip 2each ; inline
+
+: with-vreg-reps ( cfg vreg-quot: ( vreg rep -- ) -- )
+    '[
+        [ basic-block set ] [
+            [
+                _
+                [ each-def-rep ]
+                [ each-use-rep ]
+                [ each-temp-rep ] 2tri
+            ] each-non-phi
+        ] bi
+    ] each-basic-block ; inline

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

@@ -0,0 +1,19 @@
+USING: tools.test cpu.architecture
+compiler.cfg.registers compiler.cfg.instructions
+compiler.cfg.representations.preferred ;
+IN: compiler.cfg.representations
+
+[ { double-float-rep double-float-rep } ] [
+    T{ ##add-float
+       { dst 5 }
+       { src1 3 }
+       { src2 4 }
+    } uses-vreg-reps
+] unit-test
+
+[ double-float-rep ] [
+    T{ ##alien-double
+       { dst 5 }
+       { src 3 }
+    } defs-vreg-rep
+] unit-test

basis/compiler/cfg/representations/representations.factor

@@ -0,0 +1,229 @@
+! Copyright (C) 2009 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel fry accessors sequences assocs sets namespaces
+arrays combinators make locals deques dlists
+cpu.architecture compiler.utilities
+compiler.cfg
+compiler.cfg.rpo
+compiler.cfg.registers
+compiler.cfg.instructions
+compiler.cfg.def-use
+compiler.cfg.utilities
+compiler.cfg.loop-detection
+compiler.cfg.renaming.functor
+compiler.cfg.representations.preferred ;
+IN: compiler.cfg.representations
+
+! Virtual register representation selection.
+
+: emit-conversion ( dst src dst-rep src-rep -- )
+    2array {
+        { { int-rep int-rep } [ int-rep ##copy ] }
+        { { double-float-rep double-float-rep } [ double-float-rep ##copy ] }
+        { { double-float-rep int-rep } [ ##unbox-float ] }
+        { { int-rep double-float-rep } [ int-rep next-vreg-rep ##box-float ] }
+    } case ;
+
+<PRIVATE
+
+! For every vreg, compute possible representations.
+SYMBOL: possibilities
+
+: possible ( vreg -- reps ) possibilities get at ;
+
+: compute-possibilities ( cfg -- )
+    H{ } clone [ '[ swap _ conjoin-at ] with-vreg-reps ] keep
+    [ keys ] assoc-map possibilities set ;
+
+! Compute vregs which must remain tagged for their lifetime.
+SYMBOL: always-boxed
+
+:: (compute-always-boxed) ( vreg rep assoc -- )
+    rep int-rep eq? [
+        int-rep vreg assoc set-at
+    ] when ;
+
+: compute-always-boxed ( cfg -- assoc )
+    H{ } clone [
+        '[
+            [
+                dup ##load-reference? [ drop ] [
+                    [ _ (compute-always-boxed) ] each-def-rep
+                ] if
+            ] each-non-phi
+        ] each-basic-block
+    ] keep ;
+
+! For every vreg, compute the cost of keeping it in every possible
+! representation.
+
+! Cost map maps vreg to representation to cost.
+SYMBOL: costs
+
+: init-costs ( -- )
+    possibilities get [ [ 0 ] H{ } map>assoc ] assoc-map costs set ;
+
+: increase-cost ( rep vreg -- )
+    ! Increase cost of keeping vreg in rep, making a choice of rep less
+    ! likely.
+    [ basic-block get loop-nesting-at ] 2dip costs get at at+ ;
+
+: maybe-increase-cost ( possible vreg preferred -- )
+    pick eq? [ 2drop ] [ increase-cost ] if ;
+
+: representation-cost ( vreg preferred -- )
+    ! 'preferred' is a representation that the instruction can accept with no cost.
+    ! So, for each representation that's not preferred, increase the cost of keeping
+    ! the vreg in that representation.
+    [ drop possible ]
+    [ '[ _ _ maybe-increase-cost ] ]
+    2bi each ;
+
+: compute-costs ( cfg -- costs )
+    init-costs [ representation-cost ] with-vreg-reps costs get ;
+
+! For every vreg, compute preferred representation, that minimizes costs.
+: minimize-costs ( costs -- representations )
+    [ >alist alist-min first ] assoc-map ;
+
+: compute-representations ( cfg -- )
+    [ compute-costs minimize-costs ]
+    [ compute-always-boxed ]
+    bi assoc-union
+    representations set ;
+
+! Insert conversions. This introduces new temporaries, so we need
+! to rename opearands too.
+
+:: emit-def-conversion ( dst preferred required -- new-dst' )
+    ! If an instruction defines a register with representation 'required',
+    ! but the register has preferred representation 'preferred', then
+    ! we rename the instruction's definition to a new register, which
+    ! becomes the input of a conversion instruction.
+    dst required next-vreg-rep [ preferred required emit-conversion ] keep ;
+
+:: emit-use-conversion ( src preferred required -- new-src' )
+    ! If an instruction uses a register with representation 'required',
+    ! but the register has preferred representation 'preferred', then
+    ! we rename the instruction's input to a new register, which
+    ! becomes the output of a conversion instruction.
+    required next-vreg-rep [ src required preferred emit-conversion ] keep ;
+
+SYMBOLS: renaming-set needs-renaming? ;
+
+: init-renaming-set ( -- )
+    needs-renaming? off
+    V{ } clone renaming-set set ;
+
+: no-renaming ( vreg -- )
+    dup 2array renaming-set get push ;
+
+: record-renaming ( from to -- )
+    2array renaming-set get push needs-renaming? on ;
+
+:: (compute-renaming-set) ( vreg required quot: ( vreg preferred required -- ) -- )
+    vreg rep-of :> preferred
+    preferred required eq?
+    [ vreg no-renaming ]
+    [ vreg vreg preferred required quot call record-renaming ] if ; inline
+
+: compute-renaming-set ( insn -- )
+    ! temp vregs don't need conversions since they're always in their
+    ! preferred representation
+    init-renaming-set
+    [ [ [ emit-use-conversion ] (compute-renaming-set) ] each-use-rep ]
+    [ , ]
+    [ [ [ emit-def-conversion ] (compute-renaming-set) ] each-def-rep ]
+    tri ;
+
+: converted-value ( vreg -- vreg' )
+    renaming-set get pop first2 [ assert= ] dip ;
+
+RENAMING: convert [ converted-value ] [ converted-value ] [ ]
+
+: perform-renaming ( insn -- )
+    needs-renaming? get [
+        renaming-set get reverse-here
+        [ convert-insn-uses ] [ convert-insn-defs ] bi
+        renaming-set get length 0 assert=
+    ] [ drop ] if ;
+
+GENERIC: conversions-for-insn ( insn -- )
+
+SYMBOL: phi-mappings
+
+! compiler.cfg.cssa inserts conversions which convert phi inputs into
+!  the representation of the output. However, we still have to do some
+!  processing here, because if the only node that uses the output of
+!  the phi instruction is another phi instruction then this phi node's
+! output won't have a representation assigned.
+M: ##phi conversions-for-insn
+    [ , ] [ [ inputs>> values ] [ dst>> ] bi phi-mappings get set-at ] bi ;
+
+M: vreg-insn conversions-for-insn
+    [ compute-renaming-set ] [ perform-renaming ] bi ;
+
+M: insn conversions-for-insn , ;
+
+: conversions-for-block ( bb -- )
+    dup kill-block? [ drop ] [
+        [
+            [
+                [ conversions-for-insn ] each
+            ] V{ } make
+        ] change-instructions drop
+    ] if ;
+
+! If the output of a phi instruction is only used as the input to another
+! phi instruction, then we want to use the same representation for both
+! if possible.
+SYMBOL: work-list
+
+: add-to-work-list ( vregs -- )
+    work-list get push-all-front ;
+
+: rep-assigned ( vregs -- vregs' )
+    representations get '[ _ key? ] filter ;
+
+: rep-not-assigned ( vregs -- vregs' )
+    representations get '[ _ key? not ] filter ;
+
+: add-ready-phis ( -- )
+    phi-mappings get keys rep-assigned add-to-work-list ;
+
+: process-phi-mapping ( dst -- )
+    ! If dst = phi(src1,src2,...) and dst's representation has been
+    ! determined, assign that representation to each one of src1,...
+    ! that does not have a representation yet, and process those, too.
+    dup phi-mappings get at* [
+        [ rep-of ] [ rep-not-assigned ] bi*
+        [ [ set-rep-of ] with each ] [ add-to-work-list ] bi
+    ] [ 2drop ] if ;
+
+: remaining-phi-mappings ( -- )
+    phi-mappings get keys rep-not-assigned
+    [ [ int-rep ] dip set-rep-of ] each ;
+
+: process-phi-mappings ( -- )
+    <hashed-dlist> work-list set
+    add-ready-phis
+    work-list get [ process-phi-mapping ] slurp-deque
+    remaining-phi-mappings ;
+
+: insert-conversions ( cfg -- )
+    H{ } clone phi-mappings set
+    [ conversions-for-block ] each-basic-block
+    process-phi-mappings ;
+
+PRIVATE>
+
+: select-representations ( cfg -- cfg' )
+    needs-loops
+
+    {
+        [ compute-possibilities ]
+        [ compute-representations ]
+        [ insert-conversions ]
+        [ ]
+    } cleave
+    representations get cfg get (>>reps) ;