Merge branch 'master' into s3

Conflicts:

	basis/compiler/cfg/optimizer/optimizer.factor

.gitignore

@@ -12,6 +12,7 @@ Factor/factor
 *.res
 *.RES
 *.image
+factor.image.fresh
 *.dylib
 factor
 factor.com

GNUmakefile

@@ -106,61 +106,63 @@ help:
 	@echo "NO_UI=1  don't link with X11 libraries (ignored on Mac OS X)"
 	@echo "X11=1  force link with X11 libraries instead of Cocoa (only on Mac OS X)"
 
+ALL = factor factor-ffi-test factor-lib
+
 openbsd-x86-32:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.openbsd.x86.32
+	$(MAKE) $(ALL) CONFIG=vm/Config.openbsd.x86.32
 
 openbsd-x86-64:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.openbsd.x86.64
+	$(MAKE) $(ALL) CONFIG=vm/Config.openbsd.x86.64
 
 freebsd-x86-32:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.freebsd.x86.32
+	$(MAKE) $(ALL) CONFIG=vm/Config.freebsd.x86.32
 
 freebsd-x86-64:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.freebsd.x86.64
+	$(MAKE) $(ALL) CONFIG=vm/Config.freebsd.x86.64
 
 netbsd-x86-32:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.netbsd.x86.32
+	$(MAKE) $(ALL) CONFIG=vm/Config.netbsd.x86.32
 
 netbsd-x86-64:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.netbsd.x86.64
+	$(MAKE) $(ALL) CONFIG=vm/Config.netbsd.x86.64
 
 macosx-ppc:
-	$(MAKE) factor factor-ffi-test macosx.app CONFIG=vm/Config.macosx.ppc
+	$(MAKE) $(ALL) macosx.app CONFIG=vm/Config.macosx.ppc
 
 macosx-x86-32:
-	$(MAKE) factor factor-ffi-test macosx.app CONFIG=vm/Config.macosx.x86.32
+	$(MAKE) $(ALL) macosx.app CONFIG=vm/Config.macosx.x86.32
 
 macosx-x86-64:
-	$(MAKE) factor factor-ffi-test macosx.app CONFIG=vm/Config.macosx.x86.64
+	$(MAKE) $(ALL) macosx.app CONFIG=vm/Config.macosx.x86.64
 
 linux-x86-32:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.x86.32
+	$(MAKE) $(ALL) CONFIG=vm/Config.linux.x86.32
 
 linux-x86-64:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.x86.64
+	$(MAKE) $(ALL) CONFIG=vm/Config.linux.x86.64
 
 linux-ppc:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.ppc
+	$(MAKE) $(ALL) CONFIG=vm/Config.linux.ppc
 
 linux-arm:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.arm
+	$(MAKE) $(ALL) CONFIG=vm/Config.linux.arm
 
 solaris-x86-32:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.solaris.x86.32
+	$(MAKE) $(ALL) CONFIG=vm/Config.solaris.x86.32
 
 solaris-x86-64:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.solaris.x86.64
+	$(MAKE) $(ALL) CONFIG=vm/Config.solaris.x86.64
 
 winnt-x86-32:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.windows.nt.x86.32
+	$(MAKE) $(ALL) CONFIG=vm/Config.windows.nt.x86.32
 	$(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.32
 
 winnt-x86-64:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.windows.nt.x86.64
+	$(MAKE) $(ALL) CONFIG=vm/Config.windows.nt.x86.64
 	$(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.64
 
 wince-arm:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.windows.ce.arm
+	$(MAKE) $(ALL) CONFIG=vm/Config.windows.ce.arm
 
 ifdef CONFIG
 
@@ -173,6 +175,8 @@ macosx.app: factor
 $(ENGINE): $(DLL_OBJS)
 	$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
 
+factor-lib: $(ENGINE)
+
 factor: $(EXE_OBJS) $(DLL_OBJS)
 	$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(DLL_OBJS) \
 		$(CFLAGS) -o $(EXECUTABLE) $(EXE_OBJS)
@@ -217,4 +221,4 @@ clean:
 tags:
 	etags vm/*.{cpp,hpp,mm,S,c}
 
-.PHONY: factor factor-console factor-ffi-test tags clean macosx.app
+.PHONY: factor factor-lib factor-console factor-ffi-test tags clean macosx.app

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

@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: byte-arrays arrays assocs kernel kernel.private math
+USING: byte-arrays arrays assocs delegate kernel kernel.private math
 math.order math.parser namespaces make parser sequences strings
 words splitting cpu.architecture alien alien.accessors
 alien.strings quotations layouts system compiler.units io
@@ -79,74 +79,50 @@ GENERIC: c-type-class ( name -- class )
 
 M: abstract-c-type c-type-class class>> ;
 
-M: c-type-name 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: c-type-name c-type-boxed-class c-type c-type-boxed-class ;
-
 GENERIC: c-type-boxer ( name -- boxer )
 
 M: c-type c-type-boxer boxer>> ;
 
-M: c-type-name c-type-boxer c-type c-type-boxer ;
-
 GENERIC: c-type-boxer-quot ( name -- quot )
 
 M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
 
-M: c-type-name c-type-boxer-quot c-type c-type-boxer-quot ;
-
 GENERIC: c-type-unboxer ( name -- boxer )
 
 M: c-type c-type-unboxer unboxer>> ;
 
-M: c-type-name c-type-unboxer c-type c-type-unboxer ;
-
 GENERIC: c-type-unboxer-quot ( name -- quot )
 
 M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
 
-M: c-type-name c-type-unboxer-quot c-type c-type-unboxer-quot ;
-
 GENERIC: c-type-rep ( name -- rep )
 
 M: c-type c-type-rep rep>> ;
 
-M: c-type-name c-type-rep c-type c-type-rep ;
-
 GENERIC: c-type-getter ( name -- quot )
 
 M: c-type c-type-getter getter>> ;
 
-M: c-type-name c-type-getter c-type c-type-getter ;
-
 GENERIC: c-type-setter ( name -- quot )
 
 M: c-type c-type-setter setter>> ;
 
-M: c-type-name c-type-setter c-type c-type-setter ;
-
 GENERIC: c-type-align ( name -- n )
 
 M: abstract-c-type c-type-align align>> ;
 
-M: c-type-name c-type-align c-type c-type-align ;
-
 GENERIC: c-type-align-first ( name -- n )
 
-M: c-type-name c-type-align-first c-type c-type-align-first ;
-
 M: abstract-c-type c-type-align-first align-first>> ;
 
 GENERIC: c-type-stack-align? ( name -- ? )
 
 M: c-type c-type-stack-align? stack-align?>> ;
 
-M: c-type-name c-type-stack-align? c-type c-type-stack-align? ;
-
 : c-type-box ( n c-type -- )
     [ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
     %box ;
@@ -159,38 +135,26 @@ GENERIC: box-parameter ( n c-type -- )
 
 M: c-type box-parameter c-type-box ;
 
-M: c-type-name box-parameter c-type box-parameter ;
-
 GENERIC: box-return ( c-type -- )
 
 M: c-type box-return f swap c-type-box ;
 
-M: c-type-name box-return c-type box-return ;
-
 GENERIC: unbox-parameter ( n c-type -- )
 
 M: c-type unbox-parameter c-type-unbox ;
 
-M: c-type-name unbox-parameter c-type unbox-parameter ;
-
 GENERIC: unbox-return ( c-type -- )
 
 M: c-type unbox-return f swap c-type-unbox ;
 
-M: c-type-name unbox-return c-type unbox-return ;
-
 : little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
 
 GENERIC: heap-size ( name -- size )
 
-M: c-type-name heap-size c-type heap-size ;
-
 M: abstract-c-type heap-size size>> ;
 
 GENERIC: stack-size ( name -- size )
 
-M: c-type-name stack-size c-type stack-size ;
-
 M: c-type stack-size size>> cell align ;
 
 : >c-bool ( ? -- int ) 1 0 ? ; inline
@@ -217,6 +181,29 @@ MIXIN: value-type
         \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
     ] [ ] make ;
 
+PROTOCOL: c-type-protocol 
+    c-type-class
+    c-type-boxed-class
+    c-type-boxer
+    c-type-boxer-quot
+    c-type-unboxer
+    c-type-unboxer-quot
+    c-type-rep
+    c-type-getter
+    c-type-setter
+    c-type-align
+    c-type-align-first
+    c-type-stack-align?
+    box-parameter
+    box-return
+    unbox-parameter
+    unbox-return
+    heap-size
+    stack-size ;
+
+CONSULT: c-type-protocol c-type-name
+    c-type ;
+
 PREDICATE: typedef-word < c-type-word
     "c-type" word-prop c-type-name? ;
 

basis/alien/data/data-docs.factor

@@ -105,7 +105,7 @@ $nl
 "Important guidelines for passing data in byte arrays:"
 { $subsections "byte-arrays-gc" }
 "C-style enumerated types are supported:"
-{ $subsections POSTPONE: C-ENUM: }
+{ $subsections "alien.enums" POSTPONE: ENUM: }
 "C types can be aliased for convenience and consistency with native library documentation:"
 { $subsections POSTPONE: TYPEDEF: }
 "A utility for defining " { $link "destructors" } " for deallocating memory:"

basis/alien/data/data.factor

@@ -1,8 +1,7 @@
 ! (c)2009, 2010 Slava Pestov, Joe Groff bsd license
-USING: accessors alien alien.c-types alien.arrays alien.strings arrays
+USING: accessors alien alien.c-types alien.arrays alien.strings
-byte-arrays cpu.architecture fry io io.encodings.binary
+arrays byte-arrays cpu.architecture fry io io.encodings.binary
-io.files io.streams.memory kernel libc math sequences words
+io.files io.streams.memory kernel libc math sequences words ;
-byte-vectors ;
 IN: alien.data
 
 GENERIC: require-c-array ( c-type -- )
@@ -63,13 +62,6 @@ M: memory-stream stream-read
         swap memory>byte-array
     ] [ [ + ] change-index drop ] 2bi ;
 
-M: byte-vector stream-write
-    [ dup byte-length tail-slice ]
-    [ [ [ byte-length ] bi@ + ] keep lengthen ]
-    [ drop byte-length ]
-    2tri
-    [ >c-ptr swap >c-ptr ] dip memcpy ;
-
 M: value-type c-type-rep drop int-rep ;
 
 M: value-type c-type-getter
@@ -83,4 +75,3 @@ M: array c-type-boxer-quot
     unclip [ array-length ] dip [ <c-direct-array> ] 2curry ;
 
 M: array c-type-unboxer-quot drop [ >c-ptr ] ;
-

basis/alien/enums/enums-docs.factor

@@ -0,0 +1,36 @@
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.syntax help.markup help.syntax words ;
+IN: alien.enums
+
+HELP: define-enum
+{ $values
+    { "word" word } { "base-type" c-type } { "members" "sequence of word and value pairs" }
+}
+{ $description "Defines an enum. This is the run-time equivalent of " { $link POSTPONE: ENUM: } "." } ;
+
+HELP: enum>number
+{ $values
+    { "enum" "an enum word" }
+    { "number" "the corresponding number value" }
+}
+{ $description "Converts an enum to a number." } ;
+
+HELP: number>enum
+{ $values
+    { "number" "an enum number" } { "enum-c-type" "an enum type" }
+    { "enum" "the corresponding enum word" }
+}
+{ $description "Convert a number to an enum." } ;
+
+ARTICLE: "alien.enums" "Enumeration types"
+"The " { $vocab-link "alien.enums" } " vocab contains the implementation for " { $link POSTPONE: ENUM: } " C types, and provides words for converting between enum symbols and integers."
+$nl
+"Defining enums at run-time:"
+{ $subsection define-enum }
+"Conversions between enums and integers:"
+{ $subsections enum>number number>enum } ;
+
+{ POSTPONE: ENUM: define-enum enum>number number>enum } related-words
+
+ABOUT: "alien.enums"

basis/alien/enums/enums-tests.factor

@@ -0,0 +1,35 @@
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.enums alien.enums.private
+alien.syntax sequences tools.test words ;
+IN: alien.enums.tests
+
+ENUM: color_t red { green 3 } blue ;
+ENUM: instrument_t < ushort trombone trumpet ;
+
+{ { red green blue 5 } }
+[ { 0 3 4 5 } [ <color_t> ] map ] unit-test
+
+{ { 0 3 4 5 } }
+[ { red green blue 5 } [ enum>number ] map ] unit-test
+
+{ { -1 trombone trumpet } }
+[ { -1 0 1 } [ <instrument_t> ] map ] unit-test
+
+{ { -1 0 1 } }
+[ { -1 trombone trumpet } [ enum>number ] map ] unit-test
+
+{ t }
+[ color_t "c-type" word-prop enum-c-type? ] unit-test
+
+{ f }
+[ ushort "c-type" word-prop enum-c-type? ] unit-test
+
+{ int }
+[ color_t "c-type" word-prop base-type>> ] unit-test
+
+{ ushort }
+[ instrument_t "c-type" word-prop base-type>> ] unit-test
+
+{ V{ { red 0 } { green 3 } { blue 4 } } }
+[ color_t "c-type" word-prop members>> ] unit-test

basis/alien/enums/enums.factor

@@ -0,0 +1,55 @@
+! (c)2010 Joe Groff, Erik Charlebois bsd license
+USING: accessors alien.c-types arrays combinators delegate fry
+generic.parser kernel macros math parser sequences words words.symbol ;
+IN: alien.enums
+
+<PRIVATE
+TUPLE: enum-c-type base-type members ;
+C: <enum-c-type> enum-c-type
+CONSULT: c-type-protocol enum-c-type
+    base-type>> ;
+PRIVATE>
+
+GENERIC: enum>number ( enum -- number ) foldable
+M: integer enum>number ;
+M: symbol enum>number "enum-value" word-prop ;
+
+<PRIVATE
+: enum-boxer ( members -- quot )
+    [ first2 swap '[ _ ] 2array ]
+    { } map-as [ ] suffix '[ _ case ] ;
+PRIVATE>
+
+MACRO: number>enum ( enum-c-type -- )
+    c-type members>> enum-boxer ;
+
+M: enum-c-type c-type-boxed-class drop object ;
+M: enum-c-type c-type-boxer-quot members>> enum-boxer ;
+M: enum-c-type c-type-unboxer-quot drop [ enum>number ] ;
+M: enum-c-type c-type-setter
+   [ enum>number ] swap base-type>> c-type-setter '[ _ 2dip @ ] ;
+
+<PRIVATE
+
+: define-enum-value ( class value -- )
+    "enum-value" set-word-prop ;
+
+: define-enum-members ( member-names -- )
+    [
+        [ first define-symbol ]
+        [ first2 define-enum-value ] bi
+    ] each ;
+
+: define-enum-constructor ( word -- )
+    [ name>> "<" ">" surround create-in ] keep
+    [ number>enum ] curry (( number -- enum )) define-inline ;
+
+PRIVATE>
+
+: define-enum ( word base-type members -- )
+    [ dup define-enum-constructor ] 2dip
+    dup define-enum-members
+    <enum-c-type> swap typedef ;
+    
+PREDICATE: enum-c-type-word < c-type-word
+    "c-type" word-prop enum-c-type? ;

basis/alien/parser/parser.factor

@@ -75,19 +75,32 @@ M: pointer return-type-name to>> return-type-name CHAR: * suffix ;
     "*" ?head
     [ [ <pointer> ] dip parse-pointers ] when ;
 
+: next-enum-member ( members name value -- members value' )
+    [ 2array suffix! ] [ 1 + ] bi ;
+
+: parse-enum-name ( -- name )
+    scan (CREATE-C-TYPE) dup save-location ;
+
+: parse-enum-base-type ( -- base-type token )
+    scan dup "<" =
+    [ drop scan-object scan ]
+    [ [ int ] dip ] if ;
+
+: parse-enum-member ( members name value -- members value' )
+    over "{" =
+    [ 2drop scan create-in scan-object next-enum-member "}" expect ]
+    [ [ create-in ] dip next-enum-member ] if ;
+
+: parse-enum-members ( members counter token -- members )
+    dup ";" = not
+    [ swap parse-enum-member scan parse-enum-members ] [ 2drop ] if ;
+
 PRIVATE>
 
-: define-enum-member ( word-string value -- next-value )
+: parse-enum ( -- name base-type members )
-     [ create-in ] dip [ define-constant ] keep 1 + ;
+    parse-enum-name
-
+    parse-enum-base-type
-: parse-enum-member ( word-string value -- next-value )
+    [ V{ } clone 0 ] dip parse-enum-members ;
-     over "{" =
-     [ 2drop scan scan-object define-enum-member "}" expect ]
-     [ define-enum-member ] if ;
-
-: parse-enum-members ( counter -- )
-     scan dup ";" = not
-     [ swap parse-enum-member parse-enum-members ] [ 2drop ] if ;
 
 : scan-function-name ( -- return function )
     scan-c-type scan parse-pointers ;

basis/alien/prettyprint/prettyprint.factor

@@ -1,9 +1,10 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel combinators alien alien.strings alien.c-types
+USING: accessors kernel combinators alien alien.enums
-alien.parser alien.syntax arrays assocs effects math.parser
+alien.strings alien.c-types alien.parser alien.syntax arrays
-prettyprint.backend prettyprint.custom prettyprint.sections
+assocs effects math.parser prettyprint.backend prettyprint.custom
-definitions see see.private sequences strings words ;
+prettyprint.sections definitions see see.private sequences
+strings words ;
 IN: alien.prettyprint
 
 M: alien pprint*
@@ -110,3 +111,15 @@ M: alien-callback-type-word synopsis*
             ")" text block>
         ]
     } cleave ;
+
+M: enum-c-type-word definer
+    drop \ ENUM: \ ; ;
+M: enum-c-type-word synopsis*
+    {
+        [ seeing-word ]
+        [ definer. ]
+        [ pprint-word ]
+        [ c-type base-type>> dup int eq? [ drop ] [ "<" text pprint-word ] if ]
+    } cleave ;
+M: enum-c-type-word definition
+    c-type members>> ;

basis/alien/syntax/syntax-docs.factor

@@ -1,6 +1,6 @@
 IN: alien.syntax
-USING: alien alien.c-types alien.parser alien.libraries
+USING: alien alien.c-types alien.enums alien.libraries classes.struct
-classes.struct help.markup help.syntax see ;
+help.markup help.syntax see ;
 
 HELP: DLL"
 { $syntax "DLL\" path\"" }
@@ -69,16 +69,15 @@ HELP: TYPEDEF:
 { $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
 { $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
 
-HELP: C-ENUM:
+HELP: ENUM:
-{ $syntax "C-ENUM: type/f words... ;" }
+{ $syntax "ENUM: type words... ;" "ENUM: type < base-type words..." }
 { $values { "type" "a name to typedef to int or f" } { "words" "a sequence of word names" } }
-{ $description "Creates a sequence of word definitions in the current vocabulary. Each word pushes an integer according to the rules of C enums." }
+{ $description "Creates a c-type that boxes and unboxes integer values to symbols. A symbol is defined for each member word. The base c-type can optionally be specified and defaults to " { $link int } ". A constructor word " { $snippet "<type>" } " is defined for converting from integers to singletons. The generic word " { $link enum>number } " converts from singletons to integers. Enum-typed values are automatically prettyprinted as their singleton words. Unrecognizing enum numbers are kept as numbers." }
-{ $notes "This word emulates a C-style " { $snippet "enum" } " in Factor. While this feature can be used for any purpose, using integer constants is discouraged unless it is for interfacing with C libraries. Factor code should use " { $link "words.symbol" } " or " { $link "singletons" } " instead." }
 { $examples
     "Here is an example enumeration definition:"
-    { $code "C-ENUM: color_t red { green 3 } blue ;" }
+    { $code "ENUM: color_t red { green 3 } blue ;" }
-    "It is equivalent to the following series of definitions:"
+    "The following expression returns true:"
-    { $code "CONSTANT: red 0" "CONSTANT: green 3" "CONSTANT: blue 4" }
+    { $code "3 <color_t> [ green = ] [ enum>number 3 = ] bi and" }
 } ;
 
 HELP: C-TYPE:

basis/alien/syntax/syntax.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2010 Slava Pestov, Alex Chapman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays alien alien.c-types alien.arrays
+USING: accessors arrays alien alien.c-types alien.enums alien.arrays
 alien.strings kernel math namespaces parser sequences words
 quotations math.parser splitting grouping effects assocs
 combinators lexer strings.parser alien.parser fry vocabs.parser
@@ -28,11 +28,8 @@ SYNTAX: CALLBACK:
 SYNTAX: TYPEDEF:
     scan-c-type CREATE-C-TYPE dup save-location typedef ;
 
-SYNTAX: C-ENUM:
+SYNTAX: ENUM:
-    scan dup "f" =
+    parse-enum define-enum ;
-    [ drop ]
-    [ (CREATE-C-TYPE) dup save-location int swap typedef ] if
-    0 parse-enum-members ;
 
 SYNTAX: C-TYPE:
     void CREATE-C-TYPE typedef ;

basis/biassocs/biassocs.factor

@@ -13,9 +13,9 @@ TUPLE: biassoc from to ;
 
 M: biassoc assoc-size from>> assoc-size ;
 
-M: biassoc at* from>> at* ;
+M: biassoc at* from>> at* ; inline
 
-M: biassoc value-at* to>> at* ;
+M: biassoc value-at* to>> at* ; inline
 
 : once-at ( value key assoc -- )
     2dup key? [ 3drop ] [ set-at ] if ;

basis/binary-search/binary-search.factor

@@ -1,14 +1,14 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays combinators hints kernel locals math
-math.order sequences ;
+math.order sequences sequences.private ;
 IN: binary-search
 
 <PRIVATE
 
 :: (search) ( seq from to quot: ( elt -- <=> ) -- i elt )
     from to + 2/ :> midpoint@
-    midpoint@ seq nth :> midpoint
+    midpoint@ seq nth-unsafe :> midpoint
 
     to from - 1 <= [
         midpoint@ midpoint

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

@@ -11,6 +11,9 @@ IN: bit-sets.tests
     T{ bit-set f ?{ f f t f t f } } intersect
 ] unit-test
 
+[ f ] [ T{ bit-set f ?{ t f f f t f } } null? ] unit-test
+[ t ] [ T{ bit-set f ?{ f f f f f f } } null? ] unit-test
+
 [ T{ bit-set f ?{ t f t f f f } } ] [
     T{ bit-set f ?{ t t t f f f } }
     T{ bit-set f ?{ f t f f t t } } diff

basis/bootstrap/compiler/compiler.factor

@@ -20,8 +20,8 @@ IN: bootstrap.compiler
     "alien.remote-control" require
 ] unless
 
-"prettyprint" "alien.prettyprint" require-when
+{ "boostrap.compiler" "prettyprint" } "alien.prettyprint" require-when
-"debugger" "alien.debugger" require-when
+{ "boostrap.compiler" "debugger" } "alien.debugger" require-when
 
 "cpu." cpu name>> append require
 
@@ -57,7 +57,7 @@ gc
 
         curry compose uncurry
 
-        array-nth set-array-nth length>>
+        array-nth set-array-nth
 
         wrap probe
 
@@ -117,4 +117,6 @@ gc
 
     " done" print flush
 
+    "io.streams.byte-array.fast" require
+
 ] unless

basis/bootstrap/handbook/handbook.factor

@@ -1,4 +1,4 @@
 USING: vocabs.loader vocabs kernel ;
 IN: bootstrap.handbook
 
-"bootstrap.help" "help.handbook" require-when
+{ "bootstrap.handbook" "bootstrap.help" } "help.handbook" require-when

basis/bootstrap/stage2.factor

@@ -51,9 +51,11 @@ SYMBOL: bootstrap-time
 
 : save/restore-error ( quot -- )
     error get-global
+    original-error get-global
     error-continuation get-global
-    [ call ] 2dip
+    [ call ] 3dip
     error-continuation set-global
+    original-error set-global
     error set-global ; inline
 
 
@@ -89,6 +91,7 @@ SYMBOL: bootstrap-time
     run-bootstrap-init
 
     f error set-global
+    f original-error set-global
     f error-continuation set-global
 
     nano-count swap - bootstrap-time set-global

basis/bootstrap/threads/threads.factor

@@ -4,6 +4,6 @@ USING: vocabs.loader kernel io.thread threads
 compiler.utilities namespaces ;
 IN: bootstrap.threads
 
-"debugger" "debugger.threads" require-when
+{ "bootstrap.threads" "debugger" } "debugger.threads" require-when
 
 [ yield ] yield-hook set-global

basis/bootstrap/ui/tools/tools.factor

@@ -4,7 +4,7 @@ USING: kernel vocabs vocabs.loader sequences system ;
 [ "bootstrap." prepend vocab ] all? [
     "ui.tools" require
 
-    "ui.backend.cocoa" "ui.backend.cocoa.tools" require-when
+    { "ui.backend.cocoa" } "ui.backend.cocoa.tools" require-when
 
     "ui.tools.walker" require
 ] when

basis/cairo/ffi/ffi.factor

@@ -46,7 +46,7 @@ TYPEDEF: void* cairo_destroy_func_t
 STRUCT: cairo_user_data_key_t
     { unused int } ;
 
-C-ENUM: cairo_status_t
+ENUM: cairo_status_t
     CAIRO_STATUS_SUCCESS
     CAIRO_STATUS_NO_MEMORY
     CAIRO_STATUS_INVALID_RESTORE
@@ -126,7 +126,7 @@ FUNCTION: void
 cairo_pop_group_to_source ( cairo_t* cr ) ;
 
 ! Modify state
-C-ENUM: cairo_operator_t
+ENUM: cairo_operator_t
     CAIRO_OPERATOR_CLEAR
 
     CAIRO_OPERATOR_SOURCE
@@ -163,7 +163,7 @@ cairo_set_source_surface ( cairo_t* cr, cairo_surface_t* surface, double x, doub
 FUNCTION: void
 cairo_set_tolerance ( cairo_t* cr, double tolerance ) ;
 
-C-ENUM: cairo_antialias_t
+ENUM: cairo_antialias_t
     CAIRO_ANTIALIAS_DEFAULT
     CAIRO_ANTIALIAS_NONE
     CAIRO_ANTIALIAS_GRAY
@@ -172,7 +172,7 @@ C-ENUM: cairo_antialias_t
 FUNCTION: void
 cairo_set_antialias ( cairo_t* cr, cairo_antialias_t antialias ) ;
 
-C-ENUM: cairo_fill_rule_t
+ENUM: cairo_fill_rule_t
     CAIRO_FILL_RULE_WINDING
     CAIRO_FILL_RULE_EVEN_ODD ;
 
@@ -182,7 +182,7 @@ cairo_set_fill_rule ( cairo_t* cr, cairo_fill_rule_t fill_rule ) ;
 FUNCTION: void
 cairo_set_line_width ( cairo_t* cr, double width ) ;
 
-C-ENUM: cairo_line_cap_t
+ENUM: cairo_line_cap_t
     CAIRO_LINE_CAP_BUTT
     CAIRO_LINE_CAP_ROUND
     CAIRO_LINE_CAP_SQUARE ;
@@ -190,7 +190,7 @@ C-ENUM: cairo_line_cap_t
 FUNCTION: void
 cairo_set_line_cap ( cairo_t* cr, cairo_line_cap_t line_cap ) ;
 
-C-ENUM: cairo_line_join_t
+ENUM: cairo_line_join_t
     CAIRO_LINE_JOIN_MITER
     CAIRO_LINE_JOIN_ROUND
     CAIRO_LINE_JOIN_BEVEL ;
@@ -375,30 +375,30 @@ STRUCT: cairo_font_extents_t
     { max_x_advance double }
     { max_y_advance double } ;
 
-C-ENUM: cairo_font_slant_t
+ENUM: cairo_font_slant_t
     CAIRO_FONT_SLANT_NORMAL
     CAIRO_FONT_SLANT_ITALIC
     CAIRO_FONT_SLANT_OBLIQUE ;
 
-C-ENUM: cairo_font_weight_t
+ENUM: cairo_font_weight_t
     CAIRO_FONT_WEIGHT_NORMAL
     CAIRO_FONT_WEIGHT_BOLD ;
 
-C-ENUM: cairo_subpixel_order_t
+ENUM: cairo_subpixel_order_t
     CAIRO_SUBPIXEL_ORDER_DEFAULT
     CAIRO_SUBPIXEL_ORDER_RGB
     CAIRO_SUBPIXEL_ORDER_BGR
     CAIRO_SUBPIXEL_ORDER_VRGB
     CAIRO_SUBPIXEL_ORDER_VBGR ;
 
-C-ENUM: cairo_hint_style_t
+ENUM: cairo_hint_style_t
     CAIRO_HINT_STYLE_DEFAULT
     CAIRO_HINT_STYLE_NONE
     CAIRO_HINT_STYLE_SLIGHT
     CAIRO_HINT_STYLE_MEDIUM
     CAIRO_HINT_STYLE_FULL ;
 
-C-ENUM: cairo_hint_metrics_t
+ENUM: cairo_hint_metrics_t
     CAIRO_HINT_METRICS_DEFAULT
     CAIRO_HINT_METRICS_OFF
     CAIRO_HINT_METRICS_ON ;
@@ -518,7 +518,7 @@ cairo_font_face_get_reference_count ( cairo_font_face_t* font_face ) ;
 FUNCTION: cairo_status_t
 cairo_font_face_status ( cairo_font_face_t* font_face ) ;
 
-C-ENUM: cairo_font_type_t
+ENUM: cairo_font_type_t
     CAIRO_FONT_TYPE_TOY
     CAIRO_FONT_TYPE_FT
     CAIRO_FONT_TYPE_WIN32
@@ -630,7 +630,7 @@ cairo_get_target ( cairo_t* cr ) ;
 FUNCTION: cairo_surface_t*
 cairo_get_group_target ( cairo_t* cr ) ;
 
-C-ENUM: cairo_path_data_type_t
+ENUM: cairo_path_data_type_t
     CAIRO_PATH_MOVE_TO
     CAIRO_PATH_LINE_TO
     CAIRO_PATH_CURVE_TO
@@ -696,7 +696,7 @@ cairo_surface_get_reference_count ( cairo_surface_t* surface ) ;
 FUNCTION: cairo_status_t
 cairo_surface_status ( cairo_surface_t* surface ) ;
 
-C-ENUM: cairo_surface_type_t
+ENUM: cairo_surface_type_t
     CAIRO_SURFACE_TYPE_IMAGE
     CAIRO_SURFACE_TYPE_PDF
     CAIRO_SURFACE_TYPE_PS
@@ -759,7 +759,7 @@ cairo_surface_show_page ( cairo_surface_t* surface ) ;
 
 ! Image-surface functions
 
-C-ENUM: cairo_format_t
+ENUM: cairo_format_t
     CAIRO_FORMAT_ARGB32
     CAIRO_FORMAT_RGB24
     CAIRO_FORMAT_A8
@@ -831,7 +831,7 @@ cairo_pattern_get_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* k
 FUNCTION: cairo_status_t
 cairo_pattern_set_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
 
-C-ENUM: cairo_pattern_type_t
+ENUM: cairo_pattern_type_t
     CAIRO_PATTERN_TYPE_SOLID
     CAIRO_PATTERN_TYPE_SURFACE
     CAIRO_PATTERN_TYPE_LINEAR
@@ -852,7 +852,7 @@ cairo_pattern_set_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
 FUNCTION: void
 cairo_pattern_get_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
 
-C-ENUM: cairo_extend_t
+ENUM: cairo_extend_t
     CAIRO_EXTEND_NONE
     CAIRO_EXTEND_REPEAT
     CAIRO_EXTEND_REFLECT
@@ -864,7 +864,7 @@ cairo_pattern_set_extend ( cairo_pattern_t* pattern, cairo_extend_t extend ) ;
 FUNCTION: cairo_extend_t
 cairo_pattern_get_extend ( cairo_pattern_t* pattern ) ;
 
-C-ENUM: cairo_filter_t
+ENUM: cairo_filter_t
     CAIRO_FILTER_FAST
     CAIRO_FILTER_GOOD
     CAIRO_FILTER_BEST

basis/classes/struct/struct-docs.factor

@@ -35,7 +35,8 @@ HELP: STRUCT:
 { "Struct classes cannot have a superclass defined." }
 { "The slots of a struct must all have a type declared. The type must be a C type." } 
 { { $link read-only } " slots on structs are not enforced, though they may be declared." }
-} } ;
+}
+"Additionally, structs may use bit fields. A slot specifier may use the syntax " { $snippet "bits: n" } " to specify that the bit width of the slot is " { $snippet "n" } ". Bit width may be specified on signed or unsigned integer slots. The layout of bit fields is not guaranteed to match that of any particular C compiler." } ;
 
 HELP: S{
 { $syntax "S{ class slots... }" }

basis/classes/struct/struct.factor

@@ -404,4 +404,4 @@ FUNCTOR-SYNTAX: STRUCT:
 
 USING: vocabs vocabs.loader ;
 
-"prettyprint" "classes.struct.prettyprint" require-when
+{ "classes.struct" "prettyprint" } "classes.struct.prettyprint" require-when

basis/cocoa/application/application.factor

@@ -8,10 +8,9 @@ IN: cocoa.application
 
 : <NSString> ( str -- alien ) <CFString> -> autorelease ;
 
-C-ENUM: f
+CONSTANT: NSApplicationDelegateReplySuccess 0
-NSApplicationDelegateReplySuccess
+CONSTANT: NSApplicationDelegateReplyCancel  1
-NSApplicationDelegateReplyCancel
+CONSTANT: NSApplicationDelegateReplyFailure 2
-NSApplicationDelegateReplyFailure ;
 
 : with-autorelease-pool ( quot -- )
     NSAutoreleasePool -> new [ call ] [ -> release ] bi* ; inline

basis/combinators/smart/smart-tests.factor

@@ -63,3 +63,16 @@ IN: combinators.smart.tests
 
 [ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 3 smart-apply ] unit-test
 [ { 1 2 3 } { 4 5 6 } ] [ 1 2 3 4 5 6 [ 3array ] 2 smart-apply ] unit-test
+
+[ 4 ] [ 2 [ even? ] [ 2 + ] smart-when ] unit-test
+[ 3 ] [ 3 [ even? ] [ 2 + ] smart-when ] unit-test
+[ 4 ] [ 2 [ odd? ] [ 2 + ] smart-unless ] unit-test
+[ 3 ] [ 3 [ odd? ] [ 2 + ] smart-unless ] unit-test
+
+[ 4 ] [ 2 [ even? ] [ 2 + ] smart-when* ] unit-test
+[ ] [ 3 [ even? ] [ 2 + ] smart-when* ] unit-test
+[ 3 ] [ 2 [ odd? ] [ 3 ] smart-unless* ] unit-test
+[ 3 ] [ 3 [ odd? ] [ 5 ] smart-unless* ] unit-test
+
+[ -1 ] [ 1 2 [ + odd? ] [ - ] smart-when* ] unit-test
+[ ] [ 2 2 [ + odd? ] [ ] smart-unless* ] unit-test

basis/combinators/smart/smart.factor

@@ -49,8 +49,29 @@ MACRO: preserving ( quot -- )
 MACRO: nullary ( quot -- quot' )
     dup outputs '[ @ _ ndrop ] ;
 
-MACRO: smart-if ( pred true false -- )
+MACRO: dropping ( quot -- quot' )
+    inputs '[ [ _ ndrop ] ] ;
+
+MACRO: balancing ( quot -- quot' )
+    '[ _ [ preserving ] [ dropping ] bi ] ;
+
+MACRO: smart-if ( pred true false -- quot )
     '[ _ preserving _ _ if ] ;
 
-MACRO: smart-apply ( quot n -- )
+MACRO: smart-when ( pred true -- quot )
+    '[ _ _ [ ] smart-if ] ;
+
+MACRO: smart-unless ( pred false -- quot )
+    '[ _ [ ] _ smart-if ] ;
+
+MACRO: smart-if* ( pred true false -- quot )
+    '[ _ balancing _ swap _ compose if ] ;
+
+MACRO: smart-when* ( pred true -- quot )
+    '[ _ _ [ ] smart-if* ] ;
+
+MACRO: smart-unless* ( pred false -- quot )
+    '[ _ [ ] _ smart-if* ] ;
+
+MACRO: smart-apply ( quot n -- quot )
     [ dup inputs ] dip '[ _ _ _ mnapply ] ;

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

@@ -0,0 +1,244 @@
+USING: arrays compiler.cfg.alias-analysis compiler.cfg.instructions
+compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons
+cpu.architecture tools.test ;
+IN: compiler.cfg.alias-analysis.tests
+
+! Redundant load elimination
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##slot-imm f 1 0 1 0 }
+        T{ ##copy f 2 1 any-rep }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##slot-imm f 1 0 1 0 }
+        T{ ##slot-imm f 2 0 1 0 }
+    } alias-analysis-step
+] unit-test
+
+! Store-load forwarding
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##set-slot-imm f 1 0 1 0 }
+        T{ ##copy f 2 1 any-rep }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##set-slot-imm f 1 0 1 0 }
+        T{ ##slot-imm f 2 0 1 0 }
+    } alias-analysis-step
+] unit-test
+
+! Dead store elimination
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##set-slot-imm f 2 0 1 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##set-slot-imm f 1 0 1 0 }
+        T{ ##set-slot-imm f 2 0 1 0 }
+    } alias-analysis-step
+] unit-test
+
+! Redundant store elimination
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##slot-imm f 1 0 1 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##slot-imm f 1 0 1 0 }
+        T{ ##set-slot-imm f 1 0 1 0 }
+    } alias-analysis-step
+] unit-test
+
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##slot-imm f 1 0 1 0 }
+        T{ ##copy f 2 1 any-rep }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##slot-imm f 1 0 1 0 }
+        T{ ##copy f 2 1 any-rep }
+        T{ ##set-slot-imm f 2 0 1 0 }
+    } alias-analysis-step
+] unit-test
+
+! Not a redundant load
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##slot-imm f 1 0 1 0 }
+        T{ ##set-slot-imm f 0 1 1 0 }
+        T{ ##slot-imm f 2 0 1 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##slot-imm f 1 0 1 0 }
+        T{ ##set-slot-imm f 0 1 1 0 }
+        T{ ##slot-imm f 2 0 1 0 }
+    } alias-analysis-step
+] unit-test
+
+! Not a redundant store
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##peek f 3 D 3 }
+        T{ ##set-slot-imm f 2 1 1 0 }
+        T{ ##slot-imm f 4 0 1 0 }
+        T{ ##set-slot-imm f 3 1 1 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##peek f 3 D 3 }
+        T{ ##set-slot-imm f 2 1 1 0 }
+        T{ ##slot-imm f 4 0 1 0 }
+        T{ ##set-slot-imm f 3 1 1 0 }
+    } alias-analysis-step
+] unit-test
+
+! There's a redundant load, but not a redundant store
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##peek f 3 D 3 }
+        T{ ##slot-imm f 4 0 1 0 }
+        T{ ##set-slot-imm f 2 0 1 0 }
+        T{ ##slot f 5 0 3 0 0 }
+        T{ ##set-slot-imm f 3 0 1 0 }
+        T{ ##copy f 6 3 any-rep }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##peek f 3 D 3 }
+        T{ ##slot-imm f 4 0 1 0 }
+        T{ ##set-slot-imm f 2 0 1 0 }
+        T{ ##slot f 5 0 3 0 0 }
+        T{ ##set-slot-imm f 3 0 1 0 }
+        T{ ##slot-imm f 6 0 1 0 }
+    } alias-analysis-step
+] unit-test
+
+! Fresh allocations don't alias existing values
+
+! Redundant load elimination
+[
+    V{
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##peek f 3 D 3 }
+        T{ ##allot f 4 16 array }
+        T{ ##set-slot-imm f 3 4 1 0 }
+        T{ ##set-slot-imm f 2 1 1 0 }
+        T{ ##copy f 5 3 any-rep }
+    }
+] [
+    V{
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##peek f 3 D 3 }
+        T{ ##allot f 4 16 array }
+        T{ ##set-slot-imm f 3 4 1 0 }
+        T{ ##set-slot-imm f 2 1 1 0 }
+        T{ ##slot-imm f 5 4 1 0 }
+    } alias-analysis-step
+] unit-test
+
+! Redundant store elimination
+[
+    V{
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##peek f 3 D 3 }
+        T{ ##allot f 4 16 array }
+        T{ ##slot-imm f 5 1 1 0 }
+        T{ ##set-slot-imm f 3 4 1 0 }
+    }
+] [
+    V{
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##peek f 3 D 3 }
+        T{ ##allot f 4 16 array }
+        T{ ##set-slot-imm f 1 4 1 0 }
+        T{ ##slot-imm f 5 1 1 0 }
+        T{ ##set-slot-imm f 3 4 1 0 }
+    } alias-analysis-step
+] unit-test
+
+! Storing a new alias class into another object means that heap-ac
+! can now alias the new ac
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##peek f 3 D 3 }
+        T{ ##allot f 4 16 array }
+        T{ ##set-slot-imm f 0 4 1 0 }
+        T{ ##set-slot-imm f 4 2 1 0 }
+        T{ ##slot-imm f 5 3 1 0 }
+        T{ ##set-slot-imm f 1 5 1 0 }
+        T{ ##slot-imm f 6 4 1 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##peek f 3 D 3 }
+        T{ ##allot f 4 16 array }
+        T{ ##set-slot-imm f 0 4 1 0 }
+        T{ ##set-slot-imm f 4 2 1 0 }
+        T{ ##slot-imm f 5 3 1 0 }
+        T{ ##set-slot-imm f 1 5 1 0 }
+        T{ ##slot-imm f 6 4 1 0 }
+    } alias-analysis-step
+] unit-test
+
+! Compares between objects which cannot alias are eliminated
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##allot f 1 16 array }
+        T{ ##load-reference f 2 f }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##allot f 1 16 array }
+        T{ ##compare f 2 0 1 cc= }
+    } alias-analysis-step
+] unit-test

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

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math namespaces assocs hashtables sequences arrays
 accessors words vectors combinators combinators.short-circuit
@@ -7,8 +7,8 @@ compiler.cfg
 compiler.cfg.rpo
 compiler.cfg.def-use
 compiler.cfg.liveness
-compiler.cfg.copy-prop
 compiler.cfg.registers
+compiler.cfg.utilities
 compiler.cfg.comparisons
 compiler.cfg.instructions
 compiler.cfg.representations.preferred ;
@@ -68,6 +68,14 @@ IN: compiler.cfg.alias-analysis
 ! e = c
 ! x[1] = c
 
+! Local copy propagation
+SYMBOL: copies
+
+: resolve ( vreg -- vreg ) copies get ?at drop ;
+
+: record-copy ( ##copy -- )
+    [ src>> resolve ] [ dst>> ] bi copies get set-at ; inline
+
 ! Map vregs -> alias classes
 SYMBOL: vregs>acs
 
@@ -85,15 +93,10 @@ SYMBOL: acs>vregs
 
 : ac>vregs ( ac -- vregs ) acs>vregs get at ;
 
-GENERIC: aliases ( vreg -- vregs )
+: aliases ( vreg -- vregs )
-
-M: integer aliases
     #! All vregs which may contain the same value as vreg.
     vreg>ac ac>vregs ;
 
-M: word aliases
-    1array ;
-
 : each-alias ( vreg quot -- )
     [ aliases ] dip each ; inline
 
@@ -187,19 +190,12 @@ SYMBOL: heap-ac
         [ kill-constant-set-slot ] 2bi
     ] [ nip kill-computed-set-slot ] if ;
 
-SYMBOL: constants
-
-: constant ( vreg -- n/f )
-    #! Return a ##load-immediate value, or f if the vreg was not
-    #! assigned by an ##load-immediate.
-    resolve constants get at ;
-
 GENERIC: insn-slot# ( insn -- slot#/f )
 GENERIC: insn-object ( insn -- vreg )
 
-M: ##slot insn-slot# slot>> constant ;
+M: ##slot insn-slot# drop f ;
 M: ##slot-imm insn-slot# slot>> ;
-M: ##set-slot insn-slot# slot>> constant ;
+M: ##set-slot insn-slot# drop f ;
 M: ##set-slot-imm insn-slot# slot>> ;
 M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
 M: ##vm-field insn-slot# offset>> ;
@@ -218,7 +214,6 @@ M: ##set-vm-field insn-object drop \ ##vm-field ;
     H{ } clone vregs>acs set
     H{ } clone acs>vregs set
     H{ } clone live-slots set
-    H{ } clone constants set
     H{ } clone copies set
 
     0 ac-counter set
@@ -238,17 +233,13 @@ M: insn analyze-aliases*
     ! a new value, except boxing instructions haven't been
     ! inserted yet.
     dup defs-vreg [
-        over defs-vreg-rep int-rep eq?
+        over defs-vreg-rep { int-rep tagged-rep } member?
         [ set-heap-ac ] [ set-new-ac ] if
     ] when* ;
 
 M: ##phi analyze-aliases*
     dup defs-vreg set-heap-ac ;
 
-M: ##load-immediate analyze-aliases*
-    call-next-method
-    dup [ val>> ] [ dst>> ] bi constants get set-at ;
-
 M: ##allocation analyze-aliases*
     #! A freshly allocated object is distinct from any other
     #! object.
@@ -257,11 +248,10 @@ M: ##allocation analyze-aliases*
 M: ##read analyze-aliases*
     call-next-method
     dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
-    2dup live-slot dup [
+    2dup live-slot dup
-        2nip any-rep \ ##copy new-insn analyze-aliases* nip
+    [ 2nip <copy> analyze-aliases* nip ]
-    ] [
+    [ drop remember-slot ]
-        drop remember-slot
+    if ;
-    ] if ;
 
 : idempotent? ( value slot#/f vreg -- ? )
     #! Are we storing a value back to the same slot it was read
@@ -271,7 +261,9 @@ M: ##read analyze-aliases*
 M: ##write analyze-aliases*
     dup
     [ src>> resolve ] [ insn-slot# ] [ insn-object ] tri
-    [ remember-set-slot drop ] [ load-slot ] 3bi ;
+    3dup idempotent? [ 3drop ] [
+        [ remember-set-slot drop ] [ load-slot ] 3bi
+    ] if ;
 
 M: ##copy analyze-aliases*
     #! The output vreg gets the same alias class as the input
@@ -287,7 +279,7 @@ M: ##copy analyze-aliases*
 M: ##compare analyze-aliases*
     call-next-method
     dup useless-compare? [
-        dst>> \ f type-number \ ##load-immediate new-insn
+        dst>> f \ ##load-reference new-insn
         analyze-aliases*
     ] when ;
 
@@ -327,5 +319,5 @@ M: insn eliminate-dead-stores* ;
     compute-live-stores
     eliminate-dead-stores ;
 
-: alias-analysis ( cfg -- cfg' )
+: alias-analysis ( cfg -- cfg )
-    [ alias-analysis-step ] local-optimization ;
+    dup [ alias-analysis-step ] simple-optimization ;

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

@@ -1,9 +1,9 @@
 ! Copyright (C) 2008, 2010 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 layouts
+combinators classes words cpu.architecture layouts compiler.cfg
-compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.rpo compiler.cfg.instructions
-compiler.cfg.stack-frame ;
+compiler.cfg.registers compiler.cfg.stack-frame ;
 IN: compiler.cfg.build-stack-frame
 
 SYMBOL: frame-required?
@@ -25,49 +25,29 @@ M: stack-frame-insn compute-stack-frame*
 
 M: ##call compute-stack-frame* drop frame-required? on ;
 
-M: ##gc compute-stack-frame*
+M: ##call-gc compute-stack-frame*
+    drop
     frame-required? on
-    stack-frame new
+    stack-frame new t >>calls-vm? request-stack-frame ;
-        swap tagged-values>> length cells >>gc-root-size
-        t >>calls-vm?
-    request-stack-frame ;
-
-M: _spill-area-size compute-stack-frame*
-    n>> stack-frame get (>>spill-area-size) ;
 
 M: insn compute-stack-frame*
-    class frame-required? word-prop [
+    class "frame-required?" word-prop
-        frame-required? on
+    [ frame-required? on ] when ;
-    ] when ;
 
-\ _spill t frame-required? set-word-prop
+: initial-stack-frame ( -- stack-frame )
-\ ##unary-float-function t frame-required? set-word-prop
+    stack-frame new cfg get spill-area-size>> >>spill-area-size ;
-\ ##binary-float-function t frame-required? set-word-prop
 
 : compute-stack-frame ( insns -- )
     frame-required? off
-    stack-frame new stack-frame set
+    initial-stack-frame stack-frame set
-    [ compute-stack-frame* ] each
+    [ instructions>> [ compute-stack-frame* ] each ] each-basic-block
     stack-frame get dup stack-frame-size >>total-size drop ;
 
-GENERIC: insert-pro/epilogues* ( insn -- )
+: build-stack-frame ( cfg -- cfg )
-
-M: ##prologue insert-pro/epilogues*
-    drop frame-required? get [ stack-frame get _prologue ] when ;
-
-M: ##epilogue insert-pro/epilogues*
-    drop frame-required? get [ stack-frame get _epilogue ] when ;
-
-M: insn insert-pro/epilogues* , ;
-
-: insert-pro/epilogues ( insns -- insns )
-    [ [ insert-pro/epilogues* ] each ] { } make ;
-
-: build-stack-frame ( mr -- mr )
-    [
     [
         [ compute-stack-frame ]
-            [ insert-pro/epilogues ]
+        [
-            bi
+            frame-required? get stack-frame get f ?
-        ] change-instructions
+            >>stack-frame
+        ] bi
     ] with-scope ;

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

@@ -1,17 +1,19 @@
 USING: tools.test kernel sequences words sequences.private fry
-prettyprint alien alien.accessors math.private compiler.tree.builder
+prettyprint alien alien.accessors math.private
-compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
+compiler.tree.builder compiler.tree.optimizer
-compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
+compiler.cfg.builder compiler.cfg.debugger
-compiler.cfg arrays locals byte-arrays kernel.private math
+compiler.cfg.optimizer compiler.cfg.rpo
-slots.private vectors sbufs strings math.partial-dispatch
+compiler.cfg.predecessors compiler.cfg.checker compiler.cfg
-hashtables assocs combinators.short-circuit
+arrays locals byte-arrays kernel.private math slots.private
-strings.private accessors compiler.cfg.instructions ;
+vectors sbufs strings math.partial-dispatch hashtables assocs
+combinators.short-circuit strings.private accessors
+compiler.cfg.instructions compiler.cfg.representations ;
 FROM: alien.c-types => int ;
 IN: compiler.cfg.builder.tests
 
 ! Just ensure that various CFGs build correctly.
-: unit-test-cfg ( quot -- )
+: unit-test-builder ( quot -- )
-    '[ _ test-cfg [ [ optimize-cfg check-cfg ] with-cfg ] each ] [ ] swap unit-test ;
+    '[ _ test-builder [ [ optimize-cfg check-cfg ] with-cfg ] each ] [ ] swap unit-test ;
 
 : blahblah ( nodes -- ? )
     { fixnum } declare [
@@ -104,7 +106,7 @@ IN: compiler.cfg.builder.tests
         set-string-nth-fast
     ]
 } [
-    unit-test-cfg
+    unit-test-builder
 ] each
 
 : test-1 ( -- ) test-1 ;
@@ -115,7 +117,7 @@ IN: compiler.cfg.builder.tests
     test-1
     test-2
     test-3
-} [ unit-test-cfg ] each
+} [ unit-test-builder ] each
 
 {
     byte-array
@@ -133,8 +135,8 @@ IN: compiler.cfg.builder.tests
         alien-float
         alien-double
     } [| word |
-        { class } word '[ _ declare 10 _ execute ] unit-test-cfg
+        { class } word '[ _ declare 10 _ execute ] unit-test-builder
-        { class fixnum } word '[ _ declare _ execute ] unit-test-cfg
+        { class fixnum } word '[ _ declare _ execute ] unit-test-builder
     ] each
     
     {
@@ -145,23 +147,23 @@ IN: compiler.cfg.builder.tests
         set-alien-unsigned-2
         set-alien-unsigned-4
     } [| word |
-        { fixnum class } word '[ _ declare 10 _ execute ] unit-test-cfg
+        { fixnum class } word '[ _ declare 10 _ execute ] unit-test-builder
-        { fixnum class fixnum } word '[ _ declare _ execute ] unit-test-cfg
+        { fixnum class fixnum } word '[ _ declare _ execute ] unit-test-builder
     ] each
     
-    { float class } \ set-alien-float '[ _ declare 10 _ execute ] unit-test-cfg
+    { float class } \ set-alien-float '[ _ declare 10 _ execute ] unit-test-builder
-    { float class fixnum } \ set-alien-float '[ _ declare _ execute ] unit-test-cfg
+    { float class fixnum } \ set-alien-float '[ _ declare _ execute ] unit-test-builder
     
-    { float class } \ set-alien-double '[ _ declare 10 _ execute ] unit-test-cfg
+    { float class } \ set-alien-double '[ _ declare 10 _ execute ] unit-test-builder
-    { float class fixnum } \ set-alien-double '[ _ declare _ execute ] unit-test-cfg
+    { float class fixnum } \ set-alien-double '[ _ declare _ execute ] unit-test-builder
     
-    { pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-cfg
+    { pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-builder
-    { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg
+    { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-builder
 ] each
 
 : count-insns ( quot insn-check -- ? )
-    [ test-mr [ instructions>> ] map ] dip
+    [ test-regs [ post-order [ instructions>> ] map concat ] map concat ] dip
-    '[ _ count ] map-sum ; inline
+    count ; inline
 
 : contains-insn? ( quot insn-check -- ? )
     count-insns 0 > ; inline
@@ -172,17 +174,29 @@ IN: compiler.cfg.builder.tests
 
 [ t ] [
     [ { fixnum byte-array fixnum } declare set-alien-unsigned-1 ]
-    [ ##set-alien-integer-1? ] contains-insn?
+    [ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
 ] unit-test
 
 [ t ] [
     [ { fixnum byte-array fixnum } declare [ dup * dup * ] 2dip set-alien-unsigned-1 ]
-    [ ##set-alien-integer-1? ] contains-insn?
+    [ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
 ] unit-test
 
 [ f ] [
     [ { byte-array fixnum } declare set-alien-unsigned-1 ]
-    [ ##set-alien-integer-1? ] contains-insn?
+    [ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
+] unit-test
+
+[ t t ] [
+    [ { byte-array fixnum } declare alien-cell ]
+    [ [ [ ##load-memory? ] [ ##load-memory-imm? ] bi or ] contains-insn? ]
+    [ [ ##box-alien? ] contains-insn? ]
+    bi
+] unit-test
+
+[ f ] [
+    [ { byte-array integer } declare alien-cell ]
+    [ [ ##load-memory? ] [ ##load-memory-imm? ] bi or ] contains-insn?
 ] unit-test
 
 [ f ] [
@@ -209,7 +223,7 @@ IN: compiler.cfg.builder.tests
         [ [ ##allot? ] contains-insn? ] bi
     ] unit-test
     
-    [ 1 ] [ [ dup float+ ] [ ##alien-double? ] count-insns ] unit-test
+    [ 1 ] [ [ dup float+ ] [ ##load-memory-imm? ] count-insns ] unit-test
 ] when
 
 ! Regression. Make sure everything is inlined correctly

basis/compiler/cfg/builder/builder.factor

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

basis/compiler/cfg/cfg.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math vectors arrays accessors namespaces ;
 IN: compiler.cfg
@@ -8,7 +8,8 @@ TUPLE: basic-block < identity-tuple
 number
 { instructions vector }
 { successors vector }
-{ predecessors vector } ;
+{ predecessors vector }
+{ unlikely? boolean } ;
 
 : <basic-block> ( -- bb )
     basic-block new
@@ -20,7 +21,8 @@ number
 M: basic-block hashcode* nip id>> ;
 
 TUPLE: cfg { entry basic-block } word label
-spill-area-size reps
+spill-area-size
+stack-frame
 post-order linear-order
 predecessors-valid? dominance-valid? loops-valid? ;
 
@@ -41,11 +43,3 @@ predecessors-valid? dominance-valid? loops-valid? ;
 
 : with-cfg ( ..a cfg quot: ( ..a cfg -- ..b ) -- ..b )
     [ dup cfg ] dip with-variable ; inline
-
-TUPLE: mr { instructions array } word label ;
-
-: <mr> ( instructions word label -- mr )
-    mr new
-        swap >>label
-        swap >>word
-        swap >>instructions ;

basis/compiler/cfg/checker/checker.factor

@@ -3,7 +3,8 @@
 USING: kernel combinators.short-circuit accessors math sequences
 sets assocs compiler.cfg.instructions compiler.cfg.rpo
 compiler.cfg.def-use compiler.cfg.linearization
-compiler.cfg.utilities compiler.cfg.mr compiler.utilities ;
+compiler.cfg.utilities compiler.cfg.finalization
+compiler.utilities ;
 IN: compiler.cfg.checker
 
 ! Check invariants
@@ -25,13 +26,7 @@ ERROR: last-insn-not-a-jump bb ;
     dup instructions>> last {
         [ ##branch? ]
         [ ##dispatch? ]
-        [ ##compare-branch? ]
+        [ conditional-branch-insn? ]
-        [ ##compare-imm-branch? ]
-        [ ##compare-float-ordered-branch? ]
-        [ ##compare-float-unordered-branch? ]
-        [ ##fixnum-add? ]
-        [ ##fixnum-sub? ]
-        [ ##fixnum-mul? ]
         [ ##no-tco? ]
     } 1|| [ drop ] [ last-insn-not-a-jump ] if ;
 
@@ -57,18 +52,5 @@ ERROR: bad-successors ;
     [ check-successors ]
     bi ;
 
-ERROR: bad-live-in ;
-
-ERROR: undefined-values uses defs ;
-
-: check-mr ( mr -- )
-    ! Check that every used register has a definition
-    instructions>>
-    [ [ uses-vregs ] map concat ]
-    [ [ [ temp-vregs ] [ defs-vreg ] bi [ suffix ] when* ] map concat ] bi
-    2dup subset? [ 2drop ] [ undefined-values ] if ;
-
 : check-cfg ( cfg -- )
-    [ [ check-basic-block ] each-basic-block ]
+    [ check-basic-block ] each-basic-block ;
-    [ build-mr check-mr ]
-    bi ;

basis/compiler/cfg/comparisons/comparisons.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs math.order sequences ;
 IN: compiler.cfg.comparisons
@@ -12,6 +12,8 @@ SYMBOLS:
 SYMBOLS:
     vcc-all vcc-notall vcc-any vcc-none ;
 
+SYMBOLS: cc-o cc/o ;
+
 : negate-cc ( cc -- cc' )
     H{
         { cc<    cc/<   }
@@ -28,6 +30,8 @@ SYMBOLS:
         { cc/=   cc=    } 
         { cc/<>  cc<>   } 
         { cc/<>= cc<>=  }
+        { cc-o   cc/o   }
+        { cc/o   cc-o   }
     } at ;
 
 : negate-vcc ( cc -- cc' )

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

@@ -0,0 +1,107 @@
+USING: compiler.cfg.copy-prop tools.test namespaces kernel
+compiler.cfg.debugger compiler.cfg accessors
+compiler.cfg.registers compiler.cfg.instructions
+cpu.architecture ;
+IN: compiler.cfg.copy-prop.tests
+
+: test-copy-propagation ( -- )
+    cfg new 0 get >>entry copy-propagation drop ;
+
+! Simple example
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 0 D 0 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##peek f 1 D 1 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##copy f 2 0 any-rep }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##phi f 3 H{ { 2 0 } { 3 2 } } }
+    T{ ##phi f 4 H{ { 2 1 } { 3 2 } } }
+    T{ ##phi f 5 H{ { 2 1 } { 3 0 } } }
+    T{ ##branch }
+} 4 test-bb
+
+V{
+    T{ ##copy f 6 4 any-rep }
+    T{ ##replace f 3 D 0 }
+    T{ ##replace f 5 D 1 }
+    T{ ##replace f 6 D 2 }
+    T{ ##branch }
+} 5 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 6 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+2 4 edge
+3 4 edge
+4 5 edge
+
+[ ] [ test-copy-propagation ] unit-test
+
+[
+    V{
+        T{ ##replace f 0 D 0 }
+        T{ ##replace f 4 D 1 }
+        T{ ##replace f 4 D 2 }
+        T{ ##branch }
+    }
+] [ 5 get instructions>> ] unit-test
+
+! Test optimistic assumption
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 0 D 0 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##phi f 1 H{ { 1 0 } { 2 2 } } }
+    T{ ##copy f 2 1 any-rep }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##replace f 2 D 1 }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 4 test-bb
+
+0 1 edge
+1 2 edge
+2 { 2 3 } edges
+3 4 edge
+
+[ ] [ test-copy-propagation ] unit-test
+
+[
+    V{
+        T{ ##replace f 0 D 1 }
+        T{ ##branch }
+    }
+] [ 3 get instructions>> ] unit-test

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

@@ -1,78 +1,90 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces assocs accessors sequences grouping
+USING: sets kernel namespaces assocs accessors sequences grouping
-combinators compiler.cfg.rpo compiler.cfg.renaming
+combinators fry compiler.cfg.def-use compiler.cfg.rpo
-compiler.cfg.instructions compiler.cfg.predecessors ;
+compiler.cfg.renaming compiler.cfg.instructions
+compiler.cfg.predecessors ;
+FROM: namespaces => set ;
 IN: compiler.cfg.copy-prop
 
-! The first three definitions are also used in compiler.cfg.alias-analysis.
-SYMBOL: copies
-
-! Initialized per-basic-block; a mapping from inputs to dst for eliminating
-! redundant phi instructions
-SYMBOL: phis
-
-: resolve ( vreg -- vreg )
-    copies get ?at drop ;
-
-: (record-copy) ( dst src -- )
-    swap copies get set-at ; inline
-
-: record-copy ( ##copy -- )
-    [ dst>> ] [ src>> resolve ] bi (record-copy) ; inline
-
 <PRIVATE
 
+SYMBOL: changed?
+
+SYMBOL: copies
+
+! Initialized per-basic-block; a mapping from inputs to dst for
+! eliminating redundant ##phi instructions
+SYMBOL: phis
+
+: resolve ( vreg -- vreg )
+    copies get at ;
+
+: record-copy ( dst src -- )
+    swap copies get maybe-set-at [ changed? on ] when ; inline
+
 GENERIC: visit-insn ( insn -- )
 
-M: ##copy visit-insn record-copy ;
+M: ##copy visit-insn
+    [ dst>> ] [ src>> resolve ] bi
+    dup [ record-copy ] [ 2drop ] if ;
 
-: useless-phi ( dst inputs -- ) first (record-copy) ;
+: useless-phi ( dst inputs -- ) first record-copy ;
 
-: redundant-phi ( dst inputs -- ) phis get at (record-copy) ;
+: redundant-phi ( dst inputs -- ) phis get at record-copy ;
 
-: record-phi ( dst inputs -- ) phis get set-at ;
+: record-phi ( dst inputs -- )
+    [ phis get set-at ] [ drop dup record-copy ] 2bi ;
 
 M: ##phi visit-insn
     [ dst>> ] [ inputs>> values [ resolve ] map ] bi
-    {
+    dup phis get key? [ redundant-phi ] [
-        { [ dup all-equal? ] [ useless-phi ] }
+        dup sift
-        { [ dup phis get key? ] [ redundant-phi ] }
+        dup all-equal?
-        [ record-phi ]
+        [ nip useless-phi ]
-    } cond ;
+        [ drop record-phi ] if
+    ] if ;
+
+M: vreg-insn visit-insn
+    defs-vreg [ dup record-copy ] when* ;
 
 M: insn visit-insn drop ;
 
-: collect-copies ( cfg -- )
+: (collect-copies) ( cfg -- )
-    H{ } clone copies set
     [
-        H{ } clone phis set
+        phis get clear-assoc
         instructions>> [ visit-insn ] each
     ] each-basic-block ;
 
+: collect-copies ( cfg -- )
+    H{ } clone copies set
+    H{ } clone phis set
+    '[
+        changed? off
+        _ (collect-copies)
+        changed? get
+    ] loop ;
+
 GENERIC: update-insn ( insn -- keep? )
 
 M: ##copy update-insn drop f ;
 
 M: ##phi update-insn
-    dup dst>> copies get key? [ drop f ] [ call-next-method ] if ;
+    dup call-next-method drop
+    [ dst>> ] [ inputs>> values ] bi [ = not ] with any? ;
 
-M: insn update-insn rename-insn-uses t ;
+M: vreg-insn update-insn rename-insn-uses t ;
+
+M: insn update-insn drop t ;
 
 : rename-copies ( cfg -- )
-    copies get dup assoc-empty? [ 2drop ] [
+    copies get renamings set
-        renamings set
+    [ [ update-insn ] filter! ] simple-optimization ;
-        [
-            instructions>> [ update-insn ] filter! drop
-        ] each-basic-block
-    ] if ;
 
 PRIVATE>
 
 : copy-propagation ( cfg -- cfg' )
     needs-predecessors
 
-    [ collect-copies ]
+    dup collect-copies
-    [ rename-copies ]
+    dup rename-copies ;
-    [ ]
-    tri ;

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

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

basis/compiler/cfg/debugger/debugger.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel words sequences quotations namespaces io vectors
 arrays hashtables classes.tuple accessors prettyprint
@@ -7,45 +7,87 @@ prettyprint.sections parser compiler.tree.builder
 compiler.tree.optimizer cpu.architecture compiler.cfg.builder
 compiler.cfg.linearization compiler.cfg.registers
 compiler.cfg.stack-frame compiler.cfg.linear-scan
-compiler.cfg.optimizer compiler.cfg.instructions
+compiler.cfg.optimizer compiler.cfg.finalization
-compiler.cfg.utilities compiler.cfg.def-use compiler.cfg.rpo
+compiler.cfg.instructions compiler.cfg.utilities
-compiler.cfg.mr compiler.cfg.representations.preferred
+compiler.cfg.def-use compiler.cfg.rpo
-compiler.cfg ;
+compiler.cfg.representations compiler.cfg.gc-checks
+compiler.cfg.save-contexts compiler.cfg
+compiler.cfg.representations.preferred ;
+FROM: compiler.cfg.linearization => number-blocks ;
 IN: compiler.cfg.debugger
 
-GENERIC: test-cfg ( quot -- cfgs )
+GENERIC: test-builder ( quot -- cfgs )
 
-M: callable test-cfg
+M: callable test-builder
     0 vreg-counter set-global
     build-tree optimize-tree gensym build-cfg ;
 
-M: word test-cfg
+M: word test-builder
     0 vreg-counter set-global
     [ build-tree optimize-tree ] keep build-cfg ;
 
-: test-mr ( quot -- mrs )
+: test-optimizer ( quot -- cfgs )
-    test-cfg [
+    test-builder [ [ optimize-cfg ] with-cfg ] map ;
+
+: test-ssa ( quot -- cfgs )
+    test-builder [
         [
             optimize-cfg
-            build-mr
         ] with-cfg
     ] map ;
 
-: insn. ( insn -- )
+: test-flat ( quot -- cfgs )
-    tuple>array but-last [ pprint bl ] each nl ;
+    test-builder [
-
-: mr. ( mrs -- )
         [
+            optimize-cfg
+            select-representations
+            insert-gc-checks
+            insert-save-contexts
+        ] with-cfg
+    ] map ;
+
+: test-regs ( quot -- cfgs )
+    test-builder [
+        [
+            optimize-cfg
+            finalize-cfg
+        ] with-cfg
+    ] map ;
+
+GENERIC: insn. ( insn -- )
+
+M: ##phi insn.
+    clone [ [ [ number>> ] dip ] assoc-map ] change-inputs
+    call-next-method ;
+
+M: insn insn. tuple>array but-last [ bl ] [ pprint ] interleave nl ;
+
+: block. ( bb -- )
+    "=== Basic block #" write dup block-number . nl
+    dup instructions>> [ insn. ] each nl
+    successors>> [
+        "Successors: " write
+        [ block-number unparse ] map ", " join print nl
+    ] unless-empty ;
+
+: cfg. ( cfg -- )
+    [
+        dup linearization-order number-blocks
         "=== word: " write
         dup word>> pprint
         ", label: " write
         dup label>> pprint nl nl
-        instructions>> [ insn. ] each
+        dup linearization-order [ block. ] each
-        nl
+        "=== stack frame: " write
-    ] each ;
+        stack-frame>> .
+    ] with-scope ;
 
-: test-mr. ( quot -- )
+: cfgs. ( cfgs -- )
-    test-mr mr. ; inline
+    [ nl ] [ cfg. ] interleave ;
+
+: ssa. ( quot -- ) test-ssa cfgs. ;
+: flat. ( quot -- ) test-flat cfgs. ;
+: regs. ( quot -- ) test-regs cfgs. ;
 
 ! Prettyprinting
 : pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;

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

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2008, 2010 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs arrays classes combinators
 compiler.units fry generalizations generic kernel locals

basis/compiler/cfg/finalization/authors.txt

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

basis/compiler/cfg/finalization/finalization.factor

@@ -0,0 +1,16 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: compiler.cfg.empty-blocks compiler.cfg.gc-checks
+compiler.cfg.representations compiler.cfg.save-contexts
+compiler.cfg.ssa.destruction compiler.cfg.build-stack-frame
+compiler.cfg.linear-scan compiler.cfg.scheduling ;
+IN: compiler.cfg.finalization
+
+: finalize-cfg ( cfg -- cfg' )
+    select-representations
+    schedule-instructions
+    insert-gc-checks
+    insert-save-contexts
+    destruct-ssa
+    linear-scan
+    build-stack-frame ;

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

@@ -1,14 +1,14 @@
-USING: compiler.cfg.gc-checks compiler.cfg.debugger
+USING: arrays compiler.cfg.gc-checks
+compiler.cfg.gc-checks.private compiler.cfg.debugger
 compiler.cfg.registers compiler.cfg.instructions compiler.cfg
-compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
+compiler.cfg.predecessors compiler.cfg.rpo cpu.architecture
-namespaces accessors sequences ;
+tools.test kernel vectors namespaces accessors sequences alien
+memory classes make combinators.short-circuit byte-arrays ;
 IN: compiler.cfg.gc-checks.tests
 
 : test-gc-checks ( -- )
     H{ } clone representations set
-    cfg new 0 get >>entry
+    cfg new 0 get >>entry cfg set ;
-    insert-gc-checks
-    drop ;
 
 V{
     T{ ##inc-d f 3 }
@@ -23,4 +23,184 @@ V{
 
 [ ] [ test-gc-checks ] unit-test
 
-[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test
+[ t ] [ cfg get blocks-with-gc 1 get 1array sequence= ] unit-test
+
+[ ] [ 1 get allocation-size 123 <alien> size assert= ] unit-test
+
+2 \ vreg-counter set-global
+
+[
+    V{
+        T{ ##load-tagged f 3 0 }
+        T{ ##replace f 3 D 0 }
+        T{ ##replace f 3 R 3 }
+    }
+] [ [ { D 0 R 3 } wipe-locs ] V{ } make ] unit-test
+
+: gc-check? ( bb -- ? )
+    instructions>>
+    {
+        [ length 1 = ]
+        [ first ##check-nursery-branch? ]
+    } 1&& ;
+
+[ t ] [ V{ } 100 <gc-check> gc-check? ] unit-test
+
+4 \ vreg-counter set-global
+
+[
+    V{
+        T{ ##load-tagged f 5 0 }
+        T{ ##replace f 5 D 0 }
+        T{ ##replace f 5 R 3 }
+        T{ ##call-gc f { 0 1 2 } }
+        T{ ##branch }
+    }
+]
+[
+    { D 0 R 3 } { 0 1 2 } <gc-call> instructions>>
+] unit-test
+
+30 \ vreg-counter set-global
+
+V{
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##branch }
+} 4 test-bb
+
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
+3 4 edge
+
+[ ] [ test-gc-checks ] unit-test
+
+[ ] [ cfg get needs-predecessors drop ] unit-test
+
+[ ] [ { D 1 R 2 } { 10 20 } V{ } 31337 3 get (insert-gc-check) ] unit-test
+
+[ t ] [ 1 get successors>> first gc-check? ] unit-test
+
+[ t ] [ 2 get successors>> first gc-check? ] unit-test
+
+[ t ] [ 3 get predecessors>> first gc-check? ] unit-test
+
+30 \ vreg-counter set-global
+
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 2 D 0 }
+    T{ ##inc-d f 3 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##allot f 1 64 byte-array }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##replace f 2 D 1 }
+    T{ ##branch }
+} 4 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 5 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+2 4 edge
+3 4 edge
+4 5 edge
+
+[ ] [ test-gc-checks ] unit-test
+
+H{
+    { 2 tagged-rep }
+} representations set
+
+[ ] [ cfg get insert-gc-checks drop ] unit-test
+
+[ 2 ] [ 2 get predecessors>> length ] unit-test
+
+[ t ] [ 1 get successors>> first gc-check? ] unit-test
+
+[ 64 ] [ 1 get successors>> first instructions>> first size>> ] unit-test
+
+[ t ] [ 2 get predecessors>> first gc-check? ] unit-test
+
+[
+    V{
+        T{ ##load-tagged f 31 0 }
+        T{ ##replace f 31 D 0 }
+        T{ ##replace f 31 D 1 }
+        T{ ##replace f 31 D 2 }
+        T{ ##call-gc f { 2 } }
+        T{ ##branch }
+    }
+] [ 2 get predecessors>> second instructions>> ] unit-test
+
+! Don't forget to invalidate RPO after inserting basic blocks!
+[ 8 ] [ cfg get reverse-post-order length ] unit-test
+
+! Do the right thing with ##phi instructions
+V{
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##load-reference f 1 "hi" }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##load-reference f 2 "bye" }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##phi f 3 H{ { 1 1 } { 2 2 } } }
+    T{ ##allot f 1 64 byte-array }
+    T{ ##branch }
+} 3 test-bb
+
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
+
+[ ] [ test-gc-checks ] unit-test
+
+H{
+    { 1 tagged-rep }
+    { 2 tagged-rep }
+    { 3 tagged-rep }
+} representations set
+
+[ ] [ cfg get insert-gc-checks drop ] unit-test
+[ t ] [ 2 get successors>> first instructions>> first ##phi? ] unit-test
+[ 2 ] [ 3 get instructions>> length ] unit-test

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

@@ -1,15 +1,25 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences assocs fry math
+USING: accessors assocs combinators fry kernel layouts locals
-cpu.architecture layouts namespaces
+math make namespaces sequences cpu.architecture
+compiler.cfg
 compiler.cfg.rpo
+compiler.cfg.hats
 compiler.cfg.registers
+compiler.cfg.utilities
+compiler.cfg.comparisons
 compiler.cfg.instructions
+compiler.cfg.predecessors
+compiler.cfg.liveness
+compiler.cfg.liveness.ssa
 compiler.cfg.stacks.uninitialized ;
 IN: compiler.cfg.gc-checks
 
-! Garbage collection check insertion. This pass runs after representation
+<PRIVATE
-! selection, so it must keep track of representations.
+
+! Garbage collection check insertion. This pass runs after
+! representation selection, since it needs to know which vregs
+! can contain tagged pointers.
 
 : insert-gc-check? ( bb -- ? )
     instructions>> [ ##allocation? ] any? ;
@@ -17,6 +27,54 @@ IN: compiler.cfg.gc-checks
 : blocks-with-gc ( cfg -- bbs )
     post-order [ insert-gc-check? ] filter ;
 
+! A GC check for bb consists of two new basic blocks, gc-check
+! and gc-call:
+!
+!    gc-check
+!   /      \
+!  |     gc-call
+!   \      /
+!      bb
+
+! Any ##phi instructions at the start of bb are transplanted
+! into the gc-check block.
+
+: <gc-check> ( phis size -- bb )
+    [ <basic-block> ] 2dip
+    [
+        [ % ]
+        [
+            cc<= int-rep next-vreg-rep int-rep next-vreg-rep
+            ##check-nursery-branch
+        ] bi*
+    ] V{ } make >>instructions ;
+
+: wipe-locs ( uninitialized-locs -- )
+    '[
+        int-rep next-vreg-rep
+        [ 0 ##load-tagged ]
+        [ '[ [ _ ] dip ##replace ] each ] bi
+    ] unless-empty ;
+
+: <gc-call> ( uninitialized-locs gc-roots -- bb )
+    [ <basic-block> ] 2dip
+    [ [ wipe-locs ] [ ##call-gc ] bi* ##branch ] V{ } make
+    >>instructions t >>unlikely? ;
+
+:: insert-guard ( body check bb -- )
+    bb predecessors>> check (>>predecessors)
+    V{ bb body }      check (>>successors)
+
+    V{ check }        body (>>predecessors)
+    V{ bb }           body (>>successors)
+
+    V{ check body }   bb (>>predecessors)
+
+    check predecessors>> [ bb check update-successors ] each ;
+
+: (insert-gc-check) ( uninitialized-locs gc-roots phis size bb -- )
+    [ [ <gc-call> ] 2dip <gc-check> ] dip insert-guard ;
+
 GENERIC: allocation-size* ( insn -- n )
 
 M: ##allot allocation-size* size>> ;
@@ -30,20 +88,35 @@ M: ##box-displaced-alien allocation-size* drop 5 cells ;
     [ ##allocation? ] filter
     [ allocation-size* data-alignment get align ] map-sum ;
 
+: gc-live-in ( bb -- vregs )
+    [ live-in keys ] [ instructions>> [ ##phi? ] filter [ dst>> ] map ] bi
+    append ;
+
+: live-tagged ( bb -- vregs )
+    gc-live-in [ rep-of tagged-rep? ] filter ;
+
+: remove-phis ( bb -- phis )
+    [ [ ##phi? ] partition ] change-instructions drop ;
+
 : insert-gc-check ( bb -- )
-    dup dup '[
+    {
-        int-rep next-vreg-rep
+        [ uninitialized-locs ]
-        int-rep next-vreg-rep
+        [ live-tagged ]
-        _ allocation-size
+        [ remove-phis ]
-        f
+        [ allocation-size ]
-        f
+        [ ]
-        _ uninitialized-locs
+    } cleave
-        \ ##gc new-insn
+    (insert-gc-check) ;
-        prefix
+
-    ] change-instructions drop ;
+PRIVATE>
 
 : insert-gc-checks ( cfg -- cfg' )
     dup blocks-with-gc [
-        over compute-uninitialized-sets
+        [
+            needs-predecessors
+            dup compute-ssa-live-sets
+            dup compute-uninitialized-sets
+        ] dip
         [ insert-gc-check ] each
+        cfg-changed
     ] unless-empty ;

basis/compiler/cfg/hats/hats.factor

@@ -1,8 +1,9 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays kernel layouts math
+USING: accessors alien arrays byte-arrays classes.algebra
-namespaces sequences combinators splitting parser effects
+combinators.short-circuit kernel layouts math namespaces
-words cpu.architecture compiler.cfg.registers
+sequences combinators splitting parser effects words
+cpu.architecture compiler.constants compiler.cfg.registers
 compiler.cfg.instructions compiler.cfg.instructions.syntax ;
 IN: compiler.cfg.hats
 
@@ -42,18 +43,21 @@ insn-classes get [
 >>
 
 : ^^load-literal ( obj -- dst )
-    [ next-vreg dup ] dip {
+    dup fixnum? [ ^^load-integer ] [ ^^load-reference ] if ;
-        { [ dup not ] [ drop \ f type-number ##load-immediate ] }
-        { [ dup fixnum? ] [ tag-fixnum ##load-immediate ] }
-        { [ dup float? ] [ ##load-constant ] }
-        [ ##load-reference ]
-    } cond ;
 
 : ^^offset>slot ( slot -- vreg' )
-    cell 4 = 2 1 ? ^^shr-imm ;
+    cell 4 = 2 3 ? ^^shl-imm ;
 
-: ^^tag-fixnum ( src -- dst )
+: ^^unbox-f ( src -- dst )
-    tag-bits get ^^shl-imm ;
+    drop 0 ^^load-literal ;
 
-: ^^untag-fixnum ( src -- dst )
+: ^^unbox-byte-array ( src -- dst )
-    tag-bits get ^^sar-imm ;
+    ^^tagged>integer byte-array-offset ^^add-imm ;
+
+: ^^unbox-c-ptr ( src class -- dst )
+    {
+        { [ dup \ f class<= ] [ drop ^^unbox-f ] }
+        { [ dup alien class<= ] [ drop ^^unbox-alien ] }
+        { [ dup byte-array class<= ] [ drop ^^unbox-byte-array ] }
+        [ drop ^^unbox-any-c-ptr ]
+    } cond ;

basis/compiler/cfg/instructions/instructions.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs accessors arrays kernel sequences namespaces words
-math math.order layouts classes.algebra classes.union
+math math.order layouts classes.union compiler.units alien
-compiler.units alien byte-arrays compiler.constants combinators
+byte-arrays combinators compiler.cfg.registers
-compiler.cfg.registers compiler.cfg.instructions.syntax ;
+compiler.cfg.instructions.syntax ;
 IN: compiler.cfg.instructions
 
 <<
@@ -20,27 +20,40 @@ TUPLE: insn ;
 ! value numbering
 TUPLE: pure-insn < insn ;
 
-! Stack operations
+! Constants
-INSN: ##load-immediate
+INSN: ##load-integer
 def: dst/int-rep
-constant: val ;
+literal: val ;
 
 INSN: ##load-reference
-def: dst/int-rep
+def: dst/tagged-rep
-constant: obj ;
+literal: obj ;
 
-INSN: ##load-constant
+! These three are inserted by representation selection
-def: dst/int-rep
+INSN: ##load-tagged
-constant: obj ;
+def: dst/tagged-rep
+literal: val ;
 
+INSN: ##load-double
+def: dst/double-rep
+literal: val ;
+
+INSN: ##load-vector
+def: dst
+literal: val rep ;
+
+! Stack operations
 INSN: ##peek
-def: dst/int-rep
+def: dst/tagged-rep
 literal: loc ;
 
 INSN: ##replace
-use: src/int-rep
+use: src/tagged-rep
 literal: loc ;
 
+INSN: ##replace-imm
+literal: src loc ;
+
 INSN: ##inc-d
 literal: n ;
 
@@ -54,6 +67,10 @@ literal: word ;
 INSN: ##jump
 literal: word ;
 
+INSN: ##prologue ;
+
+INSN: ##epilogue ;
+
 INSN: ##return ;
 
 ! Dummy instruction that simply inhibits TCO
@@ -66,36 +83,33 @@ temp: temp/int-rep ;
 
 ! Slot access
 INSN: ##slot
-def: dst/int-rep
+def: dst/tagged-rep
-use: obj/int-rep slot/int-rep ;
+use: obj/tagged-rep slot/int-rep
+literal: scale tag ;
 
 INSN: ##slot-imm
-def: dst/int-rep
+def: dst/tagged-rep
-use: obj/int-rep
+use: obj/tagged-rep
 literal: slot tag ;
 
 INSN: ##set-slot
-use: src/int-rep obj/int-rep slot/int-rep ;
+use: src/tagged-rep obj/tagged-rep slot/int-rep
+literal: scale tag ;
 
 INSN: ##set-slot-imm
-use: src/int-rep obj/int-rep
+use: src/tagged-rep obj/tagged-rep
 literal: slot tag ;
 
-! String element access
+! Register transfers
-INSN: ##string-nth
+INSN: ##copy
-def: dst/int-rep
-use: obj/int-rep index/int-rep
-temp: temp/int-rep ;
-
-INSN: ##set-string-nth-fast
-use: src/int-rep obj/int-rep index/int-rep
-temp: temp/int-rep ;
-
-PURE-INSN: ##copy
 def: dst
 use: src
 literal: rep ;
 
+PURE-INSN: ##tagged>integer
+def: dst/int-rep
+use: src/tagged-rep ;
+
 ! Integer arithmetic
 PURE-INSN: ##add
 def: dst/int-rep
@@ -104,7 +118,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##add-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
 
 PURE-INSN: ##sub
 def: dst/int-rep
@@ -113,7 +127,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##sub-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
 
 PURE-INSN: ##mul
 def: dst/int-rep
@@ -122,7 +136,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##mul-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
 
 PURE-INSN: ##and
 def: dst/int-rep
@@ -131,7 +145,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##and-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
 
 PURE-INSN: ##or
 def: dst/int-rep
@@ -140,7 +154,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##or-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
 
 PURE-INSN: ##xor
 def: dst/int-rep
@@ -149,7 +163,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##xor-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
 
 PURE-INSN: ##shl
 def: dst/int-rep
@@ -158,7 +172,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##shl-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
 
 PURE-INSN: ##shr
 def: dst/int-rep
@@ -167,7 +181,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##shr-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
 
 PURE-INSN: ##sar
 def: dst/int-rep
@@ -176,7 +190,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##sar-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+literal: src2 ;
 
 PURE-INSN: ##min
 def: dst/int-rep
@@ -336,7 +350,7 @@ use: src1 src2
 literal: rep cc ;
 
 PURE-INSN: ##test-vector
-def: dst/int-rep
+def: dst/tagged-rep
 use: src1
 temp: temp/int-rep
 literal: rep vcc ;
@@ -525,135 +539,57 @@ literal: rep ;
 
 ! Boxing and unboxing aliens
 PURE-INSN: ##box-alien
-def: dst/int-rep
+def: dst/tagged-rep
 use: src/int-rep
 temp: temp/int-rep ;
 
 PURE-INSN: ##box-displaced-alien
-def: dst/int-rep
+def: dst/tagged-rep
-use: displacement/int-rep base/int-rep
+use: displacement/int-rep base/tagged-rep
 temp: temp/int-rep
 literal: base-class ;
 
 PURE-INSN: ##unbox-any-c-ptr
 def: dst/int-rep
-use: src/int-rep ;
+use: src/tagged-rep ;
-
-: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
-: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
 
 PURE-INSN: ##unbox-alien
 def: dst/int-rep
-use: src/int-rep ;
+use: src/tagged-rep ;
 
-: ##unbox-c-ptr ( dst src class -- )
+! Raw memory accessors
-    {
+INSN: ##load-memory
-        { [ dup \ f class<= ] [ drop ##unbox-f ] }
-        { [ dup alien class<= ] [ drop ##unbox-alien ] }
-        { [ dup byte-array class<= ] [ drop ##unbox-byte-array ] }
-        [ drop ##unbox-any-c-ptr ]
-    } cond ;
-
-! Alien accessors
-INSN: ##alien-unsigned-1
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-unsigned-2
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-unsigned-4
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-signed-1
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-signed-2
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-signed-4
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-cell
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-float
-def: dst/float-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-double
-def: dst/double-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-vector
 def: dst
-use: src/int-rep
+use: base/int-rep displacement/int-rep
-literal: offset rep ;
+literal: scale offset rep c-type ;
 
-INSN: ##set-alien-integer-1
+INSN: ##load-memory-imm
-use: src/int-rep
+def: dst
-literal: offset
+use: base/int-rep
-use: value/int-rep ;
+literal: offset rep c-type ;
 
-INSN: ##set-alien-integer-2
+INSN: ##store-memory
-use: src/int-rep
+use: src base/int-rep displacement/int-rep
-literal: offset
+literal: scale offset rep c-type ;
-use: value/int-rep ;
 
-INSN: ##set-alien-integer-4
+INSN: ##store-memory-imm
-use: src/int-rep
+use: src base/int-rep
-literal: offset
+literal: offset rep c-type ;
-use: value/int-rep ;
-
-INSN: ##set-alien-cell
-use: src/int-rep
-literal: offset
-use: value/int-rep ;
-
-INSN: ##set-alien-float
-use: src/int-rep
-literal: offset
-use: value/float-rep ;
-
-INSN: ##set-alien-double
-use: src/int-rep
-literal: offset
-use: value/double-rep ;
-
-INSN: ##set-alien-vector
-use: src/int-rep
-literal: offset
-use: value
-literal: rep ;
 
 ! Memory allocation
 INSN: ##allot
-def: dst/int-rep
+def: dst/tagged-rep
 literal: size class
 temp: temp/int-rep ;
 
 INSN: ##write-barrier
-use: src/int-rep slot/int-rep
+use: src/tagged-rep slot/int-rep
+literal: scale tag
 temp: temp1/int-rep temp2/int-rep ;
 
 INSN: ##write-barrier-imm
-use: src/int-rep
+use: src/tagged-rep
-literal: slot
+literal: slot tag
 temp: temp1/int-rep temp2/int-rep ;
 
 INSN: ##alien-global
@@ -661,11 +597,11 @@ def: dst/int-rep
 literal: symbol library ;
 
 INSN: ##vm-field
-def: dst/int-rep
+def: dst/tagged-rep
 literal: offset ;
 
 INSN: ##set-vm-field
-use: src/int-rep
+use: src/tagged-rep
 literal: offset ;
 
 ! FFI
@@ -681,39 +617,56 @@ literal: params stack-frame ;
 INSN: ##alien-callback
 literal: params stack-frame ;
 
-! Instructions used by CFG IR only.
+! Control flow
-INSN: ##prologue ;
-INSN: ##epilogue ;
-
-INSN: ##branch ;
-
 INSN: ##phi
 def: dst
 literal: inputs ;
 
-! Conditionals
+INSN: ##branch ;
+
+! Tagged conditionals
 INSN: ##compare-branch
-use: src1/int-rep src2/int-rep
+use: src1/tagged-rep src2/tagged-rep
 literal: cc ;
 
 INSN: ##compare-imm-branch
-use: src1/int-rep
+use: src1/tagged-rep
-constant: src2
+literal: src2 cc ;
-literal: cc ;
 
 PURE-INSN: ##compare
-def: dst/int-rep
+def: dst/tagged-rep
-use: src1/int-rep src2/int-rep
+use: src1/tagged-rep src2/tagged-rep
 literal: cc
 temp: temp/int-rep ;
 
 PURE-INSN: ##compare-imm
-def: dst/int-rep
+def: dst/tagged-rep
+use: src1/tagged-rep
+literal: src2 cc
+temp: temp/int-rep ;
+
+! Integer conditionals
+INSN: ##compare-integer-branch
+use: src1/int-rep src2/int-rep
+literal: cc ;
+
+INSN: ##compare-integer-imm-branch
 use: src1/int-rep
-constant: src2
+literal: src2 cc ;
+
+PURE-INSN: ##compare-integer
+def: dst/tagged-rep
+use: src1/int-rep src2/int-rep
 literal: cc
 temp: temp/int-rep ;
 
+PURE-INSN: ##compare-integer-imm
+def: dst/tagged-rep
+use: src1/int-rep
+literal: src2 cc
+temp: temp/int-rep ;
+
+! Float conditionals
 INSN: ##compare-float-ordered-branch
 use: src1/double-rep src2/double-rep
 literal: cc ;
@@ -723,123 +676,81 @@ use: src1/double-rep src2/double-rep
 literal: cc ;
 
 PURE-INSN: ##compare-float-ordered
-def: dst/int-rep
+def: dst/tagged-rep
 use: src1/double-rep src2/double-rep
 literal: cc
 temp: temp/int-rep ;
 
 PURE-INSN: ##compare-float-unordered
-def: dst/int-rep
+def: dst/tagged-rep
 use: src1/double-rep src2/double-rep
 literal: cc
 temp: temp/int-rep ;
 
 ! Overflowing arithmetic
 INSN: ##fixnum-add
-def: dst/int-rep
+def: dst/tagged-rep
-use: src1/int-rep src2/int-rep ;
+use: src1/tagged-rep src2/tagged-rep
+literal: cc ;
 
 INSN: ##fixnum-sub
-def: dst/int-rep
+def: dst/tagged-rep
-use: src1/int-rep src2/int-rep ;
+use: src1/tagged-rep src2/tagged-rep
+literal: cc ;
 
 INSN: ##fixnum-mul
-def: dst/int-rep
+def: dst/tagged-rep
-use: src1/int-rep src2/int-rep ;
+use: src1/tagged-rep src2/int-rep
-
+literal: cc ;
-INSN: ##gc
-temp: temp1/int-rep temp2/int-rep
-literal: size data-values tagged-values uninitialized-locs ;
 
 INSN: ##save-context
 temp: temp1/int-rep temp2/int-rep ;
 
-! Instructions used by machine IR only.
+! GC checks
-INSN: _prologue
+INSN: ##check-nursery-branch
-literal: stack-frame ;
+literal: size cc
+temp: temp1/int-rep temp2/int-rep ;
 
-INSN: _epilogue
+INSN: ##call-gc
-literal: stack-frame ;
+literal: gc-roots ;
-
-INSN: _label
-literal: label ;
-
-INSN: _branch
-literal: label ;
-
-INSN: _loop-entry ;
-
-INSN: _dispatch
-use: src/int-rep
-temp: temp ;
-
-INSN: _dispatch-label
-literal: label ;
-
-INSN: _compare-branch
-literal: label
-use: src1/int-rep src2/int-rep
-literal: cc ;
-
-INSN: _compare-imm-branch
-literal: label
-use: src1/int-rep
-constant: src2
-literal: cc ;
-
-INSN: _compare-float-unordered-branch
-literal: label
-use: src1/int-rep src2/int-rep
-literal: cc ;
-
-INSN: _compare-float-ordered-branch
-literal: label
-use: src1/int-rep src2/int-rep
-literal: cc ;
-
-! Overflowing arithmetic
-INSN: _fixnum-add
-literal: label
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
-
-INSN: _fixnum-sub
-literal: label
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
-
-INSN: _fixnum-mul
-literal: label
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
 
+! Spills and reloads, inserted by register allocator
 TUPLE: spill-slot { n integer } ;
 C: <spill-slot> spill-slot
 
-! These instructions operate on machine registers and not
+INSN: ##spill
-! virtual registers
-INSN: _spill
 use: src
 literal: rep dst ;
 
-INSN: _reload
+INSN: ##reload
 def: dst
 literal: rep src ;
 
-INSN: _spill-area-size
-literal: n ;
-
 UNION: ##allocation
 ##allot
 ##box-alien
 ##box-displaced-alien ;
 
+UNION: conditional-branch-insn
+##compare-branch
+##compare-imm-branch
+##compare-integer-branch
+##compare-integer-imm-branch
+##compare-float-ordered-branch
+##compare-float-unordered-branch
+##test-vector-branch
+##check-nursery-branch
+##fixnum-add
+##fixnum-sub
+##fixnum-mul ;
+
 ! For alias analysis
 UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
 UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
 
-! Instructions that kill all live vregs but cannot trigger GC
+! Instructions that clobber registers
-UNION: partial-sync-insn
+UNION: clobber-insn
+##call-gc
 ##unary-float-function
 ##binary-float-function ;
 
@@ -857,7 +768,6 @@ UNION: kill-vreg-insn
 UNION: def-is-use-insn
 ##box-alien
 ##box-displaced-alien
-##string-nth
 ##unbox-any-c-ptr ;
 
 SYMBOL: vreg-insn

basis/compiler/cfg/instructions/syntax/syntax.factor

@@ -5,7 +5,7 @@ make fry sequences parser accessors effects namespaces
 combinators splitting classes.parser lexer quotations ;
 IN: compiler.cfg.instructions.syntax
 
-SYMBOLS: def use temp literal constant ;
+SYMBOLS: def use temp literal ;
 
 SYMBOL: scalar-rep
 
@@ -31,23 +31,22 @@ TUPLE: insn-slot-spec type name rep ;
                 { "use:" [ drop use ] }
                 { "temp:" [ drop temp ] }
                 { "literal:" [ drop literal ] }
-                { "constant:" [ drop constant ] }
                 [ dupd parse-insn-slot-spec , ]
             } case
         ] reduce drop
     ] { } make ;
 
-: insn-def-slot ( class -- slot/f )
+: find-def-slot ( slots -- slot/f )
-    "insn-slots" word-prop
     [ type>> def eq? ] find nip ;
 
+: insn-def-slot ( class -- slot/f )
+    "insn-slots" word-prop find-def-slot ;
+
 : insn-use-slots ( class -- slots )
-    "insn-slots" word-prop
+    "insn-slots" word-prop [ type>> use eq? ] filter ;
-    [ type>> use eq? ] filter ;
 
 : insn-temp-slots ( class -- slots )
-    "insn-slots" word-prop
+    "insn-slots" word-prop [ type>> temp eq? ] filter ;
-    [ type>> temp eq? ] filter ;
 
 ! We cannot reference words in compiler.cfg.instructions directly
 ! since that would create circularity.

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

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel sequences alien math classes.algebra fry
 locals combinators combinators.short-circuit cpu.architecture
@@ -16,104 +16,72 @@ IN: compiler.cfg.intrinsics.alien
 
 : emit-<displaced-alien> ( node -- )
     dup emit-<displaced-alien>? [
-        [ 2inputs [ ^^untag-fixnum ] dip ] dip
+        '[
-        node-input-infos second class>>
+            _ node-input-infos second class>>
-        ^^box-displaced-alien ds-push
+            ^^box-displaced-alien
+        ] binary-op
     ] [ emit-primitive ] if ;
 
-:: inline-alien ( node quot test -- )
+:: inline-accessor ( node quot test -- )
     node node-input-infos :> infos
     infos test call
     [ infos quot call ]
     [ node emit-primitive ] if ; inline
 
-: inline-alien-getter? ( infos -- ? )
+: inline-load-memory? ( infos -- ? )
     [ first class>> c-ptr class<= ]
     [ second class>> fixnum class<= ]
     bi and ;
 
-: ^^unbox-c-ptr ( src class -- dst )
+: prepare-accessor ( base offset info -- base offset )
-    [ next-vreg dup ] 2dip ##unbox-c-ptr ;
+    class>> swap [ ^^unbox-c-ptr ] dip ^^add 0 ;
 
-: prepare-alien-accessor ( info -- ptr-vreg offset )
+: prepare-load-memory ( infos -- base offset )
-    class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add 0 ;
+    [ 2inputs ] dip first prepare-accessor ;
 
-: prepare-alien-getter ( infos -- ptr-vreg offset )
+: (emit-load-memory) ( node rep c-type quot -- )
-    first prepare-alien-accessor ;
+    '[ prepare-load-memory _ _ ^^load-memory-imm @ ds-push ]
+    [ inline-load-memory? ]
+    inline-accessor ; inline
 
-: inline-alien-getter ( node quot -- )
+: emit-load-memory ( node rep c-type -- )
-    '[ prepare-alien-getter @ ds-push ]
+    [ ] (emit-load-memory) ;
-    [ inline-alien-getter? ] inline-alien ; inline
 
-: inline-alien-setter? ( infos class -- ? )
+: emit-alien-cell ( node -- )
+    int-rep f [ ^^box-alien ] (emit-load-memory) ;
+
+: inline-store-memory? ( infos class -- ? )
     '[ first class>> _ class<= ]
     [ second class>> c-ptr class<= ]
     [ third class>> fixnum class<= ]
     tri and and ;
 
-: prepare-alien-setter ( infos -- ptr-vreg offset )
+: prepare-store-memory ( infos -- value base offset )
-    second prepare-alien-accessor ;
+    [ 3inputs ] dip second prepare-accessor ;
 
-: inline-alien-integer-setter ( node quot -- )
+:: (emit-store-memory) ( node rep c-type prepare-quot test-quot -- )
-    '[ prepare-alien-setter ds-pop ^^untag-fixnum @ ]
+    node
-    [ fixnum inline-alien-setter? ]
+    [ prepare-quot call rep c-type ##store-memory-imm ]
-    inline-alien ; inline
+    [ test-quot call inline-store-memory? ]
+    inline-accessor ; inline
 
-: inline-alien-cell-setter ( node quot -- )
+:: emit-store-memory ( node rep c-type -- )
-    '[ [ prepare-alien-setter ds-pop ] [ first class>> ] bi ^^unbox-c-ptr @ ]
+    node rep c-type
-    [ pinned-c-ptr inline-alien-setter? ]
+    [ prepare-store-memory ]
-    inline-alien ; inline
+    [
-
+        rep {
-: inline-alien-float-setter ( node quot -- )
+            { int-rep [ fixnum ] }
-    '[ prepare-alien-setter ds-pop @ ]
+            { float-rep [ float ] }
-    [ float inline-alien-setter? ]
+            { double-rep [ float ] }
-    inline-alien ; inline
-
-: emit-alien-unsigned-getter ( node n -- )
-    '[
-        _ {
-            { 1 [ ^^alien-unsigned-1 ] }
-            { 2 [ ^^alien-unsigned-2 ] }
-            { 4 [ ^^alien-unsigned-4 ] }
-        } case ^^tag-fixnum
-    ] inline-alien-getter ;
-
-: emit-alien-signed-getter ( node n -- )
-    '[
-        _ {
-            { 1 [ ^^alien-signed-1 ] }
-            { 2 [ ^^alien-signed-2 ] }
-            { 4 [ ^^alien-signed-4 ] }
-        } case ^^tag-fixnum
-    ] inline-alien-getter ;
-
-: emit-alien-integer-setter ( node n -- )
-    '[
-        _ {
-            { 1 [ ##set-alien-integer-1 ] }
-            { 2 [ ##set-alien-integer-2 ] }
-            { 4 [ ##set-alien-integer-4 ] }
         } case
-    ] inline-alien-integer-setter ;
+    ]
+    (emit-store-memory) ;
 
-: emit-alien-cell-getter ( node -- )
+: emit-set-alien-cell ( node -- )
-    [ ^^alien-cell ^^box-alien ] inline-alien-getter ;
+    int-rep f
-
+    [
-: emit-alien-cell-setter ( node -- )
+        [ first class>> ] [ prepare-store-memory ] bi
-    [ ##set-alien-cell ] inline-alien-cell-setter ;
+        [ swap ^^unbox-c-ptr ] 2dip
-
+    ]
-: emit-alien-float-getter ( node rep -- )
+    [ pinned-c-ptr ]
-    '[
+    (emit-store-memory) ;
-        _ {
-            { float-rep [ ^^alien-float ] }
-            { double-rep [ ^^alien-double ] }
-        } case
-    ] inline-alien-getter ;
-
-: emit-alien-float-setter ( node rep -- )
-    '[
-        _ {
-            { float-rep [ ##set-alien-float ] }
-            { double-rep [ ##set-alien-double ] }
-        } case
-    ] inline-alien-float-setter ;

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

@@ -1,9 +1,10 @@
-! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
+! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: sequences accessors layouts kernel math math.intervals
 namespaces combinators fry arrays
 cpu.architecture
 compiler.tree.propagation.info
+compiler.cfg
 compiler.cfg.hats
 compiler.cfg.stacks
 compiler.cfg.instructions
@@ -14,26 +15,24 @@ compiler.cfg.comparisons ;
 IN: compiler.cfg.intrinsics.fixnum
 
 : emit-both-fixnums? ( -- )
-    2inputs
+    [
-    ^^or
+        [ ^^tagged>integer ] bi@
-    tag-mask get ^^and-imm
+        ^^or tag-mask get ^^and-imm
-    0 cc= ^^compare-imm
+        0 cc= ^^compare-integer-imm
-    ds-push ;
+    ] binary-op ;
-
-: tag-literal ( n -- tagged )
-    literal>> [ tag-fixnum ] [ \ f type-number ] if* ;
-
-: emit-fixnum-op ( insn -- )
-    [ 2inputs ] dip call ds-push ; inline
 
 : emit-fixnum-left-shift ( -- )
-    [ ^^untag-fixnum ^^shl ] emit-fixnum-op ;
+    [ ^^shl ] binary-op ;
 
 : emit-fixnum-right-shift ( -- )
-    [ ^^untag-fixnum ^^neg ^^sar dup tag-mask get ^^and-imm ^^xor ] emit-fixnum-op ;
+    [
+        [ tag-bits get ^^shl-imm ] dip
+        ^^neg ^^sar
+        tag-bits get ^^sar-imm
+    ] binary-op ;
 
 : emit-fixnum-shift-general ( -- )
-    ds-peek 0 cc> ##compare-imm-branch
+    ds-peek 0 cc> ##compare-integer-imm-branch
     [ emit-fixnum-left-shift ] with-branch
     [ emit-fixnum-right-shift ] with-branch
     2array emit-conditional ;
@@ -45,17 +44,8 @@ IN: compiler.cfg.intrinsics.fixnum
         [ drop emit-fixnum-shift-general ]
     } cond ;
 
-: emit-fixnum-bitnot ( -- )
-    ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
-
-: emit-fixnum-log2 ( -- )
-    ds-pop ^^log2 tag-bits get ^^sub-imm ^^tag-fixnum ds-push ;
-
-: emit-fixnum*fast ( -- )
-    2inputs ^^untag-fixnum ^^mul ds-push ;
-
 : emit-fixnum-comparison ( cc -- )
-    '[ _ ^^compare ] emit-fixnum-op ;
+    '[ _ ^^compare-integer ] binary-op ;
 
 : emit-no-overflow-case ( dst -- final-bb )
     [ ds-drop ds-drop ds-push ] with-branch ;
@@ -66,7 +56,7 @@ IN: compiler.cfg.intrinsics.fixnum
 : emit-fixnum-overflow-op ( quot word -- )
     ! Inputs to the final instruction need to be copied because
     ! of loc>vreg sync
-    [ [ (2inputs) [ any-rep ^^copy ] bi@ ] dip call ] dip
+    [ [ (2inputs) [ any-rep ^^copy ] bi@ cc/o ] dip call ] dip
     [ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
     emit-conditional ; inline
 
@@ -83,4 +73,4 @@ IN: compiler.cfg.intrinsics.fixnum
     [ ^^fixnum-sub ] \ fixnum-overflow emit-fixnum-overflow-op ;
 
 : emit-fixnum* ( -- )
-    [ ^^untag-fixnum ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ;
+    [ ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ;

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

@@ -1,29 +1,17 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel compiler.cfg.stacks compiler.cfg.hats
+USING: fry kernel compiler.cfg.stacks compiler.cfg.hats
 compiler.cfg.instructions compiler.cfg.utilities ;
 IN: compiler.cfg.intrinsics.float
 
-: emit-float-op ( insn -- )
-    [ 2inputs ] dip call ds-push ; inline
-
 : emit-float-ordered-comparison ( cc -- )
-    [ 2inputs ] dip ^^compare-float-ordered ds-push ; inline
+    '[ _ ^^compare-float-ordered ] binary-op ; inline
 
 : emit-float-unordered-comparison ( cc -- )
-    [ 2inputs ] dip ^^compare-float-unordered ds-push ; inline
+    '[ _ ^^compare-float-unordered ] binary-op ; inline
-
-: emit-float>fixnum ( -- )
-    ds-pop ^^float>integer ^^tag-fixnum ds-push ;
-
-: emit-fixnum>float ( -- )
-    ds-pop ^^untag-fixnum ^^integer>float ds-push ;
-
-: emit-fsqrt ( -- )
-    ds-pop ^^sqrt ds-push ;
 
 : emit-unary-float-function ( func -- )
-    [ ds-pop ] dip ^^unary-float-function ds-push ;
+    '[ _ ^^unary-float-function ] unary-op ;
 
 : emit-binary-float-function ( func -- )
-    [ 2inputs ] dip ^^binary-float-function ds-push ;
+    '[ _ ^^binary-float-function ] binary-op ;

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -1,17 +1,20 @@
-! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
+! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: words sequences kernel combinators cpu.architecture assocs
 compiler.cfg.hats
+compiler.cfg.stacks
 compiler.cfg.instructions
 compiler.cfg.intrinsics.alien
 compiler.cfg.intrinsics.allot
 compiler.cfg.intrinsics.fixnum
 compiler.cfg.intrinsics.float
 compiler.cfg.intrinsics.slots
+compiler.cfg.intrinsics.strings
 compiler.cfg.intrinsics.misc
 compiler.cfg.comparisons ;
 QUALIFIED: alien
 QUALIFIED: alien.accessors
+QUALIFIED: alien.c-types
 QUALIFIED: kernel
 QUALIFIED: arrays
 QUALIFIED: byte-arrays
@@ -38,22 +41,22 @@ IN: compiler.cfg.intrinsics
     { math.private:fixnum+ [ drop emit-fixnum+ ] }
     { math.private:fixnum- [ drop emit-fixnum- ] }
     { math.private:fixnum* [ drop emit-fixnum* ] }
-    { math.private:fixnum+fast [ drop [ ^^add ] emit-fixnum-op ] }
+    { math.private:fixnum+fast [ drop [ ^^add ] binary-op ] }
-    { math.private:fixnum-fast [ drop [ ^^sub ] emit-fixnum-op ] }
+    { math.private:fixnum-fast [ drop [ ^^sub ] binary-op ] }
-    { math.private:fixnum*fast [ drop emit-fixnum*fast ] }
+    { math.private:fixnum*fast [ drop [ ^^mul ] binary-op ] }
-    { math.private:fixnum-bitand [ drop [ ^^and ] emit-fixnum-op ] }
+    { math.private:fixnum-bitand [ drop [ ^^and ] binary-op ] }
-    { math.private:fixnum-bitor [ drop [ ^^or ] emit-fixnum-op ] }
+    { math.private:fixnum-bitor [ drop [ ^^or ] binary-op ] }
-    { math.private:fixnum-bitxor [ drop [ ^^xor ] emit-fixnum-op ] }
+    { math.private:fixnum-bitxor [ drop [ ^^xor ] binary-op ] }
     { math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
-    { math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
+    { math.private:fixnum-bitnot [ drop [ ^^not ] unary-op ] }
     { math.private:fixnum< [ drop cc< emit-fixnum-comparison ] }
     { math.private:fixnum<= [ drop cc<= emit-fixnum-comparison ] }
     { math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] }
     { math.private:fixnum> [ drop cc> emit-fixnum-comparison ] }
-    { kernel:eq? [ drop cc= emit-fixnum-comparison ] }
+    { kernel:eq? [ emit-eq ] }
     { slots.private:slot [ emit-slot ] }
     { slots.private:set-slot [ emit-set-slot ] }
-    { strings.private:string-nth [ drop emit-string-nth ] }
+    { strings.private:string-nth-fast [ drop emit-string-nth-fast ] }
     { strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast ] }
     { classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
     { arrays:<array> [ emit-<array> ] }
@@ -61,32 +64,32 @@ IN: compiler.cfg.intrinsics
     { byte-arrays:(byte-array) [ emit-(byte-array) ] }
     { kernel:<wrapper> [ emit-simple-allot ] }
     { alien:<displaced-alien> [ emit-<displaced-alien> ] }
-    { alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
+    { alien.accessors:alien-unsigned-1 [ int-rep alien.c-types:uchar emit-load-memory ] }
-    { alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
+    { alien.accessors:set-alien-unsigned-1 [ int-rep alien.c-types:uchar emit-store-memory ] }
-    { alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
+    { alien.accessors:alien-signed-1 [ int-rep alien.c-types:char emit-load-memory ] }
-    { alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
+    { alien.accessors:set-alien-signed-1 [ int-rep alien.c-types:char emit-store-memory ] }
-    { alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
+    { alien.accessors:alien-unsigned-2 [ int-rep alien.c-types:ushort emit-load-memory ] }
-    { alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
+    { alien.accessors:set-alien-unsigned-2 [ int-rep alien.c-types:ushort emit-store-memory ] }
-    { alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
+    { alien.accessors:alien-signed-2 [ int-rep alien.c-types:short emit-load-memory ] }
-    { alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
+    { alien.accessors:set-alien-signed-2 [ int-rep alien.c-types:short emit-store-memory ] }
-    { alien.accessors:alien-cell [ emit-alien-cell-getter ] }
+    { alien.accessors:alien-cell [ emit-alien-cell ] }
-    { alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
+    { alien.accessors:set-alien-cell [ emit-set-alien-cell ] }
 } enable-intrinsics
 
 : enable-alien-4-intrinsics ( -- )
     {
-        { alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
+        { alien.accessors:alien-signed-4 [ int-rep alien.c-types:int emit-load-memory ] }
-        { alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
+        { alien.accessors:set-alien-signed-4 [ int-rep alien.c-types:int emit-store-memory ] }
-        { alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
+        { alien.accessors:alien-unsigned-4 [ int-rep alien.c-types:uint emit-load-memory ] }
-        { alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
+        { alien.accessors:set-alien-unsigned-4 [ int-rep alien.c-types:uint emit-store-memory ] }
     } enable-intrinsics ;
 
 : enable-float-intrinsics ( -- )
     {
-        { math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
+        { math.private:float+ [ drop [ ^^add-float ] binary-op ] }
-        { math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
+        { math.private:float- [ drop [ ^^sub-float ] binary-op ] }
-        { math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
+        { math.private:float* [ drop [ ^^mul-float ] binary-op ] }
-        { math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
+        { math.private:float/f [ drop [ ^^div-float ] binary-op ] }
         { math.private:float< [ drop cc< emit-float-ordered-comparison ] }
         { math.private:float<= [ drop cc<= emit-float-ordered-comparison ] }
         { math.private:float>= [ drop cc>= emit-float-ordered-comparison ] }
@@ -96,24 +99,24 @@ IN: compiler.cfg.intrinsics
         { math.private:float-u>= [ drop cc>= emit-float-unordered-comparison ] }
         { math.private:float-u> [ drop cc> emit-float-unordered-comparison ] }
         { math.private:float= [ drop cc= emit-float-unordered-comparison ] }
-        { math.private:float>fixnum [ drop emit-float>fixnum ] }
+        { math.private:float>fixnum [ drop [ ^^float>integer ] unary-op ] }
-        { math.private:fixnum>float [ drop emit-fixnum>float ] }
+        { math.private:fixnum>float [ drop [ ^^integer>float ] unary-op ] }
         { math.floats.private:float-unordered? [ drop cc/<>= emit-float-unordered-comparison ] }
-        { alien.accessors:alien-float [ float-rep emit-alien-float-getter ] }
+        { alien.accessors:alien-float [ float-rep f emit-load-memory ] }
-        { alien.accessors:set-alien-float [ float-rep emit-alien-float-setter ] }
+        { alien.accessors:set-alien-float [ float-rep f emit-store-memory ] }
-        { alien.accessors:alien-double [ double-rep emit-alien-float-getter ] }
+        { alien.accessors:alien-double [ double-rep f emit-load-memory ] }
-        { alien.accessors:set-alien-double [ double-rep emit-alien-float-setter ] }
+        { alien.accessors:set-alien-double [ double-rep f emit-store-memory ] }
     } enable-intrinsics ;
 
 : enable-fsqrt ( -- )
     {
-        { math.libm:fsqrt [ drop emit-fsqrt ] }
+        { math.libm:fsqrt [ drop [ ^^sqrt ] unary-op ] }
     } enable-intrinsics ;
 
 : enable-float-min/max ( -- )
     {
-        { math.floats.private:float-min [ drop [ ^^min-float ] emit-float-op ] }
+        { math.floats.private:float-min [ drop [ ^^min-float ] binary-op ] }
-        { math.floats.private:float-max [ drop [ ^^max-float ] emit-float-op ] }
+        { math.floats.private:float-max [ drop [ ^^max-float ] binary-op ] }
     } enable-intrinsics ;
 
 : enable-float-functions ( -- )
@@ -143,13 +146,13 @@ IN: compiler.cfg.intrinsics
 
 : enable-min/max ( -- )
     {
-        { math.integers.private:fixnum-min [ drop [ ^^min ] emit-fixnum-op ] }
+        { math.integers.private:fixnum-min [ drop [ ^^min ] binary-op ] }
-        { math.integers.private:fixnum-max [ drop [ ^^max ] emit-fixnum-op ] }
+        { math.integers.private:fixnum-max [ drop [ ^^max ] binary-op ] }
     } enable-intrinsics ;
 
-: enable-fixnum-log2 ( -- )
+: enable-log2 ( -- )
     {
-        { math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
+        { math.integers.private:fixnum-log2 [ drop [ ^^log2 ] unary-op ] }
     } enable-intrinsics ;
 
 : emit-intrinsic ( node word -- )

basis/compiler/cfg/intrinsics/misc/misc.factor

@@ -1,15 +1,24 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces layouts sequences kernel math accessors
+USING: accessors classes.algebra layouts kernel math namespaces
-compiler.tree.propagation.info compiler.cfg.stacks
+sequences cpu.architecture
-compiler.cfg.hats compiler.cfg.instructions
+compiler.tree.propagation.info
+compiler.cfg.stacks
+compiler.cfg.hats
+compiler.cfg.comparisons
+compiler.cfg.instructions
 compiler.cfg.builder.blocks
 compiler.cfg.utilities ;
 FROM: vm => context-field-offset vm-field-offset ;
+QUALIFIED-WITH: alien.c-types c
 IN: compiler.cfg.intrinsics.misc
 
 : emit-tag ( -- )
-    ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
+    [ ^^tagged>integer tag-mask get ^^and-imm ] unary-op ;
+
+: emit-eq ( node -- )
+    node-input-infos first2 [ class>> fixnum class<= ] both?
+    [ [ cc= ^^compare-integer ] binary-op ] [ [ cc= ^^compare ] binary-op ] if ;
 
 : special-object-offset ( n -- offset )
     cells "special-objects" vm-field-offset + ;
@@ -37,7 +46,9 @@ IN: compiler.cfg.intrinsics.misc
     ] [ emit-primitive ] ?if ;
 
 : emit-identity-hashcode ( -- )
-    ds-pop tag-mask get bitnot ^^load-immediate ^^and 0 0 ^^slot-imm
+    [
+        ^^tagged>integer
+        tag-mask get bitnot ^^load-integer ^^and
+        0 int-rep f ^^load-memory-imm
         hashcode-shift ^^shr-imm
-    ^^tag-fixnum
+    ] unary-op ;
-    ds-push ;

basis/compiler/cfg/intrinsics/simd/backend/backend.factor

@@ -19,7 +19,7 @@ M: ##zero-vector insn-available? rep>> %zero-vector-reps member? ;
 M: ##fill-vector insn-available? rep>> %fill-vector-reps member? ;
 M: ##gather-vector-2 insn-available? rep>> %gather-vector-2-reps member? ;
 M: ##gather-vector-4 insn-available? rep>> %gather-vector-4-reps member? ;
-M: ##alien-vector insn-available? rep>> %alien-vector-reps member? ;
+M: ##store-memory-imm insn-available? rep>> %alien-vector-reps member? ;
 M: ##shuffle-vector insn-available? rep>> %shuffle-vector-reps member? ;
 M: ##shuffle-vector-imm insn-available? rep>> %shuffle-vector-imm-reps member? ;
 M: ##merge-vector-head insn-available? rep>> %merge-vector-reps member? ;

basis/compiler/cfg/intrinsics/simd/simd-tests.factor

@@ -127,7 +127,7 @@ unit-test
 unit-test
 
 ! vneg
-[ { ##load-constant ##sub-vector } ]
+[ { ##load-reference ##sub-vector } ]
 [ simple-ops-cpu float-4-rep [ emit-simd-vneg ] test-emit ]
 unit-test
 
@@ -153,11 +153,11 @@ M: addsub-cpu %add-sub-vector-reps { int-4-rep float-4-rep } ;
 [ addsub-cpu float-4-rep [ emit-simd-v+- ] test-emit ]
 unit-test
 
-[ { ##load-constant ##xor-vector ##add-vector } ]
+[ { ##load-reference ##xor-vector ##add-vector } ]
 [ simple-ops-cpu float-4-rep [ emit-simd-v+- ] test-emit ]
 unit-test
 
-[ { ##load-constant ##xor-vector ##sub-vector ##add-vector } ]
+[ { ##load-reference ##xor-vector ##sub-vector ##add-vector } ]
 [ simple-ops-cpu int-4-rep [ emit-simd-v+- ] test-emit ]
 unit-test
 
@@ -301,7 +301,7 @@ unit-test
 [ abs-cpu float-4-rep [ emit-simd-vabs ] test-emit ]
 unit-test
 
-[ { ##load-constant ##andn-vector } ]
+[ { ##load-reference ##andn-vector } ]
 [ simple-ops-cpu float-4-rep [ emit-simd-vabs ] test-emit ]
 unit-test
 
@@ -388,7 +388,7 @@ TUPLE: shuffle-cpu < simple-ops-cpu ;
 M: shuffle-cpu %shuffle-vector-reps signed-reps ;
 
 ! vshuffle-elements
-[ { ##load-constant ##shuffle-vector } ]
+[ { ##load-reference ##shuffle-vector } ]
 [ shuffle-cpu { 0 1 2 3 } int-4-rep [ emit-simd-vshuffle-elements ] test-emit-literal ]
 unit-test
 
@@ -420,7 +420,7 @@ unit-test
 [ minmax-cpu int-4-rep [ emit-simd-v<= ] test-emit ]
 unit-test
 
-[ { ##load-constant ##xor-vector ##xor-vector ##compare-vector } ]
+[ { ##load-reference ##xor-vector ##xor-vector ##compare-vector } ]
 [ compare-cpu uint-4-rep [ emit-simd-v<= ] test-emit ]
 unit-test
 

basis/compiler/cfg/intrinsics/simd/simd.factor

@@ -43,24 +43,24 @@ IN: compiler.cfg.intrinsics.simd
 
 : ^load-neg-zero-vector ( rep -- dst )
     {
-        { float-4-rep [ float-array{ -0.0 -0.0 -0.0 -0.0 } underlying>> ^^load-constant ] }
+        { float-4-rep [ float-array{ -0.0 -0.0 -0.0 -0.0 } underlying>> ^^load-literal ] }
-        { double-2-rep [ double-array{ -0.0 -0.0 } underlying>> ^^load-constant ] }
+        { double-2-rep [ double-array{ -0.0 -0.0 } underlying>> ^^load-literal ] }
     } case ;
 
 : ^load-add-sub-vector ( rep -- dst )
     signed-rep {
-        { float-4-rep    [ float-array{ -0.0  0.0 -0.0  0.0 } underlying>> ^^load-constant ] }
+        { float-4-rep    [ float-array{ -0.0  0.0 -0.0  0.0 } underlying>> ^^load-literal ] }
-        { double-2-rep   [ double-array{ -0.0  0.0 } underlying>> ^^load-constant ] }
+        { double-2-rep   [ double-array{ -0.0  0.0 } underlying>> ^^load-literal ] }
-        { char-16-rep    [ char-array{ -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 } underlying>> ^^load-constant ] }
+        { char-16-rep    [ char-array{ -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 } underlying>> ^^load-literal ] }
-        { short-8-rep    [ short-array{ -1 0 -1 0 -1 0 -1 0 } underlying>> ^^load-constant ] }
+        { short-8-rep    [ short-array{ -1 0 -1 0 -1 0 -1 0 } underlying>> ^^load-literal ] }
-        { int-4-rep      [ int-array{ -1 0 -1 0 } underlying>> ^^load-constant ] }
+        { int-4-rep      [ int-array{ -1 0 -1 0 } underlying>> ^^load-literal ] }
-        { longlong-2-rep [ longlong-array{ -1 0 } underlying>> ^^load-constant ] }
+        { longlong-2-rep [ longlong-array{ -1 0 } underlying>> ^^load-literal ] }
     } case ;
 
 : ^load-half-vector ( rep -- dst )
     {
-        { float-4-rep  [ float-array{  0.5 0.5 0.5 0.5 } underlying>> ^^load-constant ] }
+        { float-4-rep  [ float-array{  0.5 0.5 0.5 0.5 } underlying>> ^^load-literal ] }
-        { double-2-rep [ double-array{ 0.5 0.5 }         underlying>> ^^load-constant ] }
+        { double-2-rep [ double-array{ 0.5 0.5 }         underlying>> ^^load-literal ] }
     } case ;
 
 : >variable-shuffle ( shuffle rep -- shuffle' )
@@ -70,7 +70,7 @@ IN: compiler.cfg.intrinsics.simd
     '[ _ n*v _ v+ ] map concat ;
 
 : ^load-immediate-shuffle ( shuffle rep -- dst )
-    >variable-shuffle ^^load-constant ;
+    >variable-shuffle ^^load-literal ;
 
 :: ^blend-vector ( mask true false rep -- dst )
     true mask rep ^^and-vector
@@ -118,7 +118,7 @@ IN: compiler.cfg.intrinsics.simd
         [ ^(compare-vector) ]
         [ ^minmax-compare-vector ]
         { unsigned-int-vector-rep [| src1 src2 rep cc |
-            rep sign-bit-mask ^^load-constant :> sign-bits
+            rep sign-bit-mask ^^load-literal :> sign-bits
             src1 sign-bits rep ^^xor-vector
             src2 sign-bits rep ^^xor-vector
             rep signed-rep cc ^(compare-vector)
@@ -587,20 +587,20 @@ PREDICATE: fixnum-vector-rep < int-vector-rep
 : emit-alien-vector ( node -- )
     dup [
         '[
-            ds-drop prepare-alien-getter
+            ds-drop prepare-load-memory
-            _ ^^alien-vector ds-push
+            _ f ^^load-memory-imm ds-push
         ]
-        [ inline-alien-getter? ] inline-alien
+        [ inline-load-memory? ] inline-accessor
     ] with { [ %alien-vector-reps member? ] } if-literals-match ;
 
 : emit-set-alien-vector ( node -- )
     dup [
         '[
-            ds-drop prepare-alien-setter ds-pop
+            ds-drop prepare-store-memory
-            _ ##set-alien-vector
+            _ f ##store-memory-imm
         ]
-        [ byte-array inline-alien-setter? ]
+        [ byte-array inline-store-memory? ]
-        inline-alien
+        inline-accessor
     ] with { [ %alien-vector-reps member? ] } if-literals-match ;
 
 : enable-simd ( -- )

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

@@ -1,9 +1,10 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: layouts namespaces kernel accessors sequences math
 classes.algebra classes.builtin locals combinators
-cpu.architecture compiler.tree.propagation.info
+combinators.short-circuit cpu.architecture
-compiler.cfg.stacks compiler.cfg.hats compiler.cfg.registers
+compiler.tree.propagation.info compiler.cfg.stacks
+compiler.cfg.hats compiler.cfg.registers
 compiler.cfg.instructions compiler.cfg.utilities
 compiler.cfg.builder.blocks compiler.constants ;
 IN: compiler.cfg.intrinsics.slots
@@ -13,12 +14,13 @@ IN: compiler.cfg.intrinsics.slots
 
 : value-tag ( info -- n ) class>> class-tag ;
 
-: ^^tag-offset>slot ( slot tag -- vreg' )
+: slot-indexing ( slot tag -- slot scale tag )
-    [ ^^offset>slot ] dip ^^sub-imm ;
+    complex-addressing?
+    [ [ cell log2 ] dip ] [ [ ^^offset>slot ] dip ^^sub-imm 0 0 ] if ;
 
 : (emit-slot) ( infos -- dst )
     [ 2inputs ] [ first value-tag ] bi*
-    ^^tag-offset>slot ^^slot ;
+    slot-indexing ^^slot ;
 
 : (emit-slot-imm) ( infos -- dst )
     ds-drop
@@ -28,9 +30,9 @@ IN: compiler.cfg.intrinsics.slots
 
 : immediate-slot-offset? ( value-info -- ? )
     literal>> {
-        { [ dup fixnum? ] [ tag-fixnum immediate-arithmetic? ] }
+        [ fixnum? ]
-        [ drop f ]
+        [ cell * immediate-arithmetic? ]
-    } cond ;
+    } 1&& ;
 
 : emit-slot ( node -- )
     dup node-input-infos
@@ -47,12 +49,13 @@ IN: compiler.cfg.intrinsics.slots
 :: (emit-set-slot) ( infos -- )
     3inputs :> ( src obj slot )
 
-    slot infos second value-tag ^^tag-offset>slot :> slot
+    infos second value-tag :> tag
 
-    src obj slot ##set-slot
+    slot tag slot-indexing :> ( slot scale tag )
+    src obj slot scale tag ##set-slot
 
     infos emit-write-barrier?
-    [ obj slot next-vreg next-vreg ##write-barrier ] when ;
+    [ obj slot scale tag next-vreg next-vreg ##write-barrier ] when ;
 
 :: (emit-set-slot-imm) ( infos -- )
     ds-drop
@@ -65,7 +68,7 @@ IN: compiler.cfg.intrinsics.slots
     src obj slot tag ##set-slot-imm
 
     infos emit-write-barrier?
-    [ obj slot tag slot-offset next-vreg next-vreg ##write-barrier-imm ] when ;
+    [ obj slot tag next-vreg next-vreg ##write-barrier-imm ] when ;
 
 : emit-set-slot ( node -- )
     dup node-input-infos
@@ -74,10 +77,3 @@ IN: compiler.cfg.intrinsics.slots
         dup third immediate-slot-offset?
         [ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
     ] [ drop emit-primitive ] if ;
-
-: emit-string-nth ( -- )
-    2inputs swap ^^untag-fixnum ^^string-nth ^^tag-fixnum ds-push ;
-
-: emit-set-string-nth-fast ( -- )
-    3inputs [ ^^untag-fixnum ] [ ^^untag-fixnum ] [ ] tri*
-    swap next-vreg ##set-string-nth-fast ;

basis/compiler/cfg/intrinsics/strings/authors.txt

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

basis/compiler/cfg/intrinsics/strings/strings.factor

@@ -0,0 +1,15 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types kernel compiler.constants compiler.cfg.hats
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.stacks cpu.architecture ;
+IN: compiler.cfg.intrinsics.strings
+
+: (string-nth) ( n string -- base offset rep c-type )
+    ^^tagged>integer swap ^^add string-offset int-rep uchar ; inline
+
+: emit-string-nth-fast ( -- )
+    2inputs (string-nth) ^^load-memory-imm ds-push ;
+
+: emit-set-string-nth-fast ( -- )
+    3inputs (string-nth) ##store-memory-imm ;

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

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs heaps kernel namespaces sequences fry math
 math.order combinators arrays sorting compiler.utilities locals
@@ -9,11 +9,11 @@ compiler.cfg.linear-scan.allocation.state ;
 IN: compiler.cfg.linear-scan.allocation
 
 : active-positions ( new assoc -- )
-    [ vreg>> active-intervals-for ] dip
+    [ active-intervals-for ] dip
     '[ [ 0 ] dip reg>> _ add-use-position ] each ;
 
 : inactive-positions ( new assoc -- )
-    [ [ vreg>> inactive-intervals-for ] keep ] dip
+    [ [ inactive-intervals-for ] keep ] dip
     '[
         [ _ relevant-ranges intersect-live-ranges 1/0. or ] [ reg>> ] bi
         _ add-use-position
@@ -38,7 +38,8 @@ IN: compiler.cfg.linear-scan.allocation
     ! If the live interval has a usage at 'n', don't spill it,
     ! since this means its being defined by the sync point
     ! instruction. Output t if this is the case.
-    2dup [ uses>> ] dip swap member? [ 2drop t ] [ spill f ] if ;
+    2dup [ uses>> ] dip '[ n>> _ = ] any?
+    [ 2drop t ] [ spill f ] if ;
 
 : handle-sync-point ( n -- )
     [ active-intervals get values ] dip
@@ -62,18 +63,19 @@ M: sync-point handle ( sync-point -- )
 
 : smallest-heap ( heap1 heap2 -- heap )
     ! If heap1 and heap2 have the same key, favors heap1.
-    [ [ heap-peek nip ] bi@ <= ] most ;
+    {
+        { [ dup heap-empty? ] [ drop ] }
+        { [ over heap-empty? ] [ nip ] }
+        [ [ [ heap-peek nip ] bi@ <= ] most ]
+    } cond ;
 
 : (allocate-registers) ( -- )
-    {
-        { [ unhandled-intervals get heap-empty? ] [ unhandled-sync-points get ] }
-        { [ unhandled-sync-points get heap-empty? ] [ unhandled-intervals get ] }
     ! If a live interval begins at the same location as a sync point,
     ! process the sync point before the live interval. This ensures that the
     ! return value of C function calls doesn't get spilled and reloaded
     ! unnecessarily.
-        [ unhandled-sync-points get unhandled-intervals get smallest-heap ]
+    unhandled-sync-points get unhandled-intervals get smallest-heap
-    } cond dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ;
+    dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ;
 
 : finish-allocation ( -- )
     active-intervals inactive-intervals

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

@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators fry hints kernel locals
 math sequences sets sorting splitting namespaces linked-assocs
@@ -17,19 +17,20 @@ ERROR: bad-live-ranges interval ;
     ] [ drop ] if ;
 
 : trim-before-ranges ( live-interval -- )
-    [ ranges>> ] [ uses>> last 1 + ] bi
+    [ ranges>> ] [ last-use n>> 1 + ] bi
     [ '[ from>> _ <= ] filter! drop ]
     [ swap last (>>to) ]
     2bi ;
 
 : trim-after-ranges ( live-interval -- )
-    [ ranges>> ] [ uses>> first ] bi
+    [ ranges>> ] [ first-use n>> ] bi
     [ '[ to>> _ >= ] filter! drop ]
     [ swap first (>>from) ]
     2bi ;
 
 : assign-spill ( live-interval -- )
-    dup vreg>> vreg-spill-slot >>spill-to drop ;
+    dup [ vreg>> ] [ last-use rep>> ] bi
+    assign-spill-slot >>spill-to drop ;
 
 : spill-before ( before -- before/f )
     ! If the interval does not have any usages before the spill location,
@@ -46,7 +47,8 @@ ERROR: bad-live-ranges interval ;
     ] if ;
 
 : assign-reload ( live-interval -- )
-    dup vreg>> vreg-spill-slot >>reload-from drop ;
+    dup [ vreg>> ] [ first-use rep>> ] bi
+    assign-spill-slot >>reload-from drop ;
 
 : spill-after ( after -- after/f )
     ! If the interval has no more usages after the spill location,
@@ -66,18 +68,19 @@ ERROR: bad-live-ranges interval ;
     split-interval [ spill-before ] [ spill-after ] bi* ;
 
 : find-use-position ( live-interval new -- n )
-    [ uses>> ] [ start>> '[ _ >= ] ] bi* find nip 1/0. or ;
+    [ uses>> ] [ start>> '[ n>> _ >= ] ] bi* find nip
+    [ n>> ] [ 1/0. ] if* ;
 
 : find-use-positions ( live-intervals new assoc -- )
     '[ [ _ find-use-position ] [ reg>> ] bi _ add-use-position ] each ;
 
 : active-positions ( new assoc -- )
-    [ [ vreg>> active-intervals-for ] keep ] dip
+    [ [ active-intervals-for ] keep ] dip
     find-use-positions ;
 
 : inactive-positions ( new assoc -- )
     [
-        [ vreg>> inactive-intervals-for ] keep
+        [ inactive-intervals-for ] keep
         [ '[ _ intervals-intersect? ] filter ] keep
     ] dip
     find-use-positions ;
@@ -88,7 +91,7 @@ ERROR: bad-live-ranges interval ;
     >alist alist-max ;
 
 : spill-new? ( new pair -- ? )
-    [ uses>> first ] [ second ] bi* > ;
+    [ first-use n>> ] [ second ] bi* > ;
 
 : spill-new ( new pair -- )
     drop spill-after add-unhandled ;
@@ -102,13 +105,13 @@ ERROR: bad-live-ranges interval ;
     ! If there is an active interval using 'reg' (there should be at
     ! most one) are split and spilled and removed from the inactive
     ! set.
-    new vreg>> active-intervals-for [ [ reg>> reg = ] find swap dup ] keep
+    new active-intervals-for [ [ reg>> reg = ] find swap dup ] keep
     '[ _ remove-nth! drop  new start>> spill ] [ 2drop ] if ;
 
 :: spill-intersecting-inactive ( new reg -- )
     ! Any inactive intervals using 'reg' are split and spilled
     ! and removed from the inactive set.
-    new vreg>> inactive-intervals-for [
+    new inactive-intervals-for [
         dup reg>> reg = [
             dup new intervals-intersect? [
                 new start>> spill f

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

@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators fry hints kernel locals
 math sequences sets sorting splitting namespaces
@@ -25,7 +25,7 @@ IN: compiler.cfg.linear-scan.allocation.splitting
     ] bi ;
 
 : split-uses ( uses n -- before after )
-    '[ _ <= ] partition ;
+    '[ n>> _ <= ] partition ;
 
 ERROR: splitting-too-early ;
 

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

@@ -1,9 +1,10 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators cpu.architecture fry heaps
+USING: arrays accessors assocs combinators cpu.architecture fry
-kernel math math.order namespaces sequences vectors
+heaps kernel math math.order namespaces sequences vectors
 linked-assocs compiler.cfg compiler.cfg.registers
-compiler.cfg.instructions compiler.cfg.linear-scan.live-intervals ;
+compiler.cfg.instructions
+compiler.cfg.linear-scan.live-intervals ;
 IN: compiler.cfg.linear-scan.allocation.state
 
 ! Start index of current live interval. We ensure that all
@@ -26,14 +27,14 @@ SYMBOL: registers
 ! Vector of active live intervals
 SYMBOL: active-intervals
 
-: active-intervals-for ( vreg -- seq )
+: active-intervals-for ( live-interval -- seq )
-    rep-of reg-class-of active-intervals get at ;
+    reg-class>> active-intervals get at ;
 
 : add-active ( live-interval -- )
-    dup vreg>> active-intervals-for push ;
+    dup active-intervals-for push ;
 
 : delete-active ( live-interval -- )
-    dup vreg>> active-intervals-for remove-eq! drop ;
+    dup active-intervals-for remove-eq! drop ;
 
 : assign-free-register ( new registers -- )
     pop >>reg add-active ;
@@ -41,14 +42,14 @@ SYMBOL: active-intervals
 ! Vector of inactive live intervals
 SYMBOL: inactive-intervals
 
-: inactive-intervals-for ( vreg -- seq )
+: inactive-intervals-for ( live-interval -- seq )
-    rep-of reg-class-of inactive-intervals get at ;
+    reg-class>> inactive-intervals get at ;
 
 : add-inactive ( live-interval -- )
-    dup vreg>> inactive-intervals-for push ;
+    dup inactive-intervals-for push ;
 
 : delete-inactive ( live-interval -- )
-    dup vreg>> inactive-intervals-for remove-eq! drop ;
+    dup inactive-intervals-for remove-eq! drop ;
 
 ! Vector of handled live intervals
 SYMBOL: handled-intervals
@@ -67,7 +68,7 @@ ERROR: register-already-used live-interval ;
 
 : check-activate ( live-interval -- )
     check-allocation? get [
-        dup [ reg>> ] [ vreg>> active-intervals-for [ reg>> ] map ] bi member?
+        dup [ reg>> ] [ active-intervals-for [ reg>> ] map ] bi member?
         [ register-already-used ] [ drop ] if
     ] [ drop ] if ;
 
@@ -116,8 +117,8 @@ SYMBOL: unhandled-intervals
 : reg-class-assoc ( quot -- assoc )
     [ reg-classes ] dip { } map>assoc ; inline
 
-: next-spill-slot ( rep -- n )
+: next-spill-slot ( size -- n )
-    rep-size cfg get
+    cfg get
     [ swap [ align dup ] [ + ] bi ] change-spill-area-size drop
     <spill-slot> ;
 
@@ -127,8 +128,11 @@ SYMBOL: unhandled-sync-points
 ! Mapping from vregs to spill slots
 SYMBOL: spill-slots
 
-: vreg-spill-slot ( vreg -- spill-slot )
+: assign-spill-slot ( coalesced-vreg rep -- spill-slot )
-    spill-slots get [ rep-of next-spill-slot ] cache ;
+    rep-size spill-slots get [ nip next-spill-slot ] 2cache ;
+
+: lookup-spill-slot ( coalesced-vreg rep -- spill-slot )
+    rep-size 2array spill-slots get ?at [ ] [ bad-vreg ] if ;
 
 : init-allocator ( registers -- )
     registers set
@@ -148,7 +152,7 @@ SYMBOL: spill-slots
 
 ! A utility used by register-status and spill-status words
 : free-positions ( new -- assoc )
-    vreg>> rep-of reg-class-of registers get at
+    reg-class>> registers get at
     [ 1/0. ] H{ } <linked-assoc> map>assoc ;
 
 : add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ;

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

@@ -1,15 +1,17 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel math assocs namespaces sequences heaps
-fry make combinators sets locals arrays
+fry make combinators combinators.short-circuit sets locals arrays
 cpu.architecture layouts
 compiler.cfg
 compiler.cfg.def-use
 compiler.cfg.liveness
+compiler.cfg.liveness.ssa
 compiler.cfg.registers
 compiler.cfg.instructions
+compiler.cfg.linearization
+compiler.cfg.ssa.destruction
 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 ;
@@ -29,21 +31,16 @@ SYMBOL: pending-interval-assoc
 : remove-pending ( live-interval -- )
     vreg>> pending-interval-assoc get delete-at ;
 
-ERROR: bad-vreg vreg ;
+:: vreg>reg ( vreg -- reg )
-
-: (vreg>reg) ( vreg pending -- reg )
     ! If a live vreg is not in the pending set, then it must
     ! have been spilled.
-    ?at [ spill-slots get ?at [ ] [ bad-vreg ] if ] unless ;
+    vreg leader :> leader
-
+    leader pending-interval-assoc get at* [
-: vreg>reg ( vreg -- reg )
+        drop leader vreg rep-of lookup-spill-slot
-    pending-interval-assoc get (vreg>reg) ;
+    ] unless ;
 
 : vregs>regs ( vregs -- assoc )
-    dup assoc-empty? [
+    [ f ] [ [ dup vreg>reg ] H{ } map>assoc ] if-empty ;
-        pending-interval-assoc get
-        '[ _ (vreg>reg) ] assoc-map
-    ] unless ;
 
 ! Minheap of live intervals which still need a register allocation
 SYMBOL: unhandled-intervals
@@ -54,22 +51,49 @@ SYMBOL: unhandled-intervals
 : init-unhandled ( live-intervals -- )
     [ add-unhandled ] each ;
 
+! Liveness info is used by resolve pass
+
 ! Mapping from basic blocks to values which are live at the start
-SYMBOL: register-live-ins
+! on all incoming CFG edges
+SYMBOL: machine-live-ins
+
+: machine-live-in ( bb -- assoc )
+    machine-live-ins get at ;
+
+: compute-live-in ( bb -- )
+    [ live-in keys vregs>regs ] keep machine-live-ins get set-at ;
+
+! Mapping from basic blocks to predecessors to values which are
+! live on a particular incoming edge
+SYMBOL: machine-edge-live-ins
+
+: machine-edge-live-in ( predecessor bb -- assoc )
+    machine-edge-live-ins get at at ;
+
+: compute-edge-live-in ( bb -- )
+    [ edge-live-ins get at [ keys vregs>regs ] assoc-map ] keep
+    machine-edge-live-ins get set-at ;
 
 ! Mapping from basic blocks to values which are live at the end
-SYMBOL: register-live-outs
+SYMBOL: machine-live-outs
+
+: machine-live-out ( bb -- assoc )
+    machine-live-outs get at ;
+
+: compute-live-out ( bb -- )
+    [ live-out keys vregs>regs ] keep machine-live-outs get set-at ;
 
 : init-assignment ( live-intervals -- )
     <min-heap> pending-interval-heap set
     H{ } clone pending-interval-assoc set
     <min-heap> unhandled-intervals set
-    H{ } clone register-live-ins set
+    H{ } clone machine-live-ins set
-    H{ } clone register-live-outs set
+    H{ } clone machine-edge-live-ins set
+    H{ } clone machine-live-outs set
     init-unhandled ;
 
 : insert-spill ( live-interval -- )
-    [ reg>> ] [ vreg>> rep-of ] [ spill-to>> ] tri _spill ;
+    [ reg>> ] [ last-use rep>> ] [ spill-to>> ] tri ##spill ;
 
 : handle-spill ( live-interval -- )
     dup spill-to>> [ insert-spill ] [ drop ] if ;
@@ -89,10 +113,18 @@ SYMBOL: register-live-outs
     pending-interval-heap get (expire-old-intervals) ;
 
 : insert-reload ( live-interval -- )
-    [ reg>> ] [ vreg>> rep-of ] [ reload-from>> ] tri _reload ;
+    [ reg>> ] [ first-use rep>> ] [ reload-from>> ] tri ##reload ;
+
+: insert-reload? ( live-interval -- ? )
+    ! Don't insert a reload if the register will be written to
+    ! before being read again.
+    {
+        [ reload-from>> ]
+        [ first-use type>> +use+ eq? ]
+    } 1&& ;
 
 : handle-reload ( live-interval -- )
-    dup reload-from>> [ insert-reload ] [ drop ] if ;
+    dup insert-reload? [ insert-reload ] [ drop ] if ;
 
 : activate-interval ( live-interval -- )
     [ add-pending ] [ handle-reload ] bi ;
@@ -118,55 +150,19 @@ 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 ;
 
-: trace-on-gc ( assoc -- assoc' )
+M: ##call-gc assign-registers-in-insn
-    ! 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 [ rep-of ] [ vreg-spill-slot ] bi 3array , ] [ 2drop ] if
-        ] assoc-each
-    ] { } make ;
-
-: gc-root-offsets ( registers -- alist )
-    ! Outputs a sequence of { offset register/spill-slot } pairs
-    [ length iota [ cell * ] map ] keep zip ;
-
-M: ##gc assign-registers-in-insn
-    ! Since ##gc is always the first instruction in a block, the set of
-    ! values live at the ##gc is just live-in.
     dup call-next-method
-    basic-block get register-live-ins get at
+    [ [ vreg>reg ] map ] change-gc-roots drop ;
-    [ trace-on-gc gc-root-offsets >>tagged-values ] [ spill-on-gc >>data-values ] bi
-    drop ;
 
 M: insn assign-registers-in-insn drop ;
 
 : begin-block ( bb -- )
-    dup basic-block set
+    {
-    dup block-from activate-new-intervals
+        [ basic-block set ]
-    [ live-in vregs>regs ] keep register-live-ins get set-at ;
+        [ block-from activate-new-intervals ]
-
+        [ compute-edge-live-in ]
-: end-block ( bb -- )
+        [ compute-live-in ]
-    [ live-out vregs>regs ] keep register-live-outs get set-at ;
+    } cleave ;
-
-: vreg-at-start ( vreg bb -- state )
-    register-live-ins get at ?at [ bad-vreg ] unless ;
-
-: vreg-at-end ( vreg bb -- state )
-    register-live-outs get at ?at [ bad-vreg ] unless ;
 
 :: assign-registers-in-block ( bb -- )
     bb [
@@ -180,7 +176,7 @@ M: insn assign-registers-in-insn drop ;
                     [ , ]
                 } cleave
             ] each
-            bb end-block
+            bb compute-live-out
         ] V{ } make
     ] change-instructions drop ;
 

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

@@ -1,10 +1,9 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors namespaces make locals
 cpu.architecture
 compiler.cfg
 compiler.cfg.rpo
-compiler.cfg.liveness
 compiler.cfg.registers
 compiler.cfg.instructions
 compiler.cfg.linear-scan.numbering
@@ -29,8 +28,9 @@ IN: compiler.cfg.linear-scan
 ! by Omri Traub, Glenn Holloway, Michael D. Smith
 ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
 
+! SSA liveness must have been computed already
+
 :: (linear-scan) ( cfg machine-registers -- )
-    cfg compute-live-sets
     cfg number-instructions
     cfg compute-live-intervals machine-registers allocate-registers
     cfg assign-registers

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

@@ -1,19 +1,36 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces kernel assocs accessors sequences math math.order fry
+USING: namespaces kernel assocs accessors locals sequences math
-combinators binary-search compiler.cfg.instructions compiler.cfg.registers
+math.order fry combinators binary-search
-compiler.cfg.def-use compiler.cfg.liveness compiler.cfg.linearization.order
+compiler.cfg.instructions
-compiler.cfg ;
+compiler.cfg.registers
+compiler.cfg.def-use
+compiler.cfg.liveness
+compiler.cfg.linearization
+compiler.cfg.ssa.destruction
+compiler.cfg
+cpu.architecture ;
 IN: compiler.cfg.linear-scan.live-intervals
 
 TUPLE: live-range from to ;
 
 C: <live-range> live-range
 
+SYMBOLS: +def+ +use+ +memory+ ;
+
+TUPLE: vreg-use rep n type ;
+
+C: <vreg-use> vreg-use
+
 TUPLE: live-interval
 vreg
 reg spill-to reload-from
-start end ranges uses ;
+start end ranges uses
+reg-class ;
+
+: first-use ( live-interval -- use ) uses>> first ; inline
+
+: last-use ( live-interval -- use ) uses>> last ; inline
 
 GENERIC: covers? ( insn# obj -- ? )
 
@@ -50,63 +67,76 @@ M: live-interval covers? ( insn# live-interval -- ? )
     2dup extend-range?
     [ extend-range ] [ add-new-range ] if ;
 
-GENERIC: operands-in-registers? ( insn -- ? )
+:: add-use ( rep n type live-interval -- )
+    type +memory+ eq? [
+        rep n type <vreg-use>
+        live-interval uses>> push
+    ] unless ;
 
-M: vreg-insn operands-in-registers? drop t ;
+: <live-interval> ( vreg reg-class -- live-interval )
-
-M: partial-sync-insn operands-in-registers? drop f ;
-
-: add-def ( insn live-interval -- )
-    [ insn#>> ] [ uses>> ] bi* push ;
-
-: add-use ( insn live-interval -- )
-    ! Every use is a potential def, no SSA here baby!
-    over operands-in-registers? [ add-def ] [ 2drop ] if ;
-
-: <live-interval> ( vreg -- live-interval )
     \ live-interval new
         V{ } clone >>uses
         V{ } clone >>ranges
+        swap >>reg-class
         swap >>vreg ;
 
 : block-from ( bb -- n ) instructions>> first insn#>> 1 - ;
 
 : block-to ( bb -- n ) instructions>> last insn#>> ;
 
-M: live-interval hashcode*
+SYMBOLS: from to ;
-    nip [ start>> ] [ end>> 1000 * ] bi + ;
 
 ! Mapping from vreg to live-interval
 SYMBOL: live-intervals
 
 : live-interval ( vreg -- live-interval )
-    live-intervals get [ <live-interval> ] cache ;
+    leader live-intervals get
+    [ dup rep-of reg-class-of <live-interval> ] cache ;
 
 GENERIC: compute-live-intervals* ( insn -- )
 
 M: insn compute-live-intervals* drop ;
 
-: handle-output ( insn vreg -- )
+:: record-def ( vreg n type -- )
-    live-interval
+    vreg rep-of :> rep
-    [ [ insn#>> ] dip shorten-range ] [ add-def ] 2bi ;
+    vreg live-interval :> live-interval
 
-: handle-input ( insn vreg -- )
+    n live-interval shorten-range
-    live-interval
+    rep n type live-interval add-use ;
-    [ [ [ basic-block get block-from ] dip insn#>> ] dip add-range ] [ add-use ] 2bi ;
 
-: handle-temp ( insn vreg -- )
+:: record-use ( vreg n type -- )
-    live-interval
+    vreg rep-of :> rep
-    [ [ insn#>> dup ] dip add-range ] [ add-use ] 2bi ;
+    vreg live-interval :> live-interval
 
-M: vreg-insn compute-live-intervals*
+    from get n live-interval add-range
-    [ dup defs-vreg [ handle-output ] with when* ]
+    rep n type live-interval add-use ;
-    [ dup uses-vregs [ handle-input ] with each ]
+
-    [ dup temp-vregs [ handle-temp ] with each ]
+:: record-temp ( vreg n -- )
-    tri ;
+    vreg rep-of :> rep
+    vreg live-interval :> live-interval
+
+    n n live-interval add-range
+    rep n +def+ live-interval add-use ;
+
+M:: vreg-insn compute-live-intervals* ( insn -- )
+    insn insn#>> :> n
+
+    insn defs-vreg [ n +def+ record-def ] when*
+    insn uses-vregs [ n +use+ record-use ] each
+    insn temp-vregs [ n record-temp ] each ;
+
+M:: clobber-insn compute-live-intervals* ( insn -- )
+    insn insn#>> :> n
+
+    insn defs-vreg [ n +use+ record-def ] when*
+    insn uses-vregs [ n +memory+ record-use ] each
+    insn temp-vregs [ n record-temp ] each ;
 
 : handle-live-out ( bb -- )
-    [ block-from ] [ block-to ] [ live-out keys ] tri
+    live-out dup assoc-empty? [ drop ] [
-    [ live-interval add-range ] with with each ;
+        [ from get to get ] dip keys
+        [ live-interval add-range ] with with each
+    ] if ;
 
 ! A location where all registers have to be spilled
 TUPLE: sync-point n ;
@@ -118,13 +148,15 @@ SYMBOL: sync-points
 
 GENERIC: compute-sync-points* ( insn -- )
 
-M: partial-sync-insn compute-sync-points*
+M: clobber-insn compute-sync-points*
     insn#>> <sync-point> sync-points get push ;
 
 M: insn compute-sync-points* drop ;
 
 : compute-live-intervals-step ( bb -- )
-    [ basic-block set ]
+    {
+        [ block-from from set ]
+        [ block-to to set ]
         [ handle-live-out ]
         [
             instructions>> <reversed> [
@@ -132,7 +164,8 @@ M: insn compute-sync-points* drop ;
                 [ compute-sync-points* ]
                 bi
             ] each
-    ] tri ;
+        ]
+    } cleave ;
 
 : init-live-intervals ( -- )
     H{ } clone live-intervals set

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

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors math sequences grouping namespaces
-compiler.cfg.linearization.order ;
+compiler.cfg.linearization ;
 IN: compiler.cfg.linear-scan.numbering
 
 ERROR: already-numbered insn ;

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

@@ -7,7 +7,10 @@ IN: compiler.cfg.linear-scan.resolve.tests
 
 [
     {
-        { { T{ spill-slot f 0 } int-rep } { 1 int-rep } }
+        {
+            T{ location f T{ spill-slot f 0 } int-rep int-regs }
+            T{ location f 1 int-rep int-regs }
+        }
     }
 ] [
     [
@@ -17,21 +20,25 @@ IN: compiler.cfg.linear-scan.resolve.tests
 
 [
     {
-        T{ _reload { dst 1 } { rep int-rep } { src T{ spill-slot f 0 } } }
+        T{ ##reload { dst 1 } { rep int-rep } { src T{ spill-slot f 0 } } }
     }
 ] [
     [
-        { T{ spill-slot f 0 } int-rep } { 1 int-rep } >insn
+        T{ location f T{ spill-slot f 0 } int-rep int-regs }
+        T{ location f 1 int-rep int-regs }
+        >insn
     ] { } make
 ] unit-test
 
 [
     {
-        T{ _spill { src 1 } { rep int-rep } { dst T{ spill-slot f 0 } } }
+        T{ ##spill { src 1 } { rep int-rep } { dst T{ spill-slot f 0 } } }
     }
 ] [
     [
-        { 1 int-rep } { T{ spill-slot f 0 } int-rep } >insn
+        T{ location f 1 int-rep int-regs }
+        T{ location f T{ spill-slot f 0 } int-rep int-regs }
+        >insn
     ] { } make
 ] unit-test
 
@@ -41,27 +48,84 @@ IN: compiler.cfg.linear-scan.resolve.tests
     }
 ] [
     [
-        { 1 int-rep } { 2 int-rep } >insn
+        T{ location f 1 int-rep int-regs }
+        T{ location f 2 int-rep int-regs }
+        >insn
     ] { } make
 ] unit-test
 
+[
+    {
+        T{ ##copy { src 1 } { dst 2 } { rep int-rep } }
+        T{ ##branch }
+    }
+] [
+    { { T{ location f 1 int-rep int-regs } T{ location f 2 int-rep int-regs } } }
+    mapping-instructions
+] unit-test
+
+[
+    {
+        T{ ##spill { src 0 } { rep int-rep } { dst T{ spill-slot f 0 } } }
+        T{ ##reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 1 } } }
+        T{ ##branch }
+    }
+] [
+    {
+        { T{ location f T{ spill-slot f 1 } tagged-rep int-regs } T{ location f 0 tagged-rep int-regs } }
+        { T{ location f 0 int-rep int-regs } T{ location f T{ spill-slot f 0 } int-rep int-regs } }
+    }
+    mapping-instructions
+] unit-test
+
+[
+    {
+        T{ ##spill { src 0 } { rep int-rep } { dst T{ spill-slot f 1 } } }
+        T{ ##reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 0 } } }
+        T{ ##branch }
+    }
+] [
+    {
+        { T{ location f T{ spill-slot f 0 } tagged-rep int-regs } T{ location f 0 tagged-rep int-regs } }
+        { T{ location f 0 int-rep int-regs } T{ location f T{ spill-slot f 1 } int-rep int-regs } }
+    }
+    mapping-instructions
+] unit-test
+
+[
+    {
+        T{ ##spill { src 0 } { rep int-rep } { dst T{ spill-slot f 1 } } }
+        T{ ##reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 0 } } }
+        T{ ##branch }
+    }
+] [
+    {
+        { T{ location f 0 int-rep int-regs } T{ location f T{ spill-slot f 1 } int-rep int-regs } }
+        { T{ location f T{ spill-slot f 0 } tagged-rep int-regs } T{ location f 0 tagged-rep int-regs } }
+    }
+    mapping-instructions
+] unit-test
+
 cfg new 8 >>spill-area-size cfg set
 H{ } clone spill-temps set
 
-[
+[ t ] [
-    t
+    {
-] [
+        { T{ location f 0 int-rep int-regs } T{ location f 1 int-rep int-regs } }
-    { { { 0 int-rep } { 1 int-rep } } { { 1 int-rep } { 0 int-rep } } }
+        { T{ location f 1 int-rep int-regs } T{ location f 0 int-rep int-regs } }
+    }
     mapping-instructions {
         {
-            T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 8 } } }
+            T{ ##spill { src 0 } { rep int-rep } { dst T{ spill-slot f 8 } } }
             T{ ##copy { dst 0 } { src 1 } { rep int-rep } }
-            T{ _reload { dst 1 } { rep int-rep } { src T{ spill-slot f 8 } } }
+            T{ ##reload { dst 1 } { rep int-rep } { src T{ spill-slot f 8 } } }
+            T{ ##branch }
         }
         {
-            T{ _spill { src 1 } { rep int-rep } { dst T{ spill-slot f 8 } } }
+            T{ ##spill { src 1 } { rep int-rep } { dst T{ spill-slot f 8 } } }
             T{ ##copy { dst 1 } { src 0 } { rep int-rep } }
-            T{ _reload { dst 0 } { rep int-rep } { src T{ spill-slot f 8 } } }
+            T{ ##reload { dst 0 } { rep int-rep } { src T{ spill-slot f 8 } } }
+            T{ ##branch }
         }
     } member?
 ] unit-test

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

@@ -1,8 +1,9 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators
 combinators.short-circuit fry kernel locals namespaces
 make math sequences hashtables
+cpu.architecture
 compiler.cfg
 compiler.cfg.rpo
 compiler.cfg.liveness
@@ -11,42 +12,67 @@ compiler.cfg.utilities
 compiler.cfg.instructions
 compiler.cfg.predecessors
 compiler.cfg.parallel-copy
+compiler.cfg.ssa.destruction
 compiler.cfg.linear-scan.assignment
 compiler.cfg.linear-scan.allocation.state ;
 IN: compiler.cfg.linear-scan.resolve
 
+TUPLE: location
+{ reg read-only }
+{ rep read-only }
+{ reg-class read-only } ;
+
+: <location> ( reg rep -- location )
+    dup reg-class-of location boa ;
+
+M: location equal?
+    over location? [
+        { [ [ reg>> ] bi@ = ] [ [ reg-class>> ] bi@ = ] } 2&&
+    ] [ 2drop f ] if ;
+
+M: location hashcode*
+    reg>> hashcode* ;
+
 SYMBOL: spill-temps
 
 : spill-temp ( rep -- n )
-    spill-temps get [ next-spill-slot ] cache ;
+    rep-size spill-temps get [ next-spill-slot ] cache ;
 
 : add-mapping ( from to rep -- )
-    '[ _ 2array ] bi@ 2array , ;
+    '[ _ <location> ] bi@ 2array , ;
 
-:: resolve-value-data-flow ( bb to vreg -- )
+:: resolve-value-data-flow ( vreg live-out live-in edge-live-in -- )
-    vreg bb vreg-at-end
+    vreg live-out ?at [ bad-vreg ] unless
-    vreg to vreg-at-start
+    vreg live-in ?at [ edge-live-in ?at [ bad-vreg ] unless ] unless
     2dup = [ 2drop ] [ vreg rep-of add-mapping ] if ;
 
-: compute-mappings ( bb to -- mappings )
+:: compute-mappings ( bb to -- mappings )
-    dup live-in dup assoc-empty? [ 3drop f ] [
+    bb machine-live-out :> live-out
-        [ keys [ resolve-value-data-flow ] with with each ] { } make
+    to machine-live-in :> live-in
+    bb to machine-edge-live-in :> edge-live-in
+    live-out assoc-empty? [ f ] [
+        [
+            live-in keys edge-live-in keys append [
+                live-out live-in edge-live-in
+                resolve-value-data-flow
+            ] each
+        ] { } make
     ] if ;
 
 : memory->register ( from to -- )
-    swap [ first2 ] [ first ] bi* _reload ;
+    swap [ reg>> ] [ [ rep>> ] [ reg>> ] bi ] bi* ##reload ;
 
 : register->memory ( from to -- )
-    [ first2 ] [ first ] bi* _spill ;
+    [ [ reg>> ] [ rep>> ] bi ] [ reg>> ] bi* ##spill ;
 
 : temp->register ( from to -- )
-    nip [ first ] [ second ] [ second spill-temp ] tri _reload ;
+    nip [ reg>> ] [ rep>> ] [ rep>> spill-temp ] tri ##reload ;
 
 : register->temp ( from to -- )
-    drop [ first2 ] [ second spill-temp ] bi _spill ;
+    drop [ [ reg>> ] [ rep>> ] bi ] [ rep>> spill-temp ] bi ##spill ;
 
 : register->register ( from to -- )
-    swap [ first ] [ first2 ] bi* ##copy ;
+    swap [ reg>> ] [ [ reg>> ] [ rep>> ] bi ] bi* ##copy ;
 
 SYMBOL: temp
 
@@ -54,18 +80,18 @@ SYMBOL: temp
     {
         { [ over temp eq? ] [ temp->register ] }
         { [ dup temp eq? ] [ register->temp ] }
-        { [ over first spill-slot? ] [ memory->register ] }
+        { [ over reg>> spill-slot? ] [ memory->register ] }
-        { [ dup first spill-slot? ] [ register->memory ] }
+        { [ dup reg>> spill-slot? ] [ register->memory ] }
         [ register->register ]
     } cond ;
 
 : mapping-instructions ( alist -- insns )
     [ swap ] H{ } assoc-map-as
-    [ temp [ swap >insn ] parallel-mapping ] { } make ;
+    [ temp [ swap >insn ] parallel-mapping ##branch ] { } make ;
 
 : perform-mappings ( bb to mappings -- )
     dup empty? [ 3drop ] [
-        mapping-instructions insert-simple-basic-block
+        mapping-instructions insert-basic-block
         cfg get cfg-changed drop
     ] if ;
 

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

@@ -1,6 +1,6 @@
-USING: compiler.cfg.debugger compiler.cfg compiler.cfg.linearization.order
+USING: compiler.cfg.debugger compiler.cfg compiler.cfg.linearization
 kernel accessors sequences sets tools.test namespaces ;
-IN: compiler.cfg.linearization.order.tests
+IN: compiler.cfg.linearization.tests
 
 V{ } 0 test-bb
 

basis/compiler/cfg/linearization/linearization.factor

@@ -1,113 +1,91 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math accessors sequences namespaces make
+USING: accessors arrays assocs deques dlists hashtables kernel
-combinators assocs arrays locals layouts hashtables
+make sorting namespaces sequences combinators
-cpu.architecture generalizations
+combinators.short-circuit fry math compiler.cfg.rpo
-compiler.cfg
+compiler.cfg.utilities compiler.cfg.loop-detection
-compiler.cfg.comparisons
+compiler.cfg.predecessors sets hash-sets ;
-compiler.cfg.stack-frame
+FROM: namespaces => set ;
-compiler.cfg.instructions
-compiler.cfg.utilities
-compiler.cfg.linearization.order ;
 IN: compiler.cfg.linearization
 
+! This is RPO except loops are rotated and unlikely blocks go
+! at the end. Based on SBCL's src/compiler/control.lisp
+
 <PRIVATE
 
+SYMBOLS: work-list loop-heads visited ;
+
+: visited? ( bb -- ? ) visited get in? ;
+
+: add-to-work-list ( bb -- )
+    dup visited? [ drop ] [
+        work-list get push-back
+    ] if ;
+
+: init-linearization-order ( cfg -- )
+    <dlist> work-list set
+    HS{ } clone visited set
+    entry>> add-to-work-list ;
+
+: (find-alternate-loop-head) ( bb -- bb' )
+    dup {
+        [ predecessor visited? not ]
+        [ predecessors>> length 1 = ]
+        [ predecessor successors>> length 1 = ]
+        [ [ number>> ] [ predecessor number>> ] bi > ]
+    } 1&& [ predecessor (find-alternate-loop-head) ] when ;
+
+: find-back-edge ( bb -- pred )
+    [ predecessors>> ] keep '[ _ back-edge? ] find nip ;
+
+: find-alternate-loop-head ( bb -- bb' )
+    dup find-back-edge dup visited? [ drop ] [
+        nip (find-alternate-loop-head)
+    ] if ;
+
+: predecessors-ready? ( bb -- ? )
+    [ predecessors>> ] keep '[
+        _ 2dup back-edge?
+        [ 2drop t ] [ drop visited? ] if
+    ] all? ;
+
+: process-successor ( bb -- )
+    dup predecessors-ready? [
+        dup loop-entry? [ find-alternate-loop-head ] when
+        add-to-work-list
+    ] [ drop ] if ;
+
+: sorted-successors ( bb -- seq )
+    successors>> <reversed> [ loop-nesting-at ] sort-with ;
+
+: process-block ( bb -- )
+    dup visited? [ drop ] [
+        [ , ]
+        [ visited get adjoin ]
+        [ sorted-successors [ process-successor ] each ]
+        tri
+    ] if ;
+
+: (linearization-order) ( cfg -- bbs )
+    init-linearization-order
+
+    [ work-list get [ process-block ] slurp-deque ] { } make
+    ! [ unlikely?>> not ] partition append
+    ;
+
+PRIVATE>
+
+: linearization-order ( cfg -- bbs )
+    needs-post-order needs-loops needs-predecessors
+
+    dup linear-order>> [ ] [
+        dup (linearization-order)
+        >>linear-order linear-order>>
+    ] ?if ;
+
 SYMBOL: numbers
 
 : block-number ( bb -- n ) numbers get at ;
 
-: number-blocks ( bbs -- ) [ 2array ] map-index >hashtable numbers set ;
+: number-blocks ( bbs -- )
-
+    [ 2array ] map-index >hashtable numbers set ;
-! Convert CFG IR to machine IR.
-GENERIC: linearize-insn ( basic-block insn -- )
-
-: linearize-basic-block ( bb -- )
-    [ block-number _label ]
-    [ dup instructions>> [ linearize-insn ] with each ]
-    bi ;
-
-M: insn linearize-insn , drop ;
-
-: useless-branch? ( basic-block successor -- ? )
-    ! If our successor immediately follows us in linearization
-    ! order then we don't need to branch.
-    [ block-number ] bi@ 1 - = ; inline
-
-: emit-branch ( bb successor -- )
-    2dup useless-branch? [ 2drop ] [ nip block-number _branch ] if ;
-
-M: ##branch linearize-insn
-    drop dup successors>> first emit-branch ;
-
-: successors ( bb -- first second ) successors>> first2 ; inline
-
-:: conditional ( bb insn n conditional-quot negate-cc-quot -- bb successor label etc... )
-    bb insn
-    conditional-quot
-    [ drop dup successors>> second useless-branch? ] 2bi
-    [ [ swap block-number ] n ndip ]
-    [ [ block-number ] n ndip negate-cc-quot call ] if ; inline
-
-: (binary-conditional) ( bb insn -- bb successor1 successor2 src1 src2 cc )
-    [ dup successors ]
-    [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
-
-: binary-conditional ( bb insn -- bb successor label2 src1 src2 cc )
-    3 [ (binary-conditional) ] [ negate-cc ] conditional ;
-
-: (test-vector-conditional) ( bb insn -- bb successor1 successor2 src1 temp rep vcc )
-    [ dup successors ]
-    [ { [ src1>> ] [ temp>> ] [ rep>> ] [ vcc>> ] } cleave ] bi* ; inline
-
-: test-vector-conditional ( bb insn -- bb successor label src1 temp rep vcc )
-    4 [ (test-vector-conditional) ] [ negate-vcc ] conditional ;
-
-M: ##compare-branch linearize-insn
-    binary-conditional _compare-branch emit-branch ;
-
-M: ##compare-imm-branch linearize-insn
-    binary-conditional _compare-imm-branch emit-branch ;
-
-M: ##compare-float-ordered-branch linearize-insn
-    binary-conditional _compare-float-ordered-branch emit-branch ;
-
-M: ##compare-float-unordered-branch linearize-insn
-    binary-conditional _compare-float-unordered-branch emit-branch ;
-
-M: ##test-vector-branch linearize-insn
-    test-vector-conditional _test-vector-branch emit-branch ;
-
-: overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 )
-    [ dup successors block-number ]
-    [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline
-
-M: ##fixnum-add linearize-insn
-    overflow-conditional _fixnum-add emit-branch ;
-
-M: ##fixnum-sub linearize-insn
-    overflow-conditional _fixnum-sub emit-branch ;
-
-M: ##fixnum-mul linearize-insn
-    overflow-conditional _fixnum-mul emit-branch ;
-
-M: ##dispatch linearize-insn
-    swap
-    [ [ src>> ] [ temp>> ] bi _dispatch ]
-    [ successors>> [ block-number _dispatch-label ] each ]
-    bi* ;
-
-: linearize-basic-blocks ( cfg -- insns )
-    [
-        [
-            linearization-order
-            [ 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,81 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs deques dlists kernel make sorting
-namespaces sequences combinators combinators.short-circuit
-fry math compiler.cfg.rpo compiler.cfg.utilities
-compiler.cfg.loop-detection compiler.cfg.predecessors
-sets hash-sets ;
-FROM: namespaces => set ;
-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 ;
-
-: visited? ( bb -- ? ) visited get in? ;
-
-: add-to-work-list ( bb -- )
-    dup visited? [ drop ] [
-        work-list get push-back
-    ] if ;
-
-: init-linearization-order ( cfg -- )
-    <dlist> work-list set
-    HS{ } clone visited set
-    entry>> add-to-work-list ;
-
-: (find-alternate-loop-head) ( bb -- bb' )
-    dup {
-        [ predecessor visited? not ]
-        [ predecessors>> length 1 = ]
-        [ predecessor successors>> length 1 = ]
-        [ [ number>> ] [ predecessor number>> ] bi > ]
-    } 1&& [ predecessor (find-alternate-loop-head) ] when ;
-
-: find-back-edge ( bb -- pred )
-    [ predecessors>> ] keep '[ _ back-edge? ] find nip ;
-
-: find-alternate-loop-head ( bb -- bb' )
-    dup find-back-edge dup visited? [ drop ] [
-        nip (find-alternate-loop-head)
-    ] if ;
-
-: predecessors-ready? ( bb -- ? )
-    [ predecessors>> ] keep '[
-        _ 2dup back-edge?
-        [ 2drop t ] [ drop visited? ] if
-    ] all? ;
-
-: process-successor ( bb -- )
-    dup predecessors-ready? [
-        dup loop-entry? [ find-alternate-loop-head ] when
-        add-to-work-list
-    ] [ drop ] if ;
-
-: sorted-successors ( bb -- seq )
-    successors>> <reversed> [ loop-nesting-at ] sort-with ;
-
-: process-block ( bb -- )
-    dup visited? [ drop ] [
-        [ , ]
-        [ visited get adjoin ]
-        [ sorted-successors [ process-successor ] each ]
-        tri
-    ] if ;
-
-: (linearization-order) ( cfg -- bbs )
-    init-linearization-order
-
-    [ work-list get [ process-block ] slurp-deque ] { } make ;
-
-PRIVATE>
-
-: linearization-order ( cfg -- bbs )
-    needs-post-order needs-loops needs-predecessors
-
-    dup linear-order>> [ ] [
-        dup (linearization-order)
-        >>linear-order linear-order>>
-    ] ?if ;

basis/compiler/cfg/linearization/summary.txt

@@ -1 +0,0 @@
-Flattening CFG into MR (machine representation)

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

@@ -0,0 +1,61 @@
+USING: accessors compiler.cfg compiler.cfg.debugger
+compiler.cfg.instructions compiler.cfg.liveness.ssa
+compiler.cfg.liveness arrays sequences assocs
+compiler.cfg.registers kernel namespaces tools.test ;
+IN: compiler.cfg.liveness.ssa.tests
+
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##load-integer f 0 0 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##load-integer f 1 1 }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##phi f 2 H{ { 2 0 } { 3 1 } } }
+    T{ ##branch }
+} 4 test-bb
+
+V{
+    T{ ##branch }
+} 5 test-bb
+
+V{
+    T{ ##replace f 2 D 0 }
+    T{ ##branch }
+} 6 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 7 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+2 4 edge
+3 4 edge
+4 { 5 6 } edges
+5 6 edge
+6 7 edge
+
+[ ] [ cfg new 0 get >>entry dup cfg set compute-ssa-live-sets ] unit-test
+
+[ t ] [ 0 get live-in assoc-empty? ] unit-test
+
+[ H{ { 2 2 } } ] [ 4 get live-out ] unit-test
+
+[ H{ { 0 0 } } ] [ 2 get 4 get edge-live-in ] unit-test
+
+[ H{ { 1 1 } } ] [ 3 get 4 get edge-live-in ] unit-test

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

@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 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
@@ -11,9 +11,9 @@ IN: compiler.cfg.liveness.ssa
 
 ! Assoc mapping basic blocks to sequences of sets of vregs; each sequence
 ! is in correspondence with a predecessor
-SYMBOL: phi-live-ins
+SYMBOL: edge-live-ins
 
-: phi-live-in ( predecessor basic-block -- set ) phi-live-ins get at at ;
+: edge-live-in ( predecessor basic-block -- set ) edge-live-ins get at at ;
 
 SYMBOL: work-list
 
@@ -23,19 +23,19 @@ SYMBOL: work-list
 : compute-live-in ( basic-block -- live-in )
     [ live-out ] keep instructions>> transfer-liveness ;
 
-: compute-phi-live-in ( basic-block -- phi-live-in )
+: compute-edge-live-in ( basic-block -- edge-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 ]
+    [ [ compute-edge-live-in ] keep edge-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
+    [ dup successors>> [ edge-live-in ] with map ] bi
     append assoc-combine ;
 
 : update-live-out ( basic-block -- changed? )
@@ -48,14 +48,14 @@ SYMBOL: work-list
         [ predecessors>> add-to-work-list ] [ drop ] if
     ] [ drop ] if ;
 
-: compute-ssa-live-sets ( cfg -- cfg' )
+: compute-ssa-live-sets ( cfg -- )
     needs-predecessors
 
     <hashed-dlist> work-list set
     H{ } clone live-ins set
-    H{ } clone phi-live-ins set
+    H{ } clone edge-live-ins set
     H{ } clone live-outs set
-    dup post-order add-to-work-list
+    post-order add-to-work-list
     work-list get [ liveness-step ] slurp-deque ;
 
 : live-in? ( vreg bb -- ? ) live-in key? ;

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

@@ -79,6 +79,8 @@ PRIVATE>
 
 : loop-nesting-at ( bb -- n ) loop-nesting get at 0 or ;
 
+: current-loop-nesting ( -- n ) basic-block get loop-nesting-at ;
+
 : needs-loops ( cfg -- cfg' )
     needs-predecessors
     dup loops-valid?>> [ detect-loops t >>loops-valid? ] unless ;

basis/compiler/cfg/mr/authors.txt

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

basis/compiler/cfg/mr/mr.factor

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

basis/compiler/cfg/optimizer/optimizer.factor

@@ -1,7 +1,6 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors combinators namespaces
+USING: compiler.cfg.tco
-compiler.cfg.tco
 compiler.cfg.useless-conditionals
 compiler.cfg.branch-splitting
 compiler.cfg.block-joining
@@ -12,20 +11,14 @@ compiler.cfg.value-numbering
 compiler.cfg.copy-prop
 compiler.cfg.dce
 compiler.cfg.write-barrier
-compiler.cfg.scheduling
 compiler.cfg.representations
+compiler.cfg.gc-checks
+compiler.cfg.save-contexts
 compiler.cfg.ssa.destruction
 compiler.cfg.empty-blocks
 compiler.cfg.checker ;
 IN: compiler.cfg.optimizer
 
-SYMBOL: check-optimizer?
-
-: ?check ( cfg -- cfg' )
-    check-optimizer? get [
-        dup check-cfg
-    ] when ;
-
 : optimize-cfg ( cfg -- cfg' )
     optimize-tail-calls
     delete-useless-conditionals
@@ -37,9 +30,4 @@ SYMBOL: check-optimizer?
     value-numbering
     copy-propagation
     eliminate-dead-code
-    eliminate-write-barriers
+    eliminate-write-barriers ;
-    select-representations
-    schedule-instructions
-    destruct-ssa
-    delete-empty-blocks
-    ?check ;

basis/compiler/cfg/representations/coalescing/authors.txt

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

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

@@ -0,0 +1,40 @@
+USING: arrays sequences kernel namespaces accessors compiler.cfg
+compiler.cfg.instructions
+compiler.cfg.registers
+compiler.cfg.debugger
+compiler.cfg.representations.coalescing
+tools.test ;
+IN: compiler.cfg.representations.coalescing.tests
+
+: test-scc ( -- )
+    cfg new 0 get >>entry compute-components ;
+
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 2 D 0 }
+    T{ ##load-integer f 0 0 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##load-integer f 1 0 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##phi f 3 H{ { 1 0 } { 2 1 } } }
+} 3 test-bb
+
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
+
+[ ] [ test-scc ] unit-test
+
+[ t ] [ 0 vreg>scc 1 vreg>scc = ] unit-test
+[ t ] [ 0 vreg>scc 3 vreg>scc = ] unit-test
+[ f ] [ 2 vreg>scc 3 vreg>scc = ] unit-test

basis/compiler/cfg/representations/coalescing/coalescing.factor

@@ -0,0 +1,43 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs compiler.cfg.def-use
+compiler.cfg.instructions compiler.cfg.rpo disjoint-sets fry
+kernel namespaces sequences ;
+IN: compiler.cfg.representations.coalescing
+
+! Find all strongly connected components in the graph where the
+! edges are ##phi or ##copy vreg uses
+SYMBOL: components
+
+: init-components ( cfg components -- )
+    '[
+        instructions>> [
+            defs-vreg [ _ add-atom ] when*
+        ] each
+    ] each-basic-block ;
+
+GENERIC# visit-insn 1 ( insn disjoint-set -- )
+
+M: ##copy visit-insn
+    [ [ dst>> ] [ src>> ] bi ] dip equate ;
+
+M: ##phi visit-insn
+    [ [ inputs>> values ] [ dst>> ] bi ] dip equate-all-with ;
+
+M: insn visit-insn 2drop ;
+
+: merge-components ( cfg components -- )
+    '[
+        instructions>> [
+            _ visit-insn
+        ] each
+    ] each-basic-block ;
+
+: compute-components ( cfg -- )
+    <disjoint-set>
+    [ init-components ]
+    [ merge-components ]
+    [ components set drop ] 2tri ;
+
+: vreg>scc ( vreg -- scc )
+    components get representative ;

basis/compiler/cfg/representations/conversion/authors.txt

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

basis/compiler/cfg/representations/conversion/conversion.factor

@@ -0,0 +1,84 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays byte-arrays combinators compiler.cfg.instructions
+compiler.cfg.registers compiler.constants cpu.architecture
+kernel layouts locals math namespaces ;
+IN: compiler.cfg.representations.conversion
+
+ERROR: bad-conversion dst src dst-rep src-rep ;
+
+GENERIC: rep>tagged ( dst src rep -- )
+GENERIC: tagged>rep ( dst src rep -- )
+
+M: int-rep rep>tagged ( dst src rep -- )
+    drop tag-bits get ##shl-imm ;
+
+M: int-rep tagged>rep ( dst src rep -- )
+    drop tag-bits get ##sar-imm ;
+
+M:: float-rep rep>tagged ( dst src rep -- )
+    double-rep next-vreg-rep :> temp
+    temp src ##single>double-float
+    dst temp double-rep rep>tagged ;
+
+M:: float-rep tagged>rep ( dst src rep -- )
+    double-rep next-vreg-rep :> temp
+    temp src double-rep tagged>rep
+    dst temp ##double>single-float ;
+
+M:: double-rep rep>tagged ( dst src rep -- )
+    dst 16 float int-rep next-vreg-rep ##allot
+    src dst float-offset double-rep f ##store-memory-imm ;
+
+M: double-rep tagged>rep
+    drop float-offset double-rep f ##load-memory-imm ;
+
+M:: vector-rep rep>tagged ( dst src rep -- )
+    tagged-rep next-vreg-rep :> temp
+    dst 16 2 cells + byte-array int-rep next-vreg-rep ##allot
+    temp 16 tag-fixnum ##load-tagged
+    temp dst 1 byte-array type-number ##set-slot-imm
+    src dst byte-array-offset rep f ##store-memory-imm ;
+
+M: vector-rep tagged>rep
+    [ byte-array-offset ] dip f ##load-memory-imm ;
+
+M:: scalar-rep rep>tagged ( dst src rep -- )
+    tagged-rep next-vreg-rep :> temp
+    temp src rep ##scalar>integer
+    dst temp int-rep rep>tagged ;
+
+M:: scalar-rep tagged>rep ( dst src rep -- )
+    tagged-rep next-vreg-rep :> temp
+    temp src int-rep tagged>rep
+    dst temp rep ##integer>scalar ;
+
+GENERIC: rep>int ( dst src rep -- )
+GENERIC: int>rep ( dst src rep -- )
+
+M: scalar-rep rep>int ( dst src rep -- )
+    ##scalar>integer ;
+
+M: scalar-rep int>rep ( dst src rep -- )
+    ##integer>scalar ;
+
+: emit-conversion ( dst src dst-rep src-rep -- )
+    {
+        { [ 2dup eq? ] [ drop ##copy ] }
+        { [ dup tagged-rep? ] [ drop tagged>rep ] }
+        { [ over tagged-rep? ] [ nip rep>tagged ] }
+        { [ dup int-rep? ] [ drop int>rep ] }
+        { [ over int-rep? ] [ nip rep>int ] }
+        [
+            2dup 2array {
+                { { double-rep float-rep } [ 2drop ##single>double-float ] }
+                { { float-rep double-rep } [ 2drop ##double>single-float ] }
+                ! Punning SIMD vector types? Naughty naughty! But
+                ! it is allowed... otherwise bail out.
+                [
+                    drop 2dup [ reg-class-of ] bi@ eq?
+                    [ drop ##copy ] [ bad-conversion ] if
+                ]
+            } case
+        ]
+    } cond ;

basis/compiler/cfg/representations/peephole/authors.txt

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

basis/compiler/cfg/representations/peephole/peephole.factor

@@ -0,0 +1,253 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors byte-arrays combinators
+combinators.short-circuit kernel layouts locals make math
+namespaces sequences cpu.architecture compiler.cfg.registers
+compiler.cfg.instructions
+compiler.cfg.representations.rewrite
+compiler.cfg.representations.selection ;
+IN: compiler.cfg.representations.peephole
+
+! Representation selection performs some peephole optimizations
+! when inserting conversions to optimize for a few common cases
+
+GENERIC: optimize-insn ( insn -- )
+
+SYMBOL: insn-index
+
+: here ( -- )
+    building get length 1 - insn-index set ;
+
+: finish ( insn -- ) , here ;
+
+: unchanged ( insn -- )
+    [ no-use-conversion ] [ finish ] [ no-def-conversion ] tri ;
+
+: last-insn ( -- insn ) insn-index get building get nth ;
+
+M: vreg-insn conversions-for-insn
+    init-renaming-set
+    optimize-insn
+    last-insn perform-renaming ;
+
+M: vreg-insn optimize-insn
+    [ emit-use-conversion ] [ finish ] [ emit-def-conversion ] tri ;
+
+M: ##load-integer optimize-insn
+    {
+        {
+            [ dup dst>> rep-of tagged-rep? ]
+            [ [ dst>> ] [ val>> tag-fixnum ] bi ##load-tagged here ]
+        }
+        [ call-next-method ]
+    } cond ;
+
+! When a float is unboxed, we replace the ##load-reference with a ##load-double
+! if the architecture supports it
+: convert-to-load-double? ( insn -- ? )
+    {
+        [ drop fused-unboxing? ]
+        [ dst>> rep-of double-rep? ]
+        [ obj>> float? ]
+    } 1&& ;
+
+: convert-to-load-vector? ( insn -- ? )
+    {
+        [ drop fused-unboxing? ]
+        [ dst>> rep-of vector-rep? ]
+        [ obj>> byte-array? ]
+    } 1&& ;
+
+! When a literal zeroes/ones vector is unboxed, we replace the ##load-reference
+! with a ##zero-vector or ##fill-vector instruction since this is more efficient.
+: convert-to-zero-vector? ( insn -- ? )
+    {
+        [ dst>> rep-of vector-rep? ]
+        [ obj>> B{ 0 0 0 0  0 0 0 0  0 0 0 0  0 0 0 0 } = ]
+    } 1&& ;
+
+: convert-to-fill-vector? ( insn -- ? )
+    {
+        [ dst>> rep-of vector-rep? ]
+        [ obj>> B{ 255 255 255 255  255 255 255 255  255 255 255 255  255 255 255 255 } = ]
+    } 1&& ;
+
+M: ##load-reference optimize-insn
+    {
+        {
+            [ dup convert-to-load-double? ]
+            [ [ dst>> ] [ obj>> ] bi ##load-double here ]
+        }
+        {
+            [ dup convert-to-zero-vector? ]
+            [ dst>> dup rep-of ##zero-vector here ]
+        }
+        {
+            [ dup convert-to-fill-vector? ]
+            [ dst>> dup rep-of ##fill-vector here ]
+        }
+        {
+            [ dup convert-to-load-vector? ]
+            [ [ dst>> ] [ obj>> ] [ dst>> rep-of ] tri ##load-vector here ]
+        }
+        [ call-next-method ]
+    } cond ;
+
+! Optimize this:
+! ##sar-imm temp src tag-bits
+! ##shl-imm dst temp X
+! Into either
+! ##shl-imm by X - tag-bits, or
+! ##sar-imm by tag-bits - X.
+: combine-shl-imm-input ( insn -- )
+    [ dst>> ] [ src1>> ] [ src2>> ] tri tag-bits get {
+        { [ 2dup < ] [ swap - ##sar-imm here ] }
+        { [ 2dup > ] [ - ##shl-imm here ] }
+        [ 2drop int-rep ##copy here ]
+    } cond ;
+
+: dst-tagged? ( insn -- ? ) dst>> rep-of tagged-rep? ;
+: src1-tagged? ( insn -- ? ) src1>> rep-of tagged-rep? ;
+: src2-tagged? ( insn -- ? ) src2>> rep-of tagged-rep? ;
+
+: src2-tagged-arithmetic? ( insn -- ? ) src2>> tag-fixnum immediate-arithmetic? ;
+: src2-tagged-bitwise? ( insn -- ? ) src2>> tag-fixnum immediate-bitwise? ;
+: src2-tagged-shift-count? ( insn -- ? ) src2>> tag-bits get + immediate-shift-count? ;
+
+: >tagged-shift ( insn -- ) [ tag-bits get + ] change-src2 finish ; inline
+
+M: ##shl-imm optimize-insn
+    {
+        {
+            [ dup { [ dst-tagged? ] [ src1-tagged? ] } 1&& ]
+            [ unchanged ]
+        }
+        {
+            [ dup { [ dst-tagged? ] [ src2-tagged-shift-count? ] } 1&& ]
+            [ [ emit-use-conversion ] [ >tagged-shift ] [ no-def-conversion ] tri ]
+        }
+        {
+            [ dup src1-tagged? ]
+            [ [ no-use-conversion ] [ combine-shl-imm-input ] [ emit-def-conversion ] tri ]
+        }
+        [ call-next-method ]
+    } cond ;
+
+! Optimize this:
+! ##sar-imm temp src tag-bits
+! ##sar-imm dst temp X
+! Into
+! ##sar-imm by X + tag-bits
+! assuming X + tag-bits is a valid shift count.
+M: ##sar-imm optimize-insn
+    {
+        {
+            [ dup { [ src1-tagged? ] [ src2-tagged-shift-count? ] } 1&& ]
+            [ [ no-use-conversion ] [ >tagged-shift ] [ emit-def-conversion ] tri ]
+        }
+        [ call-next-method ]
+    } cond ;
+
+! Peephole optimization: for X = add, sub, and, or, xor, min, max
+! we have
+! tag(untag(a) X untag(b)) = a X b
+!
+! so if all inputs and outputs of ##X or ##X-imm are tagged,
+! don't have to insert any conversions
+M: inert-tag-untag-insn optimize-insn
+    {
+        {
+            [ dup { [ dst-tagged? ] [ src1-tagged? ] [ src2-tagged? ] } 1&& ]
+            [ unchanged ]
+        }
+        [ call-next-method ]
+    } cond ;
+
+! -imm variant of above
+: >tagged-imm ( insn -- )
+    [ tag-fixnum ] change-src2 unchanged ; inline
+
+M: inert-arithmetic-tag-untag-insn optimize-insn
+    {
+        {
+            [ dup { [ dst-tagged? ] [ src1-tagged? ] [ src2-tagged-arithmetic? ] } 1&& ]
+            [ >tagged-imm ]
+        }
+        [ call-next-method ]
+    } cond ;
+
+M: inert-bitwise-tag-untag-insn optimize-insn
+    {
+        {
+            [ dup { [ dst-tagged? ] [ src1-tagged? ] [ src2-tagged-bitwise? ] } 1&& ]
+            [ >tagged-imm ]
+        }
+        [ call-next-method ]
+    } cond ;
+
+M: ##mul-imm optimize-insn
+    {
+        { [ dup { [ dst-tagged? ] [ src1-tagged? ] } 1&& ] [ unchanged ] }
+        { [ dup { [ dst-tagged? ] [ src2-tagged-arithmetic? ] } 1&& ] [ >tagged-imm ] }
+        [ call-next-method ]
+    } cond ;
+
+! Similar optimization for comparison operators
+M: ##compare-integer-imm optimize-insn
+    {
+        { [ dup { [ src1-tagged? ] [ src2-tagged-arithmetic? ] } 1&& ] [ >tagged-imm ] }
+        [ call-next-method ]
+    } cond ;
+
+M: ##compare-integer-imm-branch optimize-insn
+    {
+        { [ dup { [ src1-tagged? ] [ src2-tagged-arithmetic? ] } 1&& ] [ >tagged-imm ] }
+        [ call-next-method ]
+    } cond ;
+
+M: ##compare-integer optimize-insn
+    {
+        { [ dup { [ src1-tagged? ] [ src2-tagged? ] } 1&& ] [ unchanged ] }
+        [ call-next-method ]
+    } cond ;
+
+M: ##compare-integer-branch optimize-insn
+    {
+        { [ dup { [ src1-tagged? ] [ src2-tagged? ] } 1&& ] [ unchanged ] }
+        [ call-next-method ]
+    } cond ;
+
+! Identities:
+! tag(neg(untag(x))) = x
+! tag(neg(x)) = x * -2^tag-bits
+: inert-tag/untag-unary? ( insn -- ? )
+    [ dst>> ] [ src>> ] bi [ rep-of tagged-rep? ] both? ;
+
+: combine-neg-tag ( insn -- )
+    [ dst>> ] [ src>> ] bi tag-bits get 2^ neg ##mul-imm here ;
+
+M: ##neg optimize-insn
+    {
+        { [ dup inert-tag/untag-unary? ] [ unchanged ] }
+        {
+            [ dup dst>> rep-of tagged-rep? ]
+            [ [ emit-use-conversion ] [ combine-neg-tag ] [ no-def-conversion ] tri ]
+        }
+        [ call-next-method ]
+    } cond ;
+
+! Identity:
+! tag(not(untag(x))) = not(x) xor tag-mask
+:: emit-tagged-not ( insn -- )
+    tagged-rep next-vreg-rep :> temp
+    temp insn src>> ##not
+    insn dst>> temp tag-mask get ##xor-imm here ;
+
+M: ##not optimize-insn
+    {
+        {
+            [ dup inert-tag/untag-unary? ]
+            [ [ no-use-conversion ] [ emit-tagged-not ] [ no-def-conversion ] tri ]
+        }
+        [ call-next-method ]
+    } cond ;

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

@@ -68,23 +68,23 @@ PRIVATE>
     tri
 ] with-compilation-unit
 
-: each-def-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... )
+: 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 -- ... ) -- ... )
+: 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 -- ... ) -- ... )
+: each-temp-rep ( insn vreg-quot: ( vreg rep -- ) -- )
     [ [ temp-vregs ] [ temp-vreg-reps ] bi ] dip 2each ; inline
 
-: with-vreg-reps ( ..a cfg vreg-quot: ( ..a vreg rep -- ..b ) -- ..b )
+: each-rep ( insn vreg-quot: ( vreg rep -- ) -- )
+    [ each-def-rep ] [ each-use-rep ] [ each-temp-rep ] 2tri ; inline
+
+: with-vreg-reps ( cfg vreg-quot: ( vreg rep -- ) -- )
     '[
         [ basic-block set ] [
             [
-                _
+                _ each-rep
-                [ 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

@@ -1,6 +1,11 @@
-USING: tools.test cpu.architecture
+USING: accessors compiler.cfg compiler.cfg.debugger
-compiler.cfg.registers compiler.cfg.instructions
+compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.representations.preferred ;
+compiler.cfg.representations.preferred cpu.architecture kernel
+namespaces tools.test sequences arrays system literals layouts
+math compiler.constants compiler.cfg.representations.conversion
+compiler.cfg.representations.rewrite
+compiler.cfg.comparisons
+make ;
 IN: compiler.cfg.representations
 
 [ { double-rep double-rep } ] [
@@ -12,8 +17,717 @@ IN: compiler.cfg.representations
 ] unit-test
 
 [ double-rep ] [
-    T{ ##alien-double
+    T{ ##load-memory-imm
        { dst 5 }
-       { src 3 }
+       { base 3 }
+       { offset 0 }
+       { rep double-rep }
     } defs-vreg-rep
 ] unit-test
+
+H{ } clone representations set
+
+3 \ vreg-counter set-global
+
+[
+    {
+        T{ ##allot f 2 16 float 4 }
+        T{ ##store-memory-imm f 1 2 $[ float-offset ] double-rep f }
+    }
+] [
+    [
+        2 1 tagged-rep double-rep emit-conversion
+    ] { } make
+] unit-test
+
+[
+    {
+        T{ ##load-memory-imm f 2 1 $[ float-offset ] double-rep f }
+    }
+] [
+    [
+        2 1 double-rep tagged-rep emit-conversion
+    ] { } make
+] unit-test
+
+: test-representations ( -- )
+    cfg new 0 get >>entry dup cfg set select-representations drop ;
+
+! Make sure cost calculation isn't completely wrong
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 1 D 0 }
+    T{ ##peek f 2 D 1 }
+    T{ ##add-float f 3 1 2 }
+    T{ ##replace f 3 D 0 }
+    T{ ##replace f 3 D 1 }
+    T{ ##replace f 3 D 2 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 2 test-bb
+
+0 1 edge
+1 2 edge
+
+[ ] [ test-representations ] unit-test
+
+[ 1 ] [ 1 get instructions>> [ ##allot? ] count ] unit-test
+
+! Don't dereference the result of a peek
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 1 D 0 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##add-float f 2 1 1 }
+    T{ ##replace f 2 D 0 }
+    T{ ##epilogue }
+    T{ ##return }
+} 2 test-bb
+
+V{
+    T{ ##add-float f 3 1 1 }
+    T{ ##replace f 3 D 0 }
+    T{ ##epilogue }
+    T{ ##return }
+} 3 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+
+[ ] [ test-representations ] unit-test
+
+[
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##branch }
+    }
+] [ 1 get instructions>> ] unit-test
+
+! We cannot untag-fixnum the result of a peek if there are usages
+! of it as a tagged-rep
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 1 D 0 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##replace f 1 R 0 }
+    T{ ##epilogue }
+    T{ ##return }
+} 2 test-bb
+
+V{
+    T{ ##mul f 2 1 1 }
+    T{ ##replace f 2 D 0 }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 4 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+3 { 3 4 } edges
+2 4 edge
+
+[ ] [ test-representations ] unit-test
+
+[
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##branch }
+    }
+] [ 1 get instructions>> ] unit-test
+
+! But its ok to untag-fixnum the result of a peek if all usages use
+! it as int-rep
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 1 D 0 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 2 test-bb
+
+V{
+    T{ ##add f 2 1 1 }
+    T{ ##mul f 3 1 1 }
+    T{ ##replace f 2 D 0 }
+    T{ ##replace f 3 D 1 }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 4 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+3 { 3 4 } edges
+2 4 edge
+
+3 \ vreg-counter set-global
+
+[ ] [ test-representations ] unit-test
+
+[
+    V{
+        T{ ##peek f 4 D 0 }
+        T{ ##sar-imm f 1 4 $[ tag-bits get ] }
+        T{ ##branch }
+    }
+] [ 1 get instructions>> ] unit-test
+
+! scalar-rep => int-rep conversion
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 1 D 0 }
+    T{ ##peek f 2 D 0 }
+    T{ ##vector>scalar f 3 2 int-4-rep }
+    T{ ##replace f 3 D 0 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 2 test-bb
+
+0 1 edge
+1 2 edge
+
+[ ] [ test-representations ] unit-test
+
+[ t ] [ 1 get instructions>> 4 swap nth ##scalar>integer? ] unit-test
+
+! Test phi node behavior
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##load-integer f 1 1 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##load-integer f 2 2 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##phi f 3 H{ { 1 1 } { 2 2 } } }
+    T{ ##replace f 3 D 0 }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 4 test-bb
+
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
+3 4 edge
+
+[ ] [ test-representations ] unit-test
+
+[ T{ ##load-tagged f 1 $[ 1 tag-fixnum ] } ]
+[ 1 get instructions>> first ]
+unit-test
+
+[ T{ ##load-tagged f 2 $[ 2 tag-fixnum ] } ]
+[ 2 get instructions>> first ]
+unit-test
+
+! ##load-reference corner case
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 0 D 0 }
+    T{ ##peek f 1 D 1 }
+    T{ ##add f 2 0 1 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##load-reference f 3 f }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##phi f 4 H{ { 1 2 } { 2 3 } } }
+    T{ ##replace f 4 D 0 }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 4 test-bb
+
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
+3 4 edge
+
+[ ] [ test-representations ] unit-test
+
+! Don't untag the f!
+[ 2 ] [ 2 get instructions>> length ] unit-test
+
+cpu x86.32? [
+
+    ! Make sure load-constant is converted into load-double
+    V{
+        T{ ##prologue }
+        T{ ##branch }
+    } 0 test-bb
+
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##load-reference f 2 0.5 }
+        T{ ##add-float f 3 1 2 }
+        T{ ##replace f 3 D 0 }
+        T{ ##branch }
+    } 1 test-bb
+
+    V{
+        T{ ##epilogue }
+        T{ ##return }
+    } 2 test-bb
+
+    0 1 edge
+    1 2 edge
+
+    [ ] [ test-representations ] unit-test
+
+    [ t ] [ 1 get instructions>> second ##load-double? ] unit-test
+
+    ! Make sure phi nodes are handled in a sane way
+    V{
+        T{ ##prologue }
+        T{ ##branch }
+    } 0 test-bb
+
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##compare-imm-branch f 1 2 cc= }
+    } 1 test-bb
+
+    V{
+        T{ ##load-reference f 2 1.5 }
+        T{ ##branch }
+    } 2 test-bb
+
+    V{
+        T{ ##load-reference f 3 2.5 }
+        T{ ##branch }
+    } 3 test-bb
+
+    V{
+        T{ ##phi f 4 H{ { 2 2 } { 3 3 } } }
+        T{ ##peek f 5 D 0 }
+        T{ ##add-float f 6 4 5 }
+        T{ ##replace f 6 D 0 }
+    } 4 test-bb
+
+    V{
+        T{ ##epilogue }
+        T{ ##return }
+    } 5 test-bb
+
+    test-diamond
+    4 5 edge
+
+    [ ] [ test-representations ] unit-test
+
+    [ t ] [ 2 get instructions>> first ##load-double? ] unit-test
+
+    [ t ] [ 3 get instructions>> first ##load-double? ] unit-test
+
+    [ t ] [ 4 get instructions>> first ##phi? ] unit-test
+] when
+
+: test-peephole ( insns -- insns )
+    0 test-bb
+    test-representations
+    0 get instructions>> ;
+
+! Don't convert the def site into anything but tagged-rep since
+! we might lose precision
+5 \ vreg-counter set-global
+
+[ f ] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##tagged>integer f 2 1 }
+        T{ ##add-float f 3 0 0 }
+        T{ ##store-memory-imm f 3 2 0 float-rep f }
+        T{ ##store-memory-imm f 3 2 4 float-rep f }
+        T{ ##mul-float f 4 0 0 }
+        T{ ##replace f 4 D 0 }
+    } test-peephole
+    [ ##single>double-float? ] any?
+] unit-test
+
+! Converting a ##load-integer into a ##load-tagged
+[
+    V{
+        T{ ##load-tagged f 1 $[ 100 tag-fixnum ] }
+        T{ ##replace f 1 D 0 }
+    }
+] [
+    V{
+        T{ ##load-integer f 1 100 }
+        T{ ##replace f 1 D 0 }
+    } test-peephole
+] unit-test
+
+! Peephole optimization if input to ##shl-imm is tagged
+3 \ vreg-counter set-global
+
+[
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##sar-imm f 2 1 1 }
+        T{ ##add f 4 2 2 }
+        T{ ##shl-imm f 3 4 $[ tag-bits get ] }
+        T{ ##replace f 3 D 0 }
+    }
+] [
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##shl-imm f 2 1 3 }
+        T{ ##add f 3 2 2 }
+        T{ ##replace f 3 D 0 }
+    } test-peephole
+] unit-test
+
+3 \ vreg-counter set-global
+
+[
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##shl-imm f 2 1 $[ 10 tag-bits get - ] }
+        T{ ##add f 4 2 2 }
+        T{ ##shl-imm f 3 4 $[ tag-bits get ] }
+        T{ ##replace f 3 D 0 }
+    }
+] [
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##shl-imm f 2 1 10 }
+        T{ ##add f 3 2 2 }
+        T{ ##replace f 3 D 0 }
+    } test-peephole
+] unit-test
+
+[
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##copy f 2 1 int-rep }
+        T{ ##add f 5 2 2 }
+        T{ ##shl-imm f 3 5 $[ tag-bits get ] }
+        T{ ##replace f 3 D 0 }
+    }
+] [
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##shl-imm f 2 1 $[ tag-bits get ] }
+        T{ ##add f 3 2 2 }
+        T{ ##replace f 3 D 0 }
+    } test-peephole
+] unit-test
+
+! Peephole optimization if output of ##shl-imm needs to be tagged
+[
+    V{
+        T{ ##load-integer f 1 100 }
+        T{ ##shl-imm f 2 1 $[ 3 tag-bits get + ] }
+        T{ ##replace f 2 D 0 }
+    }
+] [
+    V{
+        T{ ##load-integer f 1 100 }
+        T{ ##shl-imm f 2 1 3 }
+        T{ ##replace f 2 D 0 }
+    } test-peephole
+] unit-test
+
+! Peephole optimization if both input and output of ##shl-imm
+! needs to be tagged
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##shl-imm f 1 0 3 }
+        T{ ##replace f 1 D 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##shl-imm f 1 0 3 }
+        T{ ##replace f 1 D 0 }
+    } test-peephole
+] unit-test
+
+6 \ vreg-counter set-global
+
+! Peephole optimization if input to ##sar-imm is tagged
+[
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##sar-imm f 7 1 $[ 3 tag-bits get + ] }
+        T{ ##shl-imm f 2 7 $[ tag-bits get ] }
+        T{ ##replace f 2 D 0 }
+    }
+] [
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##sar-imm f 2 1 3 }
+        T{ ##replace f 2 D 0 }
+    } test-peephole
+] unit-test
+
+! Tag/untag elimination
+[
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##add-imm f 2 1 $[ 100 tag-fixnum ] }
+        T{ ##replace f 2 D 0 }
+    }
+] [
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##add-imm f 2 1 100 }
+        T{ ##replace f 2 D 0 }
+    } test-peephole
+] unit-test
+
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##add f 2 0 1 }
+        T{ ##replace f 2 D 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##add f 2 0 1 }
+        T{ ##replace f 2 D 0 }
+    } test-peephole
+] unit-test
+
+! Make sure we don't exceed immediate bounds
+cpu x86.64? [
+    4 \ vreg-counter set-global
+
+    [
+        V{
+            T{ ##peek f 0 D 0 }
+            T{ ##sar-imm f 5 0 $[ tag-bits get ] }
+            T{ ##add-imm f 6 5 $[ 30 2^ ] }
+            T{ ##shl-imm f 2 6 $[ tag-bits get ] }
+            T{ ##replace f 2 D 0 }
+        }
+    ] [
+        V{
+            T{ ##peek f 0 D 0 }
+            T{ ##add-imm f 2 0 $[ 30 2^ ] }
+            T{ ##replace f 2 D 0 }
+        } test-peephole
+    ] unit-test
+
+    [
+        V{
+            T{ ##load-integer f 0 100 }
+            T{ ##mul-imm f 7 0 $[ 30 2^ ] }
+            T{ ##shl-imm f 1 7 $[ tag-bits get ] }
+            T{ ##replace f 1 D 0 }
+        }
+    ] [
+        V{
+            T{ ##load-integer f 0 100 }
+            T{ ##mul-imm f 1 0 $[ 30 2^ ] }
+            T{ ##replace f 1 D 0 }
+        } test-peephole
+    ] unit-test
+] when
+
+! Tag/untag elimination for ##mul-imm
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##mul-imm f 1 0 100 }
+        T{ ##replace f 1 D 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##mul-imm f 1 0 100 }
+        T{ ##replace f 1 D 0 }
+    } test-peephole
+] unit-test
+
+4 \ vreg-counter set-global
+
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##sar-imm f 5 1 $[ tag-bits get ] }
+        T{ ##add-imm f 2 5 30 }
+        T{ ##mul-imm f 3 2 $[ 100 tag-fixnum ] }
+        T{ ##replace f 3 D 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##add-imm f 2 1 30 }
+        T{ ##mul-imm f 3 2 100 }
+        T{ ##replace f 3 D 0 }
+    } test-peephole
+] unit-test
+
+! Tag/untag elimination for ##compare-integer
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##compare-integer f 2 0 1 cc= }
+        T{ ##replace f 2 D 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##compare-integer f 2 0 1 cc= }
+        T{ ##replace f 2 D 0 }
+    } test-peephole
+] unit-test
+
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##compare-integer-branch f 0 1 cc= }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##compare-integer-branch f 0 1 cc= }
+    } test-peephole
+] unit-test
+
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##compare-integer-imm-branch f 0 $[ 10 tag-fixnum ] cc= }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##compare-integer-imm-branch f 0 10 cc= }
+    } test-peephole
+] unit-test
+
+! Tag/untag elimination for ##neg
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##neg f 1 0 }
+        T{ ##replace f 1 D 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##neg f 1 0 }
+        T{ ##replace f 1 D 0 }
+    } test-peephole
+] unit-test
+
+4 \ vreg-counter set-global
+
+[
+    V{
+        T{ ##peek f 5 D 0 }
+        T{ ##sar-imm f 0 5 $[ tag-bits get ] }
+        T{ ##peek f 6 D 1 }
+        T{ ##sar-imm f 1 6 $[ tag-bits get ] }
+        T{ ##mul f 2 0 1 }
+        T{ ##mul-imm f 3 2 -16 }
+        T{ ##replace f 3 D 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##mul f 2 0 1 }
+        T{ ##neg f 3 2 }
+        T{ ##replace f 3 D 0 }
+    } test-peephole
+] unit-test
+
+! Tag/untag elimination for ##not
+2 \ vreg-counter set-global
+
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##not f 3 0 }
+        T{ ##xor-imm f 1 3 $[ tag-mask get ] }
+        T{ ##replace f 1 D 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##not f 1 0 }
+        T{ ##replace f 1 D 0 }
+    } test-peephole
+] unit-test

basis/compiler/cfg/representations/representations.factor

@@ -1,332 +1,29 @@
-! Copyright (C) 2009 Slava Pestov
+! Copyright (C) 2009, 2010 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel fry accessors sequences assocs sets namespaces
+USING: combinators
-arrays combinators combinators.short-circuit math make locals
-deques dlists layouts byte-arrays cpu.architecture
-compiler.utilities
-compiler.constants
 compiler.cfg
-compiler.cfg.rpo
-compiler.cfg.hats
 compiler.cfg.registers
-compiler.cfg.instructions
+compiler.cfg.predecessors
-compiler.cfg.def-use
-compiler.cfg.utilities
 compiler.cfg.loop-detection
-compiler.cfg.renaming.functor
+compiler.cfg.representations.rewrite
-compiler.cfg.representations.preferred ;
+compiler.cfg.representations.peephole
-FROM: namespaces => set ;
+compiler.cfg.representations.selection
+compiler.cfg.representations.coalescing ;
 IN: compiler.cfg.representations
 
-! Virtual register representation selection.
+! Virtual register representation selection. This is where
-
+! decisions about integer tagging and float and vector boxing
-ERROR: bad-conversion dst src dst-rep src-rep ;
+! are made. The appropriate conversion operations inserted
-
+! after a cost analysis.
-GENERIC: emit-box ( dst src rep -- )
-GENERIC: emit-unbox ( dst src rep -- )
-
-M:: float-rep emit-box ( dst src rep -- )
-    double-rep next-vreg-rep :> temp
-    temp src ##single>double-float
-    dst temp double-rep emit-box ;
-
-M:: float-rep emit-unbox ( dst src rep -- )
-    double-rep next-vreg-rep :> temp
-    temp src double-rep emit-unbox
-    dst temp ##double>single-float ;
-
-M: double-rep emit-box
-    drop
-    [ drop 16 float int-rep next-vreg-rep ##allot ]
-    [ float-offset swap ##set-alien-double ]
-    2bi ;
-
-M: double-rep emit-unbox
-    drop float-offset ##alien-double ;
-
-M:: vector-rep emit-box ( dst src rep -- )
-    int-rep next-vreg-rep :> temp
-    dst 16 2 cells + byte-array int-rep next-vreg-rep ##allot
-    temp 16 tag-fixnum ##load-immediate
-    temp dst 1 byte-array type-number ##set-slot-imm
-    dst byte-array-offset src rep ##set-alien-vector ;
-
-M: vector-rep emit-unbox
-    [ byte-array-offset ] dip ##alien-vector ;
-
-M:: scalar-rep emit-box ( dst src rep -- )
-    int-rep next-vreg-rep :> temp
-    temp src rep ##scalar>integer
-    dst temp tag-bits get ##shl-imm ;
-
-M:: scalar-rep emit-unbox ( dst src rep -- )
-    int-rep next-vreg-rep :> temp
-    temp src tag-bits get ##sar-imm
-    dst temp rep ##integer>scalar ;
-
-: emit-conversion ( dst src dst-rep src-rep -- )
-    {
-        { [ 2dup eq? ] [ drop ##copy ] }
-        { [ dup int-rep eq? ] [ drop emit-unbox ] }
-        { [ over int-rep eq? ] [ nip emit-box ] }
-        [
-            2dup 2array {
-                { { double-rep float-rep } [ 2drop ##single>double-float ] }
-                { { float-rep double-rep } [ 2drop ##double>single-float ] }
-                ! Punning SIMD vector types? Naughty naughty! But
-                ! it is allowed... otherwise bail out.
-                [
-                    drop 2dup [ reg-class-of ] bi@ eq?
-                    [ drop ##copy ] [ bad-conversion ] if
-                ]
-            } case
-        ]
-    } cond ;
-
-<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? ] [ ##load-constant? ] bi or
-                [ 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.
-
-! Mapping from vreg,rep pairs to vregs
-SYMBOL: alternatives
-
-:: 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.
-    preferred required eq? [ src ] [
-        src required alternatives get [
-            required next-vreg-rep :> new-src
-            [ new-src ] 2dip preferred emit-conversion
-            new-src
-        ] 2cache
-    ] if ;
-
-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) ( ..a vreg required quot: ( ..a vreg preferred required -- ..b ) -- ..b )
-    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! drop
-        [ 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 ;
-
-! When a literal zeroes/ones vector is unboxed, we replace the ##load-reference
-! with a ##zero-vector or ##fill-vector instruction since this is more efficient.
-: convert-to-zero-vector? ( insn -- ? )
-    {
-        [ dst>> rep-of vector-rep? ]
-        [ obj>> B{ 0 0 0 0  0 0 0 0  0 0 0 0  0 0 0 0 } = ]
-    } 1&& ;
-: convert-to-fill-vector? ( insn -- ? )
-    {
-        [ dst>> rep-of vector-rep? ]
-        [ obj>> B{ 255 255 255 255  255 255 255 255  255 255 255 255  255 255 255 255 } = ]
-    } 1&& ;
-
-: (convert-to-zero/fill-vector) ( insn -- dst rep )
-    dst>> dup rep-of ; inline
-
-: conversions-for-load-insn ( insn -- ?insn )
-    {
-        {
-            [ dup convert-to-zero-vector? ]
-            [ (convert-to-zero/fill-vector) ##zero-vector f ]
-        }
-        {
-            [ dup convert-to-fill-vector? ]
-            [ (convert-to-zero/fill-vector) ##fill-vector f ]
-        }
-        [ ]
-    } cond ;
-
-M: ##load-reference conversions-for-insn
-    conversions-for-load-insn [ call-next-method ] when* ;
-
-M: ##load-constant conversions-for-insn
-    conversions-for-load-insn [ call-next-method ] when* ;
-
-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 ] [
-        [
-            [
-                H{ } clone alternatives set
-                [ 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
+    needs-predecessors
 
     {
+        [ compute-components ]
         [ compute-possibilities ]
         [ compute-representations ]
         [ insert-conversions ]
         [ ]
-    } cleave
+    } cleave ;
-    representations get cfg get (>>reps) ;

basis/compiler/cfg/representations/rewrite/authors.txt

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

basis/compiler/cfg/representations/rewrite/rewrite.factor

@@ -0,0 +1,104 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators
+combinators.short-circuit layouts kernel locals make math
+namespaces sequences
+compiler.cfg.instructions
+compiler.cfg.registers
+compiler.cfg.renaming.functor
+compiler.cfg.representations.conversion
+compiler.cfg.representations.preferred
+compiler.cfg.rpo
+compiler.cfg.utilities
+cpu.architecture ;
+IN: compiler.cfg.representations.rewrite
+
+! Insert conversions. This introduces new temporaries, so we need
+! to rename opearands too.
+
+! Mapping from vreg,rep pairs to vregs
+SYMBOL: alternatives
+
+:: (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.
+    preferred required eq? [ src ] [
+        src required alternatives get [
+            required next-vreg-rep :> new-src
+            [ new-src ] 2dip preferred emit-conversion
+            new-src
+        ] 2cache
+    ] if ;
+
+SYMBOLS: renaming-set needs-renaming? ;
+
+: init-renaming-set ( -- )
+    needs-renaming? off
+    renaming-set get delete-all ;
+
+: 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 -- new-vreg ) -- )
+    vreg rep-of :> preferred
+    preferred required eq?
+    [ vreg no-renaming ]
+    [ vreg vreg preferred required quot call record-renaming ] if ; inline
+
+: emit-use-conversion ( insn -- )
+    [ [ (emit-use-conversion) ] (compute-renaming-set) ] each-use-rep ;
+
+: no-use-conversion ( insn -- )
+    [ drop no-renaming ] each-use-rep ;
+
+: emit-def-conversion ( insn -- )
+    [ [ (emit-def-conversion) ] (compute-renaming-set) ] each-def-rep ;
+
+: no-def-conversion ( insn -- )
+    [ drop no-renaming ] each-def-rep ;
+
+: 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! drop
+        [ convert-insn-uses ] [ convert-insn-defs ] bi
+        renaming-set get length 0 assert=
+    ] [ drop ] if ;
+
+GENERIC: conversions-for-insn ( insn -- )
+
+M: ##phi conversions-for-insn , ;
+
+M: ##copy conversions-for-insn , ;
+
+M: insn conversions-for-insn , ;
+
+: conversions-for-block ( bb -- )
+    dup kill-block? [ drop ] [
+        [
+            [
+                H{ } clone alternatives set
+                [ conversions-for-insn ] each
+            ] V{ } make
+        ] change-instructions drop
+    ] if ;
+
+: insert-conversions ( cfg -- )
+    V{ } clone renaming-set set
+    [ conversions-for-block ] each-basic-block ;

basis/compiler/cfg/representations/selection/authors.txt

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

basis/compiler/cfg/representations/selection/selection.factor

@@ -0,0 +1,150 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs byte-arrays combinators
+disjoint-sets fry kernel locals math namespaces sequences sets
+compiler.cfg
+compiler.cfg.instructions
+compiler.cfg.loop-detection
+compiler.cfg.registers
+compiler.cfg.representations.preferred
+compiler.cfg.representations.coalescing
+compiler.cfg.rpo
+compiler.cfg.utilities
+compiler.utilities
+cpu.architecture ;
+FROM: namespaces => set ;
+IN: compiler.cfg.representations.selection
+
+! vregs which must be tagged at the definition site because
+! there is at least one usage that is not int-rep. If all usages
+! are int-rep it is safe to untag at the definition site.
+SYMBOL: tagged-vregs
+
+SYMBOL: vreg-reps
+
+: handle-def ( vreg rep -- )
+    swap vreg>scc vreg-reps get
+    [ [ intersect ] when* ] change-at ;
+
+: handle-use ( vreg rep -- )
+    int-rep eq? [ drop ] [ vreg>scc tagged-vregs get adjoin ] if ;
+
+GENERIC: (collect-vreg-reps) ( insn -- )
+
+M: ##load-reference (collect-vreg-reps)
+    [ dst>> ] [ obj>> ] bi {
+        { [ dup float? ] [ drop { float-rep double-rep } ] }
+        { [ dup byte-array? ] [ drop vector-reps ] }
+        [ drop { } ]
+    } cond handle-def ;
+
+M: vreg-insn (collect-vreg-reps)
+    [ [ handle-use ] each-use-rep ]
+    [ [ 1array handle-def ] each-def-rep ]
+    [ [ 1array handle-def ] each-temp-rep ]
+    tri ;
+
+M: insn (collect-vreg-reps) drop ;
+
+: collect-vreg-reps ( cfg -- )
+    H{ } clone vreg-reps set
+    HS{ } clone tagged-vregs set
+    [ [ (collect-vreg-reps) ] each-non-phi ] each-basic-block ;
+
+SYMBOL: possibilities
+
+: possible-reps ( vreg reps -- vreg reps )
+    { tagged-rep } union
+    2dup [ tagged-vregs get in? not ] [ { tagged-rep } = ] bi* and
+    [ drop { tagged-rep int-rep } ] [ ] if ;
+
+: compute-possibilities ( cfg -- )
+    collect-vreg-reps
+    vreg-reps get [ possible-reps ] assoc-map possibilities set ;
+
+! 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 ( -- )
+    ! Initialize cost as 0 for each possibility.
+    possibilities get [ [ 0 ] H{ } map>assoc ] assoc-map costs set ;
+
+: 10^ ( n -- x ) 10 <repetition> product ;
+
+: increase-cost ( rep scc factor -- )
+    ! Increase cost of keeping vreg in rep, making a choice of rep less
+    ! likely. If the rep is not in the cost alist, it means this
+    ! representation is prohibited.
+    [ costs get at 2dup key? ] dip
+    '[ [ current-loop-nesting 10^ _ * + ] change-at ] [ 2drop ] if ;
+
+:: increase-costs ( vreg preferred factor -- )
+    vreg vreg>scc :> scc
+    scc possibilities get at [
+        dup preferred eq? [ drop ] [ scc factor increase-cost ] if
+    ] each ; inline
+
+UNION: inert-tag-untag-insn
+##add
+##sub
+##and
+##or
+##xor
+##min
+##max ;
+
+UNION: inert-arithmetic-tag-untag-insn
+##add-imm
+##sub-imm ;
+
+UNION: inert-bitwise-tag-untag-insn
+##and-imm
+##or-imm
+##xor-imm ;
+
+GENERIC: has-peephole-opts? ( insn -- ? )
+
+M: insn has-peephole-opts? drop f ;
+M: ##load-integer has-peephole-opts? drop t ;
+M: ##load-reference has-peephole-opts? drop t ;
+M: ##neg has-peephole-opts? drop t ;
+M: ##not has-peephole-opts? drop t ;
+M: inert-tag-untag-insn has-peephole-opts? drop t ;
+M: inert-arithmetic-tag-untag-insn has-peephole-opts? drop t ;
+M: inert-bitwise-tag-untag-insn has-peephole-opts? drop t ;
+M: ##mul-imm has-peephole-opts? drop t ;
+M: ##shl-imm has-peephole-opts? drop t ;
+M: ##shr-imm has-peephole-opts? drop t ;
+M: ##sar-imm has-peephole-opts? drop t ;
+M: ##compare-integer-imm has-peephole-opts? drop t ;
+M: ##compare-integer has-peephole-opts? drop t ;
+M: ##compare-integer-imm-branch has-peephole-opts? drop t ;
+M: ##compare-integer-branch has-peephole-opts? drop t ;
+
+GENERIC: compute-insn-costs ( insn -- )
+
+M: insn compute-insn-costs drop ;
+
+M: vreg-insn compute-insn-costs
+    dup has-peephole-opts? 2 5 ? '[ _ increase-costs ] each-rep ;
+
+: compute-costs ( cfg -- )
+    init-costs
+    [
+        [ basic-block set ]
+        [ [ compute-insn-costs ] each-non-phi ] bi
+    ] each-basic-block ;
+
+! For every vreg, compute preferred representation, that minimizes costs.
+: minimize-costs ( costs -- representations )
+    [ nip assoc-empty? not ] assoc-filter
+    [ >alist alist-min first ] assoc-map ;
+
+: compute-representations ( cfg -- )
+    compute-costs costs get minimize-costs
+    [ components get [ disjoint-set-members ] keep ] dip
+    '[ dup _ representative _ at ] H{ } map>assoc
+    representations set ;

basis/compiler/cfg/rpo/rpo.factor

@@ -39,8 +39,8 @@ SYMBOL: visited
     [ drop basic-block set ]
     [ change-instructions drop ] 2bi ; inline
 
-: local-optimization ( ... cfg quot: ( ... insns -- ... insns' ) -- ... cfg' )
+: simple-optimization ( ... cfg quot: ( ... insns -- ... insns' ) -- ... )
-    dupd '[ _ optimize-basic-block ] each-basic-block ; inline
+    '[ _ optimize-basic-block ] each-basic-block ; inline
 
 : needs-post-order ( cfg -- cfg' )
     dup post-order drop ;

basis/compiler/cfg/save-contexts/save-contexts.factor

@@ -10,6 +10,7 @@ IN: compiler.cfg.save-contexts
 : needs-save-context? ( insns -- ? )
     [
         {
+            [ ##call-gc? ]
             [ ##unary-float-function? ]
             [ ##binary-float-function? ]
             [ ##alien-invoke? ]
@@ -20,8 +21,8 @@ IN: compiler.cfg.save-contexts
 
 : insert-save-context ( bb -- )
     dup instructions>> dup needs-save-context? [
-        int-rep next-vreg-rep
+        tagged-rep next-vreg-rep
-        int-rep next-vreg-rep
+        tagged-rep next-vreg-rep
         \ ##save-context new-insn prefix
         >>instructions drop
     ] [ 2drop ] if ;

basis/compiler/cfg/ssa/construction/construction-tests.factor

@@ -13,19 +13,19 @@ IN: compiler.cfg.ssa.construction.tests
 reset-counters
 
 V{
-    T{ ##load-immediate f 1 100 }
+    T{ ##load-integer f 1 100 }
     T{ ##add-imm f 2 1 50 }
     T{ ##add-imm f 2 2 10 }
     T{ ##branch }
 } 0 test-bb
 
 V{
-    T{ ##load-immediate f 3 3 }
+    T{ ##load-integer f 3 3 }
     T{ ##branch }
 } 1 test-bb
 
 V{
-    T{ ##load-immediate f 3 4 }
+    T{ ##load-integer f 3 4 }
     T{ ##branch }
 } 2 test-bb
 
@@ -48,7 +48,7 @@ V{
 
 [
     V{
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##add-imm f 2 1 50 }
         T{ ##add-imm f 3 2 10 }
         T{ ##branch }
@@ -57,14 +57,14 @@ V{
 
 [
     V{
-        T{ ##load-immediate f 4 3 }
+        T{ ##load-integer f 4 3 }
         T{ ##branch }
     }
 ] [ 1 get instructions>> ] unit-test
 
 [
     V{
-        T{ ##load-immediate f 5 4 }
+        T{ ##load-integer f 5 4 }
         T{ ##branch }
     }
 ] [ 2 get instructions>> ] unit-test

basis/compiler/cfg/ssa/cssa/cssa.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs kernel locals fry sequences
 cpu.architecture
@@ -6,8 +6,7 @@ compiler.cfg.rpo
 compiler.cfg.def-use
 compiler.cfg.utilities
 compiler.cfg.registers
-compiler.cfg.instructions
+compiler.cfg.instructions ;
-compiler.cfg.representations ;
 IN: compiler.cfg.ssa.cssa
 
 ! Convert SSA to conventional SSA. This pass runs after representation
@@ -24,7 +23,7 @@ IN: compiler.cfg.ssa.cssa
 :: insert-copy ( bb src rep -- bb dst )
     bb src insert-copy? [
         rep next-vreg-rep :> dst
-        bb [ dst src rep src rep-of emit-conversion ] add-instructions
+        bb [ dst src rep ##copy ] add-instructions
         bb dst
     ] [ bb src ] if ;
 

basis/compiler/cfg/ssa/destruction/destruction.factor

@@ -1,11 +1,11 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs fry kernel namespaces
 sequences sequences.deep
 sets vectors
+cpu.architecture
 compiler.cfg.rpo
 compiler.cfg.def-use
-compiler.cfg.renaming
 compiler.cfg.registers
 compiler.cfg.dominance
 compiler.cfg.instructions
@@ -18,7 +18,20 @@ compiler.utilities ;
 FROM: namespaces => set ;
 IN: compiler.cfg.ssa.destruction
 
-! Maps vregs to leaders.
+! Because of the design of the register allocator, this pass
+! has three peculiar properties.
+!
+! 1) Instead of renaming vreg usages in the CFG, a map from
+! vregs to canonical representatives is computed. This allows
+! the register allocator to use the original SSA names to get
+! reaching definitions.
+! 2) Useless ##copy instructions, and all ##phi instructions,
+! are eliminated, so the register allocator does not have to
+! remove any redundant operations.
+! 3) A side effect of running this pass is that SSA liveness
+! information is computed, so the register allocator does not
+! need to compute it again.
+
 SYMBOL: leader-map
 
 : leader ( vreg -- vreg' ) leader-map get compress-path ;
@@ -28,12 +41,15 @@ SYMBOL: class-element-map
 
 : class-elements ( vreg -- elts ) class-element-map get at ;
 
+<PRIVATE
+
 ! Sequence of vreg pairs
 SYMBOL: copies
 
 : init-coalescing ( -- )
-    H{ } clone leader-map set
+    defs get keys
-    H{ } clone class-element-map set
+    [ [ dup ] H{ } map>assoc leader-map set ]
+    [ [ dup 1vector ] H{ } map>assoc class-element-map set ] bi
     V{ } clone copies set ;
 
 : classes-interfere? ( vreg1 vreg2 -- ? )
@@ -56,25 +72,27 @@ SYMBOL: copies
         2bi
     ] if ;
 
-: introduce-vreg ( vreg -- )
-    [ leader-map get conjoin ]
-    [ [ 1vector ] keep class-element-map get set-at ] bi ;
-
 GENERIC: prepare-insn ( insn -- )
 
 : try-to-coalesce ( dst src -- ) 2array copies get push ;
 
 M: insn prepare-insn
+    [ temp-vregs [ leader-map get conjoin ] each ]
+    [
         [ defs-vreg ] [ uses-vregs ] bi
         2dup empty? not and [
             first
-        2dup [ rep-of ] bi@ eq?
+            2dup [ rep-of reg-class-of ] bi@ eq?
             [ try-to-coalesce ] [ 2drop ] if
-    ] [ 2drop ] if ;
+        ] [ 2drop ] if
+    ] bi ;
 
 M: ##copy prepare-insn
     [ dst>> ] [ src>> ] bi try-to-coalesce ;
 
+M: ##tagged>integer prepare-insn
+    [ dst>> ] [ src>> ] bi eliminate-copy ;
+
 M: ##phi prepare-insn
     [ dst>> ] [ inputs>> values ] bi
     [ eliminate-copy ] with each ;
@@ -84,7 +102,6 @@ M: ##phi prepare-insn
 
 : prepare-coalescing ( cfg -- )
     init-coalescing
-    defs get keys [ introduce-vreg ] each
     [ prepare-block ] each-basic-block ;
 
 : process-copies ( -- )
@@ -93,26 +110,31 @@ M: ##phi prepare-insn
         [ 2drop ] [ eliminate-copy ] if
     ] assoc-each ;
 
-: useless-copy? ( ##copy -- ? )
+GENERIC: useful-insn? ( insn -- ? )
-    dup ##copy? [ [ dst>> ] [ src>> ] bi eq? ] [ drop f ] if ;
 
-: perform-renaming ( cfg -- )
+: useful-copy? ( insn -- ? )
-    leader-map get keys [ dup leader ] H{ } map>assoc renamings set
+    [ dst>> leader ] [ src>> leader ] bi eq? not ; inline
-    [
+
-        instructions>> [
+M: ##copy useful-insn? useful-copy? ;
-            [ rename-insn-defs ]
+
-            [ rename-insn-uses ]
+M: ##tagged>integer useful-insn? useful-copy? ;
-            [ [ useless-copy? ] [ ##phi? ] bi or not ] tri
+
-        ] filter! drop
+M: ##phi useful-insn? drop f ;
-    ] each-basic-block ;
+
+M: insn useful-insn? drop t ;
+
+: cleanup-cfg ( cfg -- )
+    [ [ useful-insn? ] filter! ] simple-optimization ;
+
+PRIVATE>
 
 : destruct-ssa ( cfg -- cfg' )
     needs-dominance
 
     dup construct-cssa
     dup compute-defs
-    compute-ssa-live-sets
+    dup compute-ssa-live-sets
     dup compute-live-ranges
     dup prepare-coalescing
     process-copies
-    dup perform-renaming ;
+    dup cleanup-cfg ;

basis/compiler/cfg/ssa/interference/interference-tests.factor

@@ -9,7 +9,7 @@ IN: compiler.cfg.ssa.interference.tests
 
 : test-interference ( -- )
     cfg new 0 get >>entry
-    compute-ssa-live-sets
+    dup compute-ssa-live-sets
     dup compute-defs
     compute-live-ranges ;
 

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

@@ -1,291 +0,0 @@
-! Copyright (C) 2009 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel tools.test namespaces sequences vectors accessors sets
-arrays math.ranges assocs
-cpu.architecture
-compiler.cfg
-compiler.cfg.ssa.liveness.private
-compiler.cfg.ssa.liveness 
-compiler.cfg.debugger
-compiler.cfg.instructions
-compiler.cfg.predecessors
-compiler.cfg.registers
-compiler.cfg.dominance
-compiler.cfg.def-use ;
-IN: compiler.cfg.ssa.liveness
-
-[ t ] [ { 1 } 1 only? ] unit-test
-[ t ] [ { } 1 only? ] unit-test
-[ f ] [ { 2 1 } 1 only? ] unit-test
-[ f ] [ { 2 } 1 only? ] unit-test
-
-: test-liveness ( -- )
-    cfg new 0 get >>entry
-    dup compute-defs
-    dup compute-uses
-    needs-dominance
-    precompute-liveness ;
-
-V{
-    T{ ##peek f 0 D 0 }
-    T{ ##replace f 0 D 0 }
-    T{ ##replace f 1 D 1 }
-} 0 test-bb
-
-V{
-    T{ ##replace f 2 D 0 }
-} 1 test-bb
-
-V{
-    T{ ##replace f 3 D 0 }
-} 2 test-bb
-
-0 { 1 2 } edges
-
-[ ] [ test-liveness ] unit-test
-
-[ H{ } ] [ back-edge-targets get ] unit-test
-[ t ] [ 0 get R_q { 0 1 2 } [ get ] map unique = ] unit-test
-[ t ] [ 1 get R_q { 1 } [ get ] map unique = ] unit-test
-[ t ] [ 2 get R_q { 2 } [ get ] map unique = ] unit-test
-
-: self-T_q ( n -- ? )
-    get [ T_q ] [ 1array unique ] bi = ;
-
-[ t ] [ 0 self-T_q ] unit-test
-[ t ] [ 1 self-T_q ] unit-test
-[ t ] [ 2 self-T_q ] unit-test
-
-[ f ] [ 0 0 get live-in? ] unit-test
-[ t ] [ 1 0 get live-in? ] unit-test
-[ t ] [ 2 0 get live-in? ] unit-test
-[ t ] [ 3 0 get live-in? ] unit-test
-
-[ f ] [ 0 0 get live-out? ] unit-test
-[ f ] [ 1 0 get live-out? ] unit-test
-[ t ] [ 2 0 get live-out? ] unit-test
-[ t ] [ 3 0 get live-out? ] unit-test
-
-[ f ] [ 0 1 get live-in? ] unit-test
-[ f ] [ 1 1 get live-in? ] unit-test
-[ t ] [ 2 1 get live-in? ] unit-test
-[ f ] [ 3 1 get live-in? ] unit-test
-
-[ f ] [ 0 1 get live-out? ] unit-test
-[ f ] [ 1 1 get live-out? ] unit-test
-[ f ] [ 2 1 get live-out? ] unit-test
-[ f ] [ 3 1 get live-out? ] unit-test
-
-[ f ] [ 0 2 get live-in? ] unit-test
-[ f ] [ 1 2 get live-in? ] unit-test
-[ f ] [ 2 2 get live-in? ] unit-test
-[ t ] [ 3 2 get live-in? ] unit-test
-
-[ f ] [ 0 2 get live-out? ] unit-test
-[ f ] [ 1 2 get live-out? ] unit-test
-[ f ] [ 2 2 get live-out? ] unit-test
-[ f ] [ 3 2 get live-out? ] unit-test
-
-V{ } 0 test-bb
-V{ } 1 test-bb
-V{ } 2 test-bb
-V{ } 3 test-bb
-V{
-    T{ ##phi f 2 H{ { 2 0 } { 3 1 } } }
-} 4 test-bb
-test-diamond
-
-[ ] [ test-liveness ] unit-test
-
-[ t ] [ 0 1 get live-in? ] unit-test
-[ t ] [ 1 1 get live-in? ] unit-test
-[ f ] [ 2 1 get live-in? ] unit-test
-
-[ t ] [ 0 1 get live-out? ] unit-test
-[ t ] [ 1 1 get live-out? ] unit-test
-[ f ] [ 2 1 get live-out? ] unit-test
-
-[ t ] [ 0 2 get live-in? ] unit-test
-[ f ] [ 1 2 get live-in? ] unit-test
-[ f ] [ 2 2 get live-in? ] unit-test
-
-[ f ] [ 0 2 get live-out? ] unit-test
-[ f ] [ 1 2 get live-out? ] unit-test
-[ f ] [ 2 2 get live-out? ] unit-test
-
-[ f ] [ 0 3 get live-in? ] unit-test
-[ t ] [ 1 3 get live-in? ] unit-test
-[ f ] [ 2 3 get live-in? ] unit-test
-
-[ f ] [ 0 3 get live-out? ] unit-test
-[ f ] [ 1 3 get live-out? ] unit-test
-[ f ] [ 2 3 get live-out? ] unit-test
-
-[ f ] [ 0 4 get live-in? ] unit-test
-[ f ] [ 1 4 get live-in? ] unit-test
-[ f ] [ 2 4 get live-in? ] unit-test
-
-[ f ] [ 0 4 get live-out? ] unit-test
-[ f ] [ 1 4 get live-out? ] unit-test
-[ f ] [ 2 4 get live-out? ] unit-test
-
-! This is the CFG in Figure 3 from the paper
-V{ } 0 test-bb
-V{ } 1 test-bb
-0 1 edge
-V{ } 2 test-bb
-1 2 edge
-V{
-    T{ ##peek f 0 D 0 }
-    T{ ##peek f 1 D 0 }
-    T{ ##peek f 2 D 0 }
-} 3 test-bb
-V{ } 11 test-bb
-2 { 3 11 } edges
-V{
-    T{ ##replace f 0 D 0 }
-} 4 test-bb
-V{ } 8 test-bb
-3 { 8 4 } edges
-V{
-    T{ ##replace f 1 D 0 }
-} 9 test-bb
-8 9 edge
-V{
-    T{ ##replace f 2 D 0 }
-} 5 test-bb
-4 5 edge
-V{ } 10 test-bb
-V{ } 6 test-bb
-5 6 edge
-9 { 6 10 } edges
-V{ } 7 test-bb
-6 { 5 7 } edges
-10 8 edge
-7 2 edge
-
-[ ] [ test-liveness ] unit-test
-
-[ t ] [ 1 get R_q 1 11 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 2 get R_q 2 11 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 3 get R_q 3 10 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 4 get R_q 4 7 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 5 get R_q 5 7 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 6 get R_q 6 7 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 7 get R_q 7 7 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 8 get R_q 6 10 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 9 get R_q 8 6 10 [a,b] remove [ get ] map unique = ] unit-test
-[ t ] [ 10 get R_q 10 10 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 11 get R_q 11 11 [a,b] [ get ] map unique = ] unit-test
-
-[ t ] [ 1 get T_q 1 get 1array unique = ] unit-test
-[ t ] [ 2 get T_q 2 get 1array unique = ] unit-test
-[ t ] [ 3 get T_q 3 get 2 get 2array unique = ] unit-test
-[ t ] [ 4 get T_q 4 get 2 get 2array unique = ] unit-test
-[ t ] [ 5 get T_q 5 get 2 get 2array unique = ] unit-test
-[ t ] [ 6 get T_q { 6 2 5 } [ get ] map unique = ] unit-test
-[ t ] [ 7 get T_q { 7 2 } [ get ] map unique = ] unit-test
-[ t ] [ 8 get T_q { 8 2 5 } [ get ] map unique = ] unit-test
-[ t ] [ 9 get T_q { 2 5 8 9 } [ get ] map unique = ] unit-test
-[ t ] [ 10 get T_q { 2 5 8 10 } [ get ] map unique = ] unit-test
-[ t ] [ 11 get T_q 11 get 1array unique = ] unit-test
-
-[ f ] [ 1 get back-edge-target? ] unit-test
-[ t ] [ 2 get back-edge-target? ] unit-test
-[ f ] [ 3 get back-edge-target? ] unit-test
-[ f ] [ 4 get back-edge-target? ] unit-test
-[ t ] [ 5 get back-edge-target? ] unit-test
-[ f ] [ 6 get back-edge-target? ] unit-test
-[ f ] [ 7 get back-edge-target? ] unit-test
-[ t ] [ 8 get back-edge-target? ] unit-test
-[ f ] [ 9 get back-edge-target? ] unit-test
-[ f ] [ 10 get back-edge-target? ] unit-test
-[ f ] [ 11 get back-edge-target? ] unit-test
-
-[ f ] [ 0 1 get live-in? ] unit-test
-[ f ] [ 1 1 get live-in? ] unit-test
-[ f ] [ 2 1 get live-in? ] unit-test
-
-[ f ] [ 0 1 get live-out? ] unit-test
-[ f ] [ 1 1 get live-out? ] unit-test
-[ f ] [ 2 1 get live-out? ] unit-test
-
-[ f ] [ 0 2 get live-in? ] unit-test
-[ f ] [ 1 2 get live-in? ] unit-test
-[ f ] [ 2 2 get live-in? ] unit-test
-
-[ f ] [ 0 2 get live-out? ] unit-test
-[ f ] [ 1 2 get live-out? ] unit-test
-[ f ] [ 2 2 get live-out? ] unit-test
-
-[ f ] [ 0 3 get live-in? ] unit-test
-[ f ] [ 1 3 get live-in? ] unit-test
-[ f ] [ 2 3 get live-in? ] unit-test
-
-[ t ] [ 0 3 get live-out? ] unit-test
-[ t ] [ 1 3 get live-out? ] unit-test
-[ t ] [ 2 3 get live-out? ] unit-test
-
-[ t ] [ 0 4 get live-in? ] unit-test
-[ f ] [ 1 4 get live-in? ] unit-test
-[ t ] [ 2 4 get live-in? ] unit-test
-
-[ f ] [ 0 4 get live-out? ] unit-test
-[ f ] [ 1 4 get live-out? ] unit-test
-[ t ] [ 2 4 get live-out? ] unit-test
-
-[ f ] [ 0 5 get live-in? ] unit-test
-[ f ] [ 1 5 get live-in? ] unit-test
-[ t ] [ 2 5 get live-in? ] unit-test
-
-[ f ] [ 0 5 get live-out? ] unit-test
-[ f ] [ 1 5 get live-out? ] unit-test
-[ t ] [ 2 5 get live-out? ] unit-test
-
-[ f ] [ 0 6 get live-in? ] unit-test
-[ f ] [ 1 6 get live-in? ] unit-test
-[ t ] [ 2 6 get live-in? ] unit-test
-
-[ f ] [ 0 6 get live-out? ] unit-test
-[ f ] [ 1 6 get live-out? ] unit-test
-[ t ] [ 2 6 get live-out? ] unit-test
-
-[ f ] [ 0 7 get live-in? ] unit-test
-[ f ] [ 1 7 get live-in? ] unit-test
-[ f ] [ 2 7 get live-in? ] unit-test
-
-[ f ] [ 0 7 get live-out? ] unit-test
-[ f ] [ 1 7 get live-out? ] unit-test
-[ f ] [ 2 7 get live-out? ] unit-test
-
-[ f ] [ 0 8 get live-in? ] unit-test
-[ t ] [ 1 8 get live-in? ] unit-test
-[ t ] [ 2 8 get live-in? ] unit-test
-
-[ f ] [ 0 8 get live-out? ] unit-test
-[ t ] [ 1 8 get live-out? ] unit-test
-[ t ] [ 2 8 get live-out? ] unit-test
-
-[ f ] [ 0 9 get live-in? ] unit-test
-[ t ] [ 1 9 get live-in? ] unit-test
-[ t ] [ 2 9 get live-in? ] unit-test
-
-[ f ] [ 0 9 get live-out? ] unit-test
-[ t ] [ 1 9 get live-out? ] unit-test
-[ t ] [ 2 9 get live-out? ] unit-test
-
-[ f ] [ 0 10 get live-in? ] unit-test
-[ t ] [ 1 10 get live-in? ] unit-test
-[ t ] [ 2 10 get live-in? ] unit-test
-
-[ f ] [ 0 10 get live-out? ] unit-test
-[ t ] [ 1 10 get live-out? ] unit-test
-[ t ] [ 2 10 get live-out? ] unit-test
-
-[ f ] [ 0 11 get live-in? ] unit-test
-[ f ] [ 1 11 get live-in? ] unit-test
-[ f ] [ 2 11 get live-in? ] unit-test
-
-[ f ] [ 0 11 get live-out? ] unit-test
-[ f ] [ 1 11 get live-out? ] unit-test
-[ f ] [ 2 11 get live-out? ] unit-test

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

@@ -1,130 +0,0 @@
-! Copyright (C) 2009 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences assocs accessors
-namespaces fry math sets combinators locals
-compiler.cfg.rpo
-compiler.cfg.dominance
-compiler.cfg.def-use
-compiler.cfg.instructions ;
-FROM: namespaces => set ;
-IN: compiler.cfg.ssa.liveness
-
-! Liveness checking on SSA IR, as described in
-! "Fast Liveness Checking for SSA-Form Programs", Sebastian Hack et al.
-! http://hal.archives-ouvertes.fr/docs/00/19/22/19/PDF/fast_liveness.pdf
-
-<PRIVATE
-
-! The sets T_q and R_q are described there
-SYMBOL: T_q-sets
-SYMBOL: R_q-sets
-
-! Targets of back edges
-SYMBOL: back-edge-targets
-
-: T_q ( q -- T_q )
-    T_q-sets get at ;
-
-: R_q ( q -- R_q )
-    R_q-sets get at ;
-
-: back-edge-target? ( block -- ? )
-    back-edge-targets get key? ;
-
-: next-R_q ( q -- R_q )
-    [ ] [ successors>> ] [ number>> ] tri
-    '[ number>> _ >= ] filter
-    [ R_q ] map assoc-combine
-    [ conjoin ] keep ;
-
-: set-R_q ( q -- )
-    [ next-R_q ] keep R_q-sets get set-at ;
-
-: set-back-edges ( q -- )
-    [ successors>> ] [ number>> ] bi '[
-        dup number>> _ < 
-        [ back-edge-targets get conjoin ] [ drop ] if
-    ] each ;
-
-: init-R_q ( -- )
-    H{ } clone R_q-sets set
-    H{ } clone back-edge-targets set ;
-
-: compute-R_q ( cfg -- )
-    init-R_q
-    post-order [
-        [ set-R_q ] [ set-back-edges ] bi
-    ] each ;
-
-! This algorithm for computing T_q uses equation (1)
-! but not the faster algorithm described in the paper
-
-: back-edges-from ( q -- edges )
-    R_q keys [
-        [ successors>> ] [ number>> ] bi
-        '[ number>> _ < ] filter
-    ] gather ;
-
-: T^_q ( q -- T^_q )
-    [ back-edges-from ] [ R_q ] bi
-    '[ _ key? not ] filter ;
-
-: next-T_q ( q -- T_q )
-    dup dup T^_q [ next-T_q keys ] map 
-    concat unique [ conjoin ] keep
-    [ swap T_q-sets get set-at ] keep ;
-
-: compute-T_q ( cfg -- )
-    H{ } T_q-sets set
-    [ next-T_q drop ] each-basic-block ;
-
-PRIVATE>
-
-: precompute-liveness ( cfg -- )
-    [ compute-R_q ] [ compute-T_q ] bi ;
-
-<PRIVATE
-
-! This doesn't take advantage of ordering T_q,a so you 
-! only have to check one if the CFG is reducible.
-! It should be changed to be more efficient.
-
-: only? ( seq obj -- ? )
-    '[ _ eq? ] all? ;
-
-: strictly-dominates? ( bb1 bb2 -- ? )
-    [ dominates? ] [ eq? not ] 2bi and ;
-
-: T_q,a ( a q -- T_q,a )
-    ! This could take advantage of the structure of dominance,
-    ! but probably I'll replace it with the algorithm that works
-    ! on reducible CFGs anyway
-    T_q keys swap def-of 
-    [ '[ _ swap strictly-dominates? ] filter ] when* ;
-
-: live? ( vreg node quot -- ? )
-    [ [ T_q,a ] [ drop uses-of ] 2bi ] dip
-    '[ [ R_q keys _ ] keep @ intersects? ] any? ; inline
-
-PRIVATE>
-
-: live-in? ( vreg node -- ? )
-    [ drop ] live? ;
-
-<PRIVATE
-
-: (live-out?) ( vreg node -- ? )
-    dup dup dup '[
-        _ = _ back-edge-target? not and
-        [ _ swap remove ] when
-    ] live? ;
-
-PRIVATE>
-
-:: live-out? ( vreg node -- ? )
-    vreg def-of :> def
-    {
-        { [ node def eq? ] [ vreg uses-of def only? not ] }
-        { [ def node strictly-dominates? ] [ vreg node (live-out?) ] }
-        [ f ]
-    } cond ;