diff --git a/.gitignore b/.gitignore index 3bc5a6ffda..7bd42557b7 100644 --- a/.gitignore +++ b/.gitignore @@ -12,6 +12,7 @@ Factor/factor *.res *.RES *.image +factor.image.fresh *.dylib factor factor.com diff --git a/GNUmakefile b/GNUmakefile index 30f44e9eba..300a62f71c 100755 --- a/GNUmakefile +++ b/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 diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 17bf4765b8..ff3c9b8dde 100644 --- a/basis/alien/c-types/c-types.factor +++ b/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 *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? ; diff --git a/basis/alien/data/data-docs.factor b/basis/alien/data/data-docs.factor index d36a4d5fd2..1401190f45 100644 --- a/basis/alien/data/data-docs.factor +++ b/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:" diff --git a/basis/alien/data/data.factor b/basis/alien/data/data.factor index a0450d5122..af1ed24663 100644 --- a/basis/alien/data/data.factor +++ b/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 -byte-arrays cpu.architecture fry io io.encodings.binary -io.files io.streams.memory kernel libc math sequences words -byte-vectors ; +USING: accessors alien alien.c-types alien.arrays alien.strings +arrays byte-arrays cpu.architecture fry io io.encodings.binary +io.files io.streams.memory kernel libc math sequences words ; 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 [ ] 2curry ; M: array c-type-unboxer-quot drop [ >c-ptr ] ; - diff --git a/basis/alien/enums/enums-docs.factor b/basis/alien/enums/enums-docs.factor new file mode 100644 index 0000000000..cc23a40df3 --- /dev/null +++ b/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" diff --git a/basis/alien/enums/enums-tests.factor b/basis/alien/enums/enums-tests.factor new file mode 100644 index 0000000000..f0c665830d --- /dev/null +++ b/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 } [ ] map ] unit-test + +{ { 0 3 4 5 } } +[ { red green blue 5 } [ enum>number ] map ] unit-test + +{ { -1 trombone trumpet } } +[ { -1 0 1 } [ ] 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 diff --git a/basis/alien/enums/enums.factor b/basis/alien/enums/enums.factor new file mode 100644 index 0000000000..18000105e7 --- /dev/null +++ b/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 + + 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 ; + + + +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 @ ] ; + +> "<" ">" 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 + swap typedef ; + +PREDICATE: enum-c-type-word < c-type-word + "c-type" word-prop enum-c-type? ; diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index 1db4ca5cd8..166c29bef5 100755 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -75,19 +75,32 @@ M: pointer return-type-name to>> return-type-name CHAR: * suffix ; "*" ?head [ [ ] 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 ) - [ create-in ] dip [ define-constant ] keep 1 + ; - -: parse-enum-member ( word-string value -- next-value ) - 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 ; +: parse-enum ( -- name base-type members ) + parse-enum-name + parse-enum-base-type + [ V{ } clone 0 ] dip parse-enum-members ; : scan-function-name ( -- return function ) scan-c-type scan parse-pointers ; diff --git a/basis/alien/prettyprint/prettyprint.factor b/basis/alien/prettyprint/prettyprint.factor index c47dafbfce..8ba1328dcd 100644 --- a/basis/alien/prettyprint/prettyprint.factor +++ b/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 -alien.parser alien.syntax arrays assocs effects math.parser -prettyprint.backend prettyprint.custom prettyprint.sections -definitions see see.private sequences strings words ; +USING: accessors kernel combinators alien alien.enums +alien.strings alien.c-types alien.parser alien.syntax arrays +assocs effects math.parser prettyprint.backend prettyprint.custom +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>> ; diff --git a/basis/alien/syntax/syntax-docs.factor b/basis/alien/syntax/syntax-docs.factor index b71d0bd533..c960984d53 100644 --- a/basis/alien/syntax/syntax-docs.factor +++ b/basis/alien/syntax/syntax-docs.factor @@ -1,6 +1,6 @@ IN: alien.syntax -USING: alien alien.c-types alien.parser alien.libraries -classes.struct help.markup help.syntax see ; +USING: alien alien.c-types alien.enums alien.libraries classes.struct +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: -{ $syntax "C-ENUM: type/f words... ;" } +HELP: ENUM: +{ $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." } -{ $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." } +{ $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 "" } " 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." } { $examples "Here is an example enumeration definition:" - { $code "C-ENUM: color_t red { green 3 } blue ;" } - "It is equivalent to the following series of definitions:" - { $code "CONSTANT: red 0" "CONSTANT: green 3" "CONSTANT: blue 4" } + { $code "ENUM: color_t red { green 3 } blue ;" } + "The following expression returns true:" + { $code "3 [ green = ] [ enum>number 3 = ] bi and" } } ; HELP: C-TYPE: diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index 41aed99446..570ebf60a5 100755 --- a/basis/alien/syntax/syntax.factor +++ b/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: - scan dup "f" = - [ drop ] - [ (CREATE-C-TYPE) dup save-location int swap typedef ] if - 0 parse-enum-members ; +SYNTAX: ENUM: + parse-enum define-enum ; SYNTAX: C-TYPE: void CREATE-C-TYPE typedef ; diff --git a/basis/biassocs/biassocs.factor b/basis/biassocs/biassocs.factor index 7daa478f54..ab3157d400 100644 --- a/basis/biassocs/biassocs.factor +++ b/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 ; diff --git a/basis/binary-search/binary-search.factor b/basis/binary-search/binary-search.factor index 36e983a1c8..db40408d5e 100644 --- a/basis/binary-search/binary-search.factor +++ b/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 ) -- i elt ) from to + 2/ :> midpoint@ - midpoint@ seq nth :> midpoint + midpoint@ seq nth-unsafe :> midpoint to from - 1 <= [ midpoint@ midpoint diff --git a/basis/bit-sets/bit-sets-tests.factor b/basis/bit-sets/bit-sets-tests.factor index 4e97e703d0..0d4543f8f2 100644 --- a/basis/bit-sets/bit-sets-tests.factor +++ b/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 diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index 0237ed99ee..56109e2de6 100644 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -20,8 +20,8 @@ IN: bootstrap.compiler "alien.remote-control" require ] unless -"prettyprint" "alien.prettyprint" require-when -"debugger" "alien.debugger" require-when +{ "boostrap.compiler" "prettyprint" } "alien.prettyprint" require-when +{ "boostrap.compiler" "debugger" } "alien.debugger" require-when "cpu." cpu name>> append require @@ -35,7 +35,7 @@ gc [ optimized? not ] filter compile ; "debug-compiler" get [ - + nl "Compiling..." write flush @@ -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 diff --git a/basis/bootstrap/handbook/handbook.factor b/basis/bootstrap/handbook/handbook.factor index 11f7349b79..f680c0e328 100644 --- a/basis/bootstrap/handbook/handbook.factor +++ b/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 diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 98b6a472ed..da4fbc444b 100644 --- a/basis/bootstrap/stage2.factor +++ b/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 diff --git a/basis/bootstrap/threads/threads.factor b/basis/bootstrap/threads/threads.factor index 3a8fe98cf4..2bc8d612b6 100644 --- a/basis/bootstrap/threads/threads.factor +++ b/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 diff --git a/basis/bootstrap/ui/tools/tools.factor b/basis/bootstrap/ui/tools/tools.factor index 7db69ce9c1..3efd156983 100644 --- a/basis/bootstrap/ui/tools/tools.factor +++ b/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 diff --git a/basis/cairo/ffi/ffi.factor b/basis/cairo/ffi/ffi.factor index fafc41af26..026fa621f8 100644 --- a/basis/cairo/ffi/ffi.factor +++ b/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 diff --git a/basis/classes/struct/struct-docs.factor b/basis/classes/struct/struct-docs.factor index 7dbfda1f4f..68a4876f92 100644 --- a/basis/classes/struct/struct-docs.factor +++ b/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... }" } diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index ffde233748..605ee573f5 100644 --- a/basis/classes/struct/struct.factor +++ b/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 diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor index 6768e1471d..db1eefca14 100644 --- a/basis/cocoa/application/application.factor +++ b/basis/cocoa/application/application.factor @@ -8,10 +8,9 @@ IN: cocoa.application : ( str -- alien ) -> autorelease ; -C-ENUM: f -NSApplicationDelegateReplySuccess -NSApplicationDelegateReplyCancel -NSApplicationDelegateReplyFailure ; +CONSTANT: NSApplicationDelegateReplySuccess 0 +CONSTANT: NSApplicationDelegateReplyCancel 1 +CONSTANT: NSApplicationDelegateReplyFailure 2 : with-autorelease-pool ( quot -- ) NSAutoreleasePool -> new [ call ] [ -> release ] bi* ; inline diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor index 11624dcf10..8933c4bb39 100644 --- a/basis/combinators/smart/smart-tests.factor +++ b/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 diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor index 5576421742..a907d2d297 100644 --- a/basis/combinators/smart/smart.factor +++ b/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 ] ; diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor new file mode 100644 index 0000000000..4a41129ef4 --- /dev/null +++ b/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 diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index 44326c179f..3cf099d149 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/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 ) - -M: integer aliases +: aliases ( vreg -- vregs ) #! 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 [ - 2nip any-rep \ ##copy new-insn analyze-aliases* nip - ] [ - drop remember-slot - ] if ; + 2dup live-slot dup + [ 2nip analyze-aliases* nip ] + [ drop remember-slot ] + 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-step ] local-optimization ; +: alias-analysis ( cfg -- cfg ) + dup [ alias-analysis-step ] simple-optimization ; diff --git a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor index 670e34e5f9..8f98ab7add 100644 --- a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor +++ b/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 -compiler.cfg.instructions compiler.cfg.registers -compiler.cfg.stack-frame ; +combinators classes words cpu.architecture layouts compiler.cfg +compiler.cfg.rpo compiler.cfg.instructions +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 - 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) ; + stack-frame new t >>calls-vm? request-stack-frame ; M: insn compute-stack-frame* - class frame-required? word-prop [ - frame-required? on - ] when ; + class "frame-required?" word-prop + [ frame-required? on ] when ; -\ _spill t frame-required? set-word-prop -\ ##unary-float-function t frame-required? set-word-prop -\ ##binary-float-function t frame-required? set-word-prop +: initial-stack-frame ( -- stack-frame ) + stack-frame new cfg get spill-area-size>> >>spill-area-size ; : compute-stack-frame ( insns -- ) frame-required? off - stack-frame new stack-frame set - [ compute-stack-frame* ] each + initial-stack-frame stack-frame set + [ instructions>> [ compute-stack-frame* ] each ] each-basic-block stack-frame get dup stack-frame-size >>total-size drop ; -GENERIC: insert-pro/epilogues* ( insn -- ) - -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 ) +: build-stack-frame ( cfg -- cfg ) [ + [ compute-stack-frame ] [ - [ compute-stack-frame ] - [ insert-pro/epilogues ] - bi - ] change-instructions + frame-required? get stack-frame get f ? + >>stack-frame + ] bi ] with-scope ; diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index b2c05edf73..5d2c5e2e3c 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/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 -compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger -compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker -compiler.cfg arrays locals byte-arrays kernel.private math -slots.private vectors sbufs strings math.partial-dispatch -hashtables assocs combinators.short-circuit -strings.private accessors compiler.cfg.instructions ; +prettyprint alien alien.accessors math.private +compiler.tree.builder compiler.tree.optimizer +compiler.cfg.builder compiler.cfg.debugger +compiler.cfg.optimizer compiler.cfg.rpo +compiler.cfg.predecessors compiler.cfg.checker compiler.cfg +arrays locals byte-arrays kernel.private math slots.private +vectors sbufs strings math.partial-dispatch hashtables assocs +combinators.short-circuit strings.private accessors +compiler.cfg.instructions compiler.cfg.representations ; FROM: alien.c-types => int ; IN: compiler.cfg.builder.tests ! Just ensure that various CFGs build correctly. -: unit-test-cfg ( quot -- ) - '[ _ test-cfg [ [ optimize-cfg check-cfg ] with-cfg ] each ] [ ] swap unit-test ; +: unit-test-builder ( quot -- ) + '[ _ 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 fixnum } word '[ _ declare _ execute ] unit-test-cfg + { class } word '[ _ declare 10 _ execute ] unit-test-builder + { 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 fixnum } word '[ _ declare _ execute ] unit-test-cfg + { fixnum class } word '[ _ declare 10 _ execute ] unit-test-builder + { fixnum class fixnum } word '[ _ declare _ execute ] unit-test-builder ] each - { float class } \ set-alien-float '[ _ declare 10 _ execute ] unit-test-cfg - { float class fixnum } \ set-alien-float '[ _ declare _ 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-builder - { float class } \ set-alien-double '[ _ declare 10 _ execute ] unit-test-cfg - { float class fixnum } \ set-alien-double '[ _ declare _ 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-builder - { pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-cfg - { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg + { 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-builder ] each : count-insns ( quot insn-check -- ? ) - [ test-mr [ instructions>> ] map ] dip - '[ _ count ] map-sum ; inline + [ test-regs [ post-order [ instructions>> ] map concat ] map concat ] dip + 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 diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 529c3b5ae6..07f3c0aae4 100644 --- a/basis/compiler/cfg/builder/builder.factor +++ b/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 { diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor index 79f3b0d1fb..c49d638509 100644 --- a/basis/compiler/cfg/cfg.factor +++ b/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 } ; : ( -- 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 ; - -: ( instructions word label -- mr ) - mr new - swap >>label - swap >>word - swap >>instructions ; diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index d6f2702ee7..d7a48a1511 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/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? ] - [ ##compare-imm-branch? ] - [ ##compare-float-ordered-branch? ] - [ ##compare-float-unordered-branch? ] - [ ##fixnum-add? ] - [ ##fixnum-sub? ] - [ ##fixnum-mul? ] + [ conditional-branch-insn? ] [ ##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 ] - [ build-mr check-mr ] - bi ; + [ check-basic-block ] each-basic-block ; diff --git a/basis/compiler/cfg/comparisons/comparisons.factor b/basis/compiler/cfg/comparisons/comparisons.factor index 35f25c2d40..019bfd7a74 100644 --- a/basis/compiler/cfg/comparisons/comparisons.factor +++ b/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' ) diff --git a/basis/compiler/cfg/copy-prop/copy-prop-tests.factor b/basis/compiler/cfg/copy-prop/copy-prop-tests.factor new file mode 100644 index 0000000000..84641183b7 --- /dev/null +++ b/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 diff --git a/basis/compiler/cfg/copy-prop/copy-prop.factor b/basis/compiler/cfg/copy-prop/copy-prop.factor index 23382c3dbe..e18c0fa792 100644 --- a/basis/compiler/cfg/copy-prop/copy-prop.factor +++ b/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 -combinators compiler.cfg.rpo compiler.cfg.renaming -compiler.cfg.instructions compiler.cfg.predecessors ; +USING: sets kernel namespaces assocs accessors sequences grouping +combinators fry compiler.cfg.def-use compiler.cfg.rpo +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 - > ] [ 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 all-equal? ] [ useless-phi ] } - { [ dup phis get key? ] [ redundant-phi ] } - [ record-phi ] - } cond ; + dup phis get key? [ redundant-phi ] [ + dup sift + dup all-equal? + [ nip useless-phi ] + [ drop record-phi ] if + ] if ; + +M: vreg-insn visit-insn + defs-vreg [ dup record-copy ] when* ; M: insn visit-insn drop ; -: collect-copies ( cfg -- ) - H{ } clone copies set +: (collect-copies) ( cfg -- ) [ - 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 ] [ - renamings set - [ - instructions>> [ update-insn ] filter! drop - ] each-basic-block - ] if ; + copies get renamings set + [ [ update-insn ] filter! ] simple-optimization ; PRIVATE> : copy-propagation ( cfg -- cfg' ) needs-predecessors - [ collect-copies ] - [ rename-copies ] - [ ] - tri ; + dup collect-copies + dup rename-copies ; diff --git a/basis/compiler/cfg/dce/dce-tests.factor b/basis/compiler/cfg/dce/dce-tests.factor index 6a7ef08257..460d1a53d1 100644 --- a/basis/compiler/cfg/dce/dce-tests.factor +++ b/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-immediate { dst 2 } { val 16 } } + T{ ##load-integer { dst 1 } { val 8 } } + 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-immediate { dst 2 } { val 16 } } + T{ ##load-integer { dst 1 } { val 8 } } + 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-immediate { dst 2 } { val 16 } } + T{ ##load-integer { dst 1 } { val 8 } } + 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 diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor index d4e8c5401a..dc0be45cc0 100644 --- a/basis/compiler/cfg/debugger/debugger.factor +++ b/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.utilities compiler.cfg.def-use compiler.cfg.rpo -compiler.cfg.mr compiler.cfg.representations.preferred -compiler.cfg ; +compiler.cfg.optimizer compiler.cfg.finalization +compiler.cfg.instructions compiler.cfg.utilities +compiler.cfg.def-use compiler.cfg.rpo +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-cfg [ +: test-optimizer ( quot -- cfgs ) + test-builder [ [ optimize-cfg ] with-cfg ] map ; + +: test-ssa ( quot -- cfgs ) + test-builder [ [ optimize-cfg - build-mr ] with-cfg ] map ; -: insn. ( insn -- ) - tuple>array but-last [ pprint bl ] each nl ; +: test-flat ( quot -- cfgs ) + test-builder [ + [ + optimize-cfg + select-representations + insert-gc-checks + insert-save-contexts + ] with-cfg + ] map ; -: mr. ( mrs -- ) +: 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 - nl - ] each ; + dup linearization-order [ block. ] each + "=== stack frame: " write + stack-frame>> . + ] with-scope ; -: test-mr. ( quot -- ) - test-mr mr. ; inline +: cfgs. ( cfgs -- ) + [ nl ] [ cfg. ] interleave ; + +: ssa. ( quot -- ) test-ssa cfgs. ; +: flat. ( quot -- ) test-flat cfgs. ; +: regs. ( quot -- ) test-regs cfgs. ; ! Prettyprinting : pprint-loc ( loc word -- ) > pprint* block> ; diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index 87758fafcd..93c1a53b44 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/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 diff --git a/basis/compiler/cfg/finalization/authors.txt b/basis/compiler/cfg/finalization/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/compiler/cfg/finalization/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/compiler/cfg/finalization/finalization.factor b/basis/compiler/cfg/finalization/finalization.factor new file mode 100644 index 0000000000..a5f65d7c78 --- /dev/null +++ b/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 ; diff --git a/basis/compiler/cfg/gc-checks/gc-checks-tests.factor b/basis/compiler/cfg/gc-checks/gc-checks-tests.factor index 27d37b115f..496954de2c 100644 --- a/basis/compiler/cfg/gc-checks/gc-checks-tests.factor +++ b/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 -namespaces accessors sequences ; +compiler.cfg.predecessors compiler.cfg.rpo cpu.architecture +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 - insert-gc-checks - drop ; + cfg new 0 get >>entry cfg set ; 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 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? ] 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 } 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 diff --git a/basis/compiler/cfg/gc-checks/gc-checks.factor b/basis/compiler/cfg/gc-checks/gc-checks.factor index 6d192ec54a..4d71bbe556 100644 --- a/basis/compiler/cfg/gc-checks/gc-checks.factor +++ b/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 -cpu.architecture layouts namespaces +USING: accessors assocs combinators fry kernel layouts locals +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 -! selection, so it must keep track of representations. +> [ ##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. + +: ( phis size -- bb ) + [ ] 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 ; + +: ( uninitialized-locs gc-roots -- bb ) + [ ] 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 -- ) + [ [ ] 2dip ] 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 - int-rep next-vreg-rep - _ allocation-size - f - f - _ uninitialized-locs - \ ##gc new-insn - prefix - ] change-instructions drop ; + { + [ uninitialized-locs ] + [ live-tagged ] + [ remove-phis ] + [ allocation-size ] + [ ] + } cleave + (insert-gc-check) ; + +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 ; diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index 9d1945c525..a03f1f83bc 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/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 -namespaces sequences combinators splitting parser effects -words cpu.architecture compiler.cfg.registers +USING: accessors alien arrays byte-arrays classes.algebra +combinators.short-circuit kernel layouts math namespaces +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 not ] [ drop \ f type-number ##load-immediate ] } - { [ dup fixnum? ] [ tag-fixnum ##load-immediate ] } - { [ dup float? ] [ ##load-constant ] } - [ ##load-reference ] - } cond ; + dup fixnum? [ ^^load-integer ] [ ^^load-reference ] if ; : ^^offset>slot ( slot -- vreg' ) - cell 4 = 2 1 ? ^^shr-imm ; + cell 4 = 2 3 ? ^^shl-imm ; -: ^^tag-fixnum ( src -- dst ) - tag-bits get ^^shl-imm ; +: ^^unbox-f ( src -- dst ) + drop 0 ^^load-literal ; -: ^^untag-fixnum ( src -- dst ) - tag-bits get ^^sar-imm ; +: ^^unbox-byte-array ( src -- dst ) + ^^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 ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index c015cb640b..d4e019d8dd 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/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 -compiler.units alien byte-arrays compiler.constants combinators -compiler.cfg.registers compiler.cfg.instructions.syntax ; +math math.order layouts classes.union compiler.units alien +byte-arrays combinators compiler.cfg.registers +compiler.cfg.instructions.syntax ; IN: compiler.cfg.instructions << @@ -20,27 +20,40 @@ TUPLE: insn ; ! value numbering TUPLE: pure-insn < insn ; -! Stack operations -INSN: ##load-immediate +! Constants +INSN: ##load-integer def: dst/int-rep -constant: val ; +literal: val ; INSN: ##load-reference -def: dst/int-rep -constant: obj ; +def: dst/tagged-rep +literal: obj ; -INSN: ##load-constant -def: dst/int-rep -constant: obj ; +! These three are inserted by representation selection +INSN: ##load-tagged +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 -use: obj/int-rep slot/int-rep ; +def: dst/tagged-rep +use: obj/tagged-rep slot/int-rep +literal: scale tag ; INSN: ##slot-imm -def: dst/int-rep -use: obj/int-rep +def: dst/tagged-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 -INSN: ##string-nth -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 +! Register transfers +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 -use: displacement/int-rep base/int-rep +def: dst/tagged-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 ; - -: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ; -: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ; +use: src/tagged-rep ; PURE-INSN: ##unbox-alien def: dst/int-rep -use: src/int-rep ; +use: src/tagged-rep ; -: ##unbox-c-ptr ( dst src class -- ) - { - { [ 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 +! Raw memory accessors +INSN: ##load-memory def: dst -use: src/int-rep -literal: offset rep ; +use: base/int-rep displacement/int-rep +literal: scale offset rep c-type ; -INSN: ##set-alien-integer-1 -use: src/int-rep -literal: offset -use: value/int-rep ; +INSN: ##load-memory-imm +def: dst +use: base/int-rep +literal: offset rep c-type ; -INSN: ##set-alien-integer-2 -use: src/int-rep -literal: offset -use: value/int-rep ; +INSN: ##store-memory +use: src base/int-rep displacement/int-rep +literal: scale offset rep c-type ; -INSN: ##set-alien-integer-4 -use: src/int-rep -literal: offset -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 ; +INSN: ##store-memory-imm +use: src base/int-rep +literal: offset rep c-type ; ! 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 -literal: slot +use: src/tagged-rep +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. -INSN: ##prologue ; -INSN: ##epilogue ; - -INSN: ##branch ; - +! Control flow 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 -constant: src2 -literal: cc ; +use: src1/tagged-rep +literal: src2 cc ; PURE-INSN: ##compare -def: dst/int-rep -use: src1/int-rep src2/int-rep +def: dst/tagged-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 -use: src1/int-rep src2/int-rep ; +def: dst/tagged-rep +use: src1/tagged-rep src2/tagged-rep +literal: cc ; INSN: ##fixnum-sub -def: dst/int-rep -use: src1/int-rep src2/int-rep ; +def: dst/tagged-rep +use: src1/tagged-rep src2/tagged-rep +literal: cc ; INSN: ##fixnum-mul -def: dst/int-rep -use: src1/int-rep src2/int-rep ; - -INSN: ##gc -temp: temp1/int-rep temp2/int-rep -literal: size data-values tagged-values uninitialized-locs ; +def: dst/tagged-rep +use: src1/tagged-rep src2/int-rep +literal: cc ; INSN: ##save-context temp: temp1/int-rep temp2/int-rep ; -! Instructions used by machine IR only. -INSN: _prologue -literal: stack-frame ; +! GC checks +INSN: ##check-nursery-branch +literal: size cc +temp: temp1/int-rep temp2/int-rep ; -INSN: _epilogue -literal: stack-frame ; - -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 ; +INSN: ##call-gc +literal: gc-roots ; +! Spills and reloads, inserted by register allocator TUPLE: spill-slot { n integer } ; C: spill-slot -! These instructions operate on machine registers and not -! virtual registers -INSN: _spill +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 -UNION: partial-sync-insn +! Instructions that clobber registers +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 diff --git a/basis/compiler/cfg/instructions/syntax/syntax.factor b/basis/compiler/cfg/instructions/syntax/syntax.factor index cd76652d06..7b8327cf06 100644 --- a/basis/compiler/cfg/instructions/syntax/syntax.factor +++ b/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 ) - "insn-slots" word-prop +: find-def-slot ( slots -- slot/f ) [ 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 - [ type>> use eq? ] filter ; + "insn-slots" word-prop [ type>> use eq? ] filter ; : insn-temp-slots ( class -- slots ) - "insn-slots" word-prop - [ type>> temp eq? ] filter ; + "insn-slots" word-prop [ type>> temp eq? ] filter ; ! We cannot reference words in compiler.cfg.instructions directly ! since that would create circularity. diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor index 320a0a08f7..23143b2f86 100644 --- a/basis/compiler/cfg/intrinsics/alien/alien.factor +++ b/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- ( node -- ) dup emit-? [ - [ 2inputs [ ^^untag-fixnum ] dip ] dip - node-input-infos second class>> - ^^box-displaced-alien ds-push + '[ + _ node-input-infos second class>> + ^^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 ) - [ next-vreg dup ] 2dip ##unbox-c-ptr ; +: prepare-accessor ( base offset info -- base offset ) + class>> swap [ ^^unbox-c-ptr ] dip ^^add 0 ; -: prepare-alien-accessor ( info -- ptr-vreg offset ) - class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add 0 ; +: prepare-load-memory ( infos -- base offset ) + [ 2inputs ] dip first prepare-accessor ; -: prepare-alien-getter ( infos -- ptr-vreg offset ) - first prepare-alien-accessor ; +: (emit-load-memory) ( node rep c-type quot -- ) + '[ prepare-load-memory _ _ ^^load-memory-imm @ ds-push ] + [ inline-load-memory? ] + inline-accessor ; inline -: inline-alien-getter ( node quot -- ) - '[ prepare-alien-getter @ ds-push ] - [ inline-alien-getter? ] inline-alien ; inline +: emit-load-memory ( node rep c-type -- ) + [ ] (emit-load-memory) ; -: 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 ) - second prepare-alien-accessor ; +: prepare-store-memory ( infos -- value base offset ) + [ 3inputs ] dip second prepare-accessor ; -: inline-alien-integer-setter ( node quot -- ) - '[ prepare-alien-setter ds-pop ^^untag-fixnum @ ] - [ fixnum inline-alien-setter? ] - inline-alien ; inline +:: (emit-store-memory) ( node rep c-type prepare-quot test-quot -- ) + node + [ prepare-quot call rep c-type ##store-memory-imm ] + [ test-quot call inline-store-memory? ] + inline-accessor ; inline -: inline-alien-cell-setter ( node quot -- ) - '[ [ prepare-alien-setter ds-pop ] [ first class>> ] bi ^^unbox-c-ptr @ ] - [ pinned-c-ptr inline-alien-setter? ] - inline-alien ; inline - -: inline-alien-float-setter ( node quot -- ) - '[ prepare-alien-setter ds-pop @ ] - [ float inline-alien-setter? ] - 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 ] } +:: emit-store-memory ( node rep c-type -- ) + node rep c-type + [ prepare-store-memory ] + [ + rep { + { int-rep [ fixnum ] } + { float-rep [ float ] } + { double-rep [ float ] } } case - ] inline-alien-integer-setter ; + ] + (emit-store-memory) ; -: emit-alien-cell-getter ( node -- ) - [ ^^alien-cell ^^box-alien ] inline-alien-getter ; - -: emit-alien-cell-setter ( node -- ) - [ ##set-alien-cell ] inline-alien-cell-setter ; - -: emit-alien-float-getter ( node rep -- ) - '[ - _ { - { 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 ; +: emit-set-alien-cell ( node -- ) + int-rep f + [ + [ first class>> ] [ prepare-store-memory ] bi + [ swap ^^unbox-c-ptr ] 2dip + ] + [ pinned-c-ptr ] + (emit-store-memory) ; diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index e4d1735eae..b9cfac3b92 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/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 - tag-mask get ^^and-imm - 0 cc= ^^compare-imm - ds-push ; - -: tag-literal ( n -- tagged ) - literal>> [ tag-fixnum ] [ \ f type-number ] if* ; - -: emit-fixnum-op ( insn -- ) - [ 2inputs ] dip call ds-push ; inline + [ + [ ^^tagged>integer ] bi@ + ^^or tag-mask get ^^and-imm + 0 cc= ^^compare-integer-imm + ] binary-op ; : 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 ; @@ -44,18 +43,9 @@ IN: compiler.cfg.intrinsics.fixnum { [ dup 0 [-inf,a] interval-subset? ] [ drop emit-fixnum-right-shift ] } [ 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 ; \ No newline at end of file + [ ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ; \ No newline at end of file diff --git a/basis/compiler/cfg/intrinsics/float/float.factor b/basis/compiler/cfg/intrinsics/float/float.factor index 8a65de5805..480b46f9b3 100644 --- a/basis/compiler/cfg/intrinsics/float/float.factor +++ b/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 - -: 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 ; + '[ _ ^^compare-float-unordered ] binary-op ; inline : 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 ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 2b2ae7d160..4faa4809e5 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/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 [ ^^sub ] emit-fixnum-op ] } - { math.private:fixnum*fast [ drop emit-fixnum*fast ] } - { math.private:fixnum-bitand [ drop [ ^^and ] emit-fixnum-op ] } - { math.private:fixnum-bitor [ drop [ ^^or ] emit-fixnum-op ] } - { math.private:fixnum-bitxor [ drop [ ^^xor ] emit-fixnum-op ] } + { math.private:fixnum+fast [ drop [ ^^add ] binary-op ] } + { math.private:fixnum-fast [ drop [ ^^sub ] binary-op ] } + { math.private:fixnum*fast [ drop [ ^^mul ] binary-op ] } + { math.private:fixnum-bitand [ drop [ ^^and ] binary-op ] } + { math.private:fixnum-bitor [ drop [ ^^or ] binary-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: [ emit- ] } { arrays: [ emit- ] } @@ -61,32 +64,32 @@ IN: compiler.cfg.intrinsics { byte-arrays:(byte-array) [ emit-(byte-array) ] } { kernel: [ emit-simple-allot ] } { alien: [ emit- ] } - { alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] } - { alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] } - { alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] } - { alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] } - { alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] } - { alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] } - { alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] } - { alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] } - { alien.accessors:alien-cell [ emit-alien-cell-getter ] } - { alien.accessors:set-alien-cell [ emit-alien-cell-setter ] } + { alien.accessors:alien-unsigned-1 [ int-rep alien.c-types:uchar emit-load-memory ] } + { alien.accessors:set-alien-unsigned-1 [ int-rep alien.c-types:uchar emit-store-memory ] } + { alien.accessors:alien-signed-1 [ int-rep alien.c-types:char emit-load-memory ] } + { alien.accessors:set-alien-signed-1 [ int-rep alien.c-types:char emit-store-memory ] } + { alien.accessors:alien-unsigned-2 [ int-rep alien.c-types:ushort emit-load-memory ] } + { alien.accessors:set-alien-unsigned-2 [ int-rep alien.c-types:ushort emit-store-memory ] } + { alien.accessors:alien-signed-2 [ int-rep alien.c-types:short emit-load-memory ] } + { alien.accessors:set-alien-signed-2 [ int-rep alien.c-types:short emit-store-memory ] } + { alien.accessors:alien-cell [ emit-alien-cell ] } + { 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:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] } - { alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] } - { alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] } + { alien.accessors:alien-signed-4 [ int-rep alien.c-types:int emit-load-memory ] } + { alien.accessors:set-alien-signed-4 [ int-rep alien.c-types:int emit-store-memory ] } + { alien.accessors:alien-unsigned-4 [ int-rep alien.c-types:uint emit-load-memory ] } + { 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 [ ^^sub-float ] emit-float-op ] } - { math.private:float* [ drop [ ^^mul-float ] emit-float-op ] } - { math.private:float/f [ drop [ ^^div-float ] emit-float-op ] } + { math.private:float+ [ drop [ ^^add-float ] binary-op ] } + { math.private:float- [ drop [ ^^sub-float ] binary-op ] } + { math.private:float* [ drop [ ^^mul-float ] binary-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:fixnum>float [ drop emit-fixnum>float ] } + { math.private:float>fixnum [ drop [ ^^float>integer ] unary-op ] } + { 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:set-alien-float [ float-rep emit-alien-float-setter ] } - { alien.accessors:alien-double [ double-rep emit-alien-float-getter ] } - { alien.accessors:set-alien-double [ double-rep emit-alien-float-setter ] } + { alien.accessors:alien-float [ float-rep f emit-load-memory ] } + { alien.accessors:set-alien-float [ float-rep f emit-store-memory ] } + { alien.accessors:alien-double [ double-rep f emit-load-memory ] } + { 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-max [ drop [ ^^max-float ] emit-float-op ] } + { math.floats.private:float-min [ drop [ ^^min-float ] binary-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-max [ drop [ ^^max ] emit-fixnum-op ] } + { math.integers.private:fixnum-min [ drop [ ^^min ] binary-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 -- ) diff --git a/basis/compiler/cfg/intrinsics/misc/misc.factor b/basis/compiler/cfg/intrinsics/misc/misc.factor index da77bcaa09..31c3bac37b 100644 --- a/basis/compiler/cfg/intrinsics/misc/misc.factor +++ b/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 -compiler.tree.propagation.info compiler.cfg.stacks -compiler.cfg.hats compiler.cfg.instructions +USING: accessors classes.algebra layouts kernel math namespaces +sequences cpu.architecture +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 - hashcode-shift ^^shr-imm - ^^tag-fixnum - ds-push ; + [ + ^^tagged>integer + tag-mask get bitnot ^^load-integer ^^and + 0 int-rep f ^^load-memory-imm + hashcode-shift ^^shr-imm + ] unary-op ; diff --git a/basis/compiler/cfg/intrinsics/simd/backend/backend.factor b/basis/compiler/cfg/intrinsics/simd/backend/backend.factor index 2c2d1f1d3a..d9f3df000f 100644 --- a/basis/compiler/cfg/intrinsics/simd/backend/backend.factor +++ b/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? ; diff --git a/basis/compiler/cfg/intrinsics/simd/simd-tests.factor b/basis/compiler/cfg/intrinsics/simd/simd-tests.factor index 8bd936c4f6..96c8da8ace 100644 --- a/basis/compiler/cfg/intrinsics/simd/simd-tests.factor +++ b/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 diff --git a/basis/compiler/cfg/intrinsics/simd/simd.factor b/basis/compiler/cfg/intrinsics/simd/simd.factor index 0d413f1346..a64aa828d0 100644 --- a/basis/compiler/cfg/intrinsics/simd/simd.factor +++ b/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 ] } - { double-2-rep [ double-array{ -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-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 ] } - { double-2-rep [ double-array{ -0.0 0.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-constant ] } - { short-8-rep [ short-array{ -1 0 -1 0 -1 0 -1 0 } underlying>> ^^load-constant ] } - { int-4-rep [ int-array{ -1 0 -1 0 } underlying>> ^^load-constant ] } - { longlong-2-rep [ longlong-array{ -1 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-literal ] } + { 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-literal ] } + { int-4-rep [ int-array{ -1 0 -1 0 } underlying>> ^^load-literal ] } + { 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 ] } - { double-2-rep [ double-array{ 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-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 - _ ^^alien-vector ds-push + ds-drop prepare-load-memory + _ 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 - _ ##set-alien-vector + ds-drop prepare-store-memory + _ f ##store-memory-imm ] - [ byte-array inline-alien-setter? ] - inline-alien + [ byte-array inline-store-memory? ] + inline-accessor ] with { [ %alien-vector-reps member? ] } if-literals-match ; : enable-simd ( -- ) diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor index 1ceac4990a..a3f532b4db 100644 --- a/basis/compiler/cfg/intrinsics/slots/slots.factor +++ b/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 -compiler.cfg.stacks compiler.cfg.hats compiler.cfg.registers +combinators.short-circuit cpu.architecture +compiler.tree.propagation.info compiler.cfg.stacks +compiler.cfg.hats compiler.cfg.registers compiler.cfg.instructions compiler.cfg.utilities compiler.cfg.builder.blocks compiler.constants ; IN: compiler.cfg.intrinsics.slots @@ -13,12 +14,13 @@ IN: compiler.cfg.intrinsics.slots : value-tag ( info -- n ) class>> class-tag ; -: ^^tag-offset>slot ( slot tag -- vreg' ) - [ ^^offset>slot ] dip ^^sub-imm ; +: slot-indexing ( slot tag -- slot scale tag ) + 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? ] } - [ drop f ] - } cond ; + [ fixnum? ] + [ cell * immediate-arithmetic? ] + } 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 ; diff --git a/basis/compiler/cfg/intrinsics/strings/authors.txt b/basis/compiler/cfg/intrinsics/strings/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/compiler/cfg/intrinsics/strings/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/compiler/cfg/intrinsics/strings/strings.factor b/basis/compiler/cfg/intrinsics/strings/strings.factor new file mode 100644 index 0000000000..70d8442a2b --- /dev/null +++ b/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 ; diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index 8951d7a1f1..ed7690bd77 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/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 ] - } cond dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ; + ! 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 + dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ; : finish-allocation ( -- ) active-intervals inactive-intervals diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor index 845cb14d5c..19b0f6c5b9 100644 --- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor +++ b/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 diff --git a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor index 1a2b0f2f2b..b3cba3d90d 100644 --- a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor +++ b/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 ; diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor index 4c825c9d7c..89ec1b7785 100644 --- a/basis/compiler/cfg/linear-scan/allocation/state/state.factor +++ b/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 -kernel math math.order namespaces sequences vectors +USING: arrays accessors assocs combinators cpu.architecture fry +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 ) - rep-of reg-class-of active-intervals get at ; +: active-intervals-for ( live-interval -- seq ) + 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 ) - rep-of reg-class-of inactive-intervals get at ; +: inactive-intervals-for ( live-interval -- seq ) + 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 ) - rep-size cfg get +: next-spill-slot ( size -- n ) + cfg get [ swap [ align dup ] [ + ] bi ] change-spill-area-size drop ; @@ -127,8 +128,11 @@ SYMBOL: unhandled-sync-points ! Mapping from vregs to spill slots SYMBOL: spill-slots -: vreg-spill-slot ( vreg -- spill-slot ) - spill-slots get [ rep-of next-spill-slot ] cache ; +: assign-spill-slot ( coalesced-vreg rep -- spill-slot ) + 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{ } map>assoc ; : add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 6acb9169ec..1682cf9eb6 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/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 pending -- reg ) +:: vreg>reg ( vreg -- 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>reg ( vreg -- reg ) - pending-interval-assoc get (vreg>reg) ; + vreg leader :> leader + leader pending-interval-assoc get at* [ + drop leader vreg rep-of lookup-spill-slot + ] unless ; : vregs>regs ( vregs -- assoc ) - dup assoc-empty? [ - pending-interval-assoc get - '[ _ (vreg>reg) ] assoc-map - ] unless ; + [ f ] [ [ dup vreg>reg ] H{ } map>assoc ] if-empty ; ! 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 -- ) pending-interval-heap set H{ } clone pending-interval-assoc set unhandled-intervals set - H{ } clone register-live-ins set - H{ } clone register-live-outs set + H{ } clone machine-live-ins 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' ) - ! 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. +M: ##call-gc assign-registers-in-insn dup call-next-method - basic-block get register-live-ins get at - [ trace-on-gc gc-root-offsets >>tagged-values ] [ spill-on-gc >>data-values ] bi - drop ; + [ [ vreg>reg ] map ] change-gc-roots drop ; M: insn assign-registers-in-insn drop ; : begin-block ( bb -- ) - dup basic-block set - dup block-from activate-new-intervals - [ live-in vregs>regs ] keep register-live-ins get set-at ; - -: end-block ( bb -- ) - [ live-out vregs>regs ] keep register-live-outs get set-at ; - -: 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 ; + { + [ basic-block set ] + [ block-from activate-new-intervals ] + [ compute-edge-live-in ] + [ compute-live-in ] + } cleave ; :: 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 ; diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index dcf2e743ec..9e6ec76d2c 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -8,7 +8,6 @@ compiler.cfg.instructions compiler.cfg.registers compiler.cfg.predecessors compiler.cfg.rpo -compiler.cfg.linearization compiler.cfg.debugger compiler.cfg.def-use compiler.cfg.comparisons @@ -89,26 +88,29 @@ H{ [ T{ live-interval { vreg 1 } + { reg-class float-regs } { start 0 } { end 2 } - { uses V{ 0 1 } } + { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 1 } } } { ranges V{ T{ live-range f 0 2 } } } { spill-to T{ spill-slot f 0 } } } T{ live-interval { vreg 1 } + { reg-class float-regs } { start 5 } { end 5 } - { uses V{ 5 } } + { uses V{ T{ vreg-use f float-rep 5 } } } { ranges V{ T{ live-range f 5 5 } } } { reload-from T{ spill-slot f 0 } } } ] [ T{ live-interval { vreg 1 } + { reg-class float-regs } { start 0 } { end 5 } - { uses V{ 0 1 5 } } + { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 1 } T{ vreg-use f float-rep 5 } } } { ranges V{ T{ live-range f 0 5 } } } } 2 split-for-spill ] unit-test @@ -116,26 +118,29 @@ H{ [ T{ live-interval { vreg 2 } + { reg-class float-regs } { start 0 } { end 1 } - { uses V{ 0 } } + { uses V{ T{ vreg-use f float-rep 0 } } } { ranges V{ T{ live-range f 0 1 } } } { spill-to T{ spill-slot f 4 } } } T{ live-interval { vreg 2 } + { reg-class float-regs } { start 1 } { end 5 } - { uses V{ 1 5 } } + { uses V{ T{ vreg-use f float-rep 1 } T{ vreg-use f float-rep 5 } } } { ranges V{ T{ live-range f 1 5 } } } { reload-from T{ spill-slot f 4 } } } ] [ T{ live-interval { vreg 2 } + { reg-class float-regs } { start 0 } { end 5 } - { uses V{ 0 1 5 } } + { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 1 } T{ vreg-use f float-rep 5 } } } { ranges V{ T{ live-range f 0 5 } } } } 0 split-for-spill ] unit-test @@ -143,26 +148,29 @@ H{ [ T{ live-interval { vreg 3 } + { reg-class float-regs } { start 0 } { end 1 } - { uses V{ 0 } } + { uses V{ T{ vreg-use f float-rep 0 } } } { ranges V{ T{ live-range f 0 1 } } } { spill-to T{ spill-slot f 8 } } } T{ live-interval { vreg 3 } + { reg-class float-regs } { start 20 } { end 30 } - { uses V{ 20 30 } } + { uses V{ T{ vreg-use f float-rep 20 } T{ vreg-use f float-rep 30 } } } { ranges V{ T{ live-range f 20 30 } } } { reload-from T{ spill-slot f 8 } } } ] [ T{ live-interval { vreg 3 } + { reg-class float-regs } { start 0 } { end 30 } - { uses V{ 0 20 30 } } + { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 20 } T{ vreg-use f float-rep 30 } } } { ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } } } 10 split-for-spill ] unit-test @@ -184,24 +192,27 @@ H{ V{ T{ live-interval { vreg 1 } + { reg-class int-regs } { reg 1 } { start 1 } { end 15 } - { uses V{ 1 3 7 10 15 } } + { uses V{ T{ vreg-use f int-rep 1 } T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 7 } T{ vreg-use f int-rep 10 } T{ vreg-use f int-rep 15 } } } } T{ live-interval { vreg 2 } + { reg-class int-regs } { reg 2 } { start 3 } { end 8 } - { uses V{ 3 4 8 } } + { uses V{ T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 4 } T{ vreg-use f int-rep 8 } } } } T{ live-interval { vreg 3 } + { reg-class int-regs } { reg 3 } { start 3 } { end 10 } - { uses V{ 3 10 } } + { uses V{ T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 10 } } } } } } @@ -209,9 +220,10 @@ H{ H{ } inactive-intervals set T{ live-interval { vreg 1 } + { reg-class int-regs } { start 5 } { end 5 } - { uses V{ 5 } } + { uses V{ T{ vreg-use f int-rep 5 } } } } spill-status ] unit-test @@ -227,17 +239,19 @@ H{ V{ T{ live-interval { vreg 1 } + { reg-class int-regs } { reg 1 } { start 1 } { end 15 } - { uses V{ 1 } } + { uses V{ T{ vreg-use f int-rep 1 } } } } T{ live-interval { vreg 2 } + { reg-class int-regs } { reg 2 } { start 3 } { end 8 } - { uses V{ 3 8 } } + { uses V{ T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 8 } } } } } } @@ -245,9 +259,10 @@ H{ H{ } inactive-intervals set T{ live-interval { vreg 3 } + { reg-class int-regs } { start 5 } { end 5 } - { uses V{ 5 } } + { uses V{ T{ vreg-use f int-rep 5 } } } } spill-status ] unit-test @@ -258,9 +273,10 @@ H{ { 1 int-rep } { 2 int-rep } } representations set { T{ live-interval { vreg 1 } + { reg-class int-regs } { start 0 } { end 100 } - { uses V{ 0 100 } } + { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } } { ranges V{ T{ live-range f 0 100 } } } } } @@ -272,16 +288,18 @@ H{ { 1 int-rep } { 2 int-rep } } representations set { T{ live-interval { vreg 1 } + { reg-class int-regs } { start 0 } { end 10 } - { uses V{ 0 10 } } + { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 10 } } } { ranges V{ T{ live-range f 0 10 } } } } T{ live-interval { vreg 2 } + { reg-class int-regs } { start 11 } { end 20 } - { uses V{ 11 20 } } + { uses V{ T{ vreg-use f int-rep 11 } T{ vreg-use f int-rep 20 } } } { ranges V{ T{ live-range f 11 20 } } } } } @@ -293,16 +311,18 @@ H{ { 1 int-rep } { 2 int-rep } } representations set { T{ live-interval { vreg 1 } + { reg-class int-regs } { start 0 } { end 100 } - { uses V{ 0 100 } } + { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } } { ranges V{ T{ live-range f 0 100 } } } } T{ live-interval { vreg 2 } + { reg-class int-regs } { start 30 } { end 60 } - { uses V{ 30 60 } } + { uses V{ T{ vreg-use f int-rep 30 } T{ vreg-use f int-rep 60 } } } { ranges V{ T{ live-range f 30 60 } } } } } @@ -314,16 +334,18 @@ H{ { 1 int-rep } { 2 int-rep } } representations set { T{ live-interval { vreg 1 } + { reg-class int-regs } { start 0 } { end 100 } - { uses V{ 0 100 } } + { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } } { ranges V{ T{ live-range f 0 100 } } } } T{ live-interval { vreg 2 } + { reg-class int-regs } { start 30 } { end 200 } - { uses V{ 30 200 } } + { uses V{ T{ vreg-use f int-rep 30 } T{ vreg-use f int-rep 200 } } } { ranges V{ T{ live-range f 30 200 } } } } } @@ -335,16 +357,18 @@ H{ { 1 int-rep } { 2 int-rep } } representations set { T{ live-interval { vreg 1 } + { reg-class int-regs } { start 0 } { end 100 } - { uses V{ 0 100 } } + { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } } { ranges V{ T{ live-range f 0 100 } } } } T{ live-interval { vreg 2 } + { reg-class int-regs } { start 30 } { end 100 } - { uses V{ 30 100 } } + { uses V{ T{ vreg-use f int-rep 30 } T{ vreg-use f int-rep 100 } } } { ranges V{ T{ live-range f 30 100 } } } } } @@ -365,39 +389,44 @@ H{ { T{ live-interval { vreg 1 } + { reg-class int-regs } { start 0 } { end 20 } - { uses V{ 0 10 20 } } + { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 10 } T{ vreg-use f int-rep 20 } } } { ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } } } T{ live-interval { vreg 2 } + { reg-class int-regs } { start 0 } { end 20 } - { uses V{ 0 10 20 } } + { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 10 } T{ vreg-use f int-rep 20 } } } { ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } } } T{ live-interval { vreg 3 } + { reg-class int-regs } { start 4 } { end 8 } - { uses V{ 6 } } + { uses V{ T{ vreg-use f int-rep 6 } } } { ranges V{ T{ live-range f 4 8 } } } } T{ live-interval { vreg 4 } + { reg-class int-regs } { start 4 } { end 8 } - { uses V{ 8 } } + { uses V{ T{ vreg-use f int-rep 8 } } } { ranges V{ T{ live-range f 4 8 } } } } ! This guy will invoke the 'spill partially available' code path T{ live-interval { vreg 5 } + { reg-class int-regs } { start 4 } { end 8 } - { uses V{ 8 } } + { uses V{ T{ vreg-use f int-rep 8 } } } { ranges V{ T{ live-range f 4 8 } } } } } @@ -411,18 +440,20 @@ H{ { T{ live-interval { vreg 1 } + { reg-class int-regs } { start 0 } { end 10 } - { uses V{ 0 6 10 } } + { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 6 } T{ vreg-use f int-rep 10 } } } { ranges V{ T{ live-range f 0 10 } } } } ! This guy will invoke the 'spill new' code path T{ live-interval { vreg 5 } + { reg-class int-regs } { start 2 } { end 8 } - { uses V{ 8 } } + { uses V{ T{ vreg-use f int-rep 8 } } } { ranges V{ T{ live-range f 2 8 } } } } } @@ -491,12 +522,14 @@ H{ [ 5 ] [ T{ live-interval { start 0 } + { reg-class int-regs } { end 10 } { uses { 0 10 } } { ranges V{ T{ live-range f 0 10 } } } } T{ live-interval { start 5 } + { reg-class int-regs } { end 10 } { uses { 5 10 } } { ranges V{ T{ live-range f 5 10 } } } @@ -520,6 +553,7 @@ H{ { T{ live-interval { vreg 1 } + { reg-class int-regs } { start 0 } { end 20 } { reg 0 } @@ -529,6 +563,7 @@ H{ T{ live-interval { vreg 2 } + { reg-class int-regs } { start 4 } { end 40 } { reg 0 } @@ -543,6 +578,7 @@ H{ { T{ live-interval { vreg 3 } + { reg-class int-regs } { start 0 } { end 40 } { reg 1 } @@ -554,939 +590,12 @@ H{ } active-intervals set T{ live-interval - { vreg 4 } + { vreg 4 } + { reg-class int-regs } { start 8 } { end 10 } { ranges V{ T{ live-range f 8 10 } } } - { uses V{ 8 10 } } + { uses V{ T{ vreg-use f int-rep 8 } T{ vreg-use f int-rep 10 } } } } register-status ] unit-test - -:: test-linear-scan-on-cfg ( regs -- ) - [ - cfg new 0 get >>entry - dup cfg set - dup fake-representations - dup { { int-regs regs } } (linear-scan) - flatten-cfg 1array mr. - ] with-scope ; - -! Bug in live spill slots calculation - -V{ T{ ##prologue } T{ ##branch } } 0 test-bb - -V{ - T{ ##peek - { dst 703128 } - { loc D 1 } - } - T{ ##peek - { dst 703129 } - { loc D 0 } - } - T{ ##copy - { dst 703134 } - { src 703128 } - } - T{ ##copy - { dst 703135 } - { src 703129 } - } - T{ ##compare-imm-branch - { src1 703128 } - { src2 5 } - { cc cc/= } - } -} 1 test-bb - -V{ - T{ ##copy - { dst 703134 } - { src 703129 } - } - T{ ##copy - { dst 703135 } - { src 703128 } - } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##replace - { src 703134 } - { loc D 0 } - } - T{ ##replace - { src 703135 } - { loc D 1 } - } - T{ ##epilogue } - T{ ##return } -} 3 test-bb - -0 1 edge -1 { 2 3 } edges -2 3 edge - -! Bug in inactive interval handling -! [ rot dup [ -rot ] when ] -V{ T{ ##prologue } T{ ##branch } } 0 test-bb - -V{ - T{ ##peek - { dst 689473 } - { loc D 2 } - } - T{ ##peek - { dst 689474 } - { loc D 1 } - } - T{ ##peek - { dst 689475 } - { loc D 0 } - } - T{ ##compare-imm-branch - { src1 689473 } - { src2 5 } - { cc cc/= } - } -} 1 test-bb - -V{ - T{ ##copy - { dst 689481 } - { src 689475 } - { rep int-rep } - } - T{ ##copy - { dst 689482 } - { src 689474 } - { rep int-rep } - } - T{ ##copy - { dst 689483 } - { src 689473 } - { rep int-rep } - } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##copy - { dst 689481 } - { src 689473 } - { rep int-rep } - } - T{ ##copy - { dst 689482 } - { src 689475 } - { rep int-rep } - } - T{ ##copy - { dst 689483 } - { src 689474 } - { rep int-rep } - } - T{ ##branch } -} 3 test-bb - -V{ - T{ ##replace - { src 689481 } - { loc D 0 } - } - T{ ##replace - { src 689482 } - { loc D 1 } - } - T{ ##replace - { src 689483 } - { loc D 2 } - } - T{ ##epilogue } - T{ ##return } -} 4 test-bb - -test-diamond - -[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test - -! Similar to the above -! [ swap dup [ rot ] when ] - -T{ basic-block - { id 201537 } - { number 0 } - { instructions V{ T{ ##prologue } T{ ##branch } } } -} 0 set - -V{ - T{ ##peek - { dst 689600 } - { loc D 1 } - } - T{ ##peek - { dst 689601 } - { loc D 0 } - } - T{ ##compare-imm-branch - { src1 689600 } - { src2 5 } - { cc cc/= } - } -} 1 test-bb - -V{ - T{ ##peek - { dst 689604 } - { loc D 2 } - } - T{ ##copy - { dst 689607 } - { src 689604 } - } - T{ ##copy - { dst 689608 } - { src 689600 } - { rep int-rep } - } - T{ ##copy - { dst 689610 } - { src 689601 } - { rep int-rep } - } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##peek - { dst 689609 } - { loc D 2 } - } - T{ ##copy - { dst 689607 } - { src 689600 } - { rep int-rep } - } - T{ ##copy - { dst 689608 } - { src 689601 } - { rep int-rep } - } - T{ ##copy - { dst 689610 } - { src 689609 } - { rep int-rep } - } - T{ ##branch } -} 3 test-bb - -V{ - T{ ##replace - { src 689607 } - { loc D 0 } - } - T{ ##replace - { src 689608 } - { loc D 1 } - } - T{ ##replace - { src 689610 } - { loc D 2 } - } - T{ ##epilogue } - T{ ##return } -} 4 test-bb - -test-diamond - -[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test - -! compute-live-registers was inaccurate since it didn't take -! lifetime holes into account - -V{ T{ ##prologue } T{ ##branch } } 0 test-bb - -V{ - T{ ##peek - { dst 0 } - { loc D 0 } - } - T{ ##compare-imm-branch - { src1 0 } - { src2 5 } - { cc cc/= } - } -} 1 test-bb - -V{ - T{ ##peek - { dst 1 } - { loc D 1 } - } - T{ ##copy - { dst 2 } - { src 1 } - { rep int-rep } - } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##peek - { dst 3 } - { loc D 2 } - } - T{ ##copy - { dst 2 } - { src 3 } - { rep int-rep } - } - T{ ##branch } -} 3 test-bb - -V{ - T{ ##replace - { src 2 } - { loc D 0 } - } - T{ ##return } -} 4 test-bb - -test-diamond - -[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test - -! Inactive interval handling: splitting active interval -! if it fits in lifetime hole only partially - -V{ T{ ##peek f 3 R 1 } T{ ##branch } } 0 test-bb - -V{ - T{ ##peek f 2 R 0 } - T{ ##compare-imm-branch f 2 5 cc= } -} 1 test-bb - -V{ - T{ ##peek f 0 D 0 } - T{ ##branch } -} 2 test-bb - - -V{ - T{ ##peek f 1 D 1 } - T{ ##peek f 0 D 0 } - T{ ##replace f 1 D 2 } - T{ ##branch } -} 3 test-bb - -V{ - T{ ##replace f 3 R 2 } - T{ ##replace f 0 D 0 } - T{ ##return } -} 4 test-bb - -test-diamond - -[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test - -! Not until splitting is finished -! [ _copy ] [ 3 get instructions>> second class ] unit-test - -! Resolve pass; make sure the spilling is done correctly -V{ T{ ##peek f 3 R 1 } T{ ##branch } } 0 test-bb - -V{ - T{ ##peek f 2 R 0 } - T{ ##compare-imm-branch f 2 5 cc= } -} 1 test-bb - -V{ - T{ ##branch } -} 2 test-bb - -V{ - T{ ##replace f 3 R 1 } - T{ ##peek f 1 D 1 } - T{ ##peek f 0 D 0 } - T{ ##replace f 1 D 2 } - T{ ##replace f 0 D 2 } - T{ ##branch } -} 3 test-bb - -V{ - T{ ##replace f 3 R 2 } - T{ ##return } -} 4 test-bb - -test-diamond - -[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test - -[ _spill ] [ 2 get successors>> first instructions>> first class ] unit-test - -[ _spill ] [ 3 get instructions>> second class ] unit-test - -[ f ] [ 3 get instructions>> [ _reload? ] any? ] unit-test - -[ _reload ] [ 4 get instructions>> first class ] unit-test - -! Resolve pass -V{ - T{ ##branch } -} 0 test-bb - -V{ - T{ ##peek f 0 D 0 } - T{ ##compare-imm-branch f 0 5 cc= } -} 1 test-bb - -V{ - T{ ##replace f 0 D 0 } - T{ ##peek f 1 D 0 } - T{ ##peek f 2 D 0 } - T{ ##replace f 1 D 0 } - T{ ##replace f 2 D 0 } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##branch } -} 3 test-bb - -V{ - T{ ##peek f 1 D 0 } - T{ ##compare-imm-branch f 1 5 cc= } -} 4 test-bb - -V{ - T{ ##replace f 0 D 0 } - T{ ##return } -} 5 test-bb - -V{ - T{ ##replace f 0 D 0 } - T{ ##return } -} 6 test-bb - -0 1 edge -1 { 2 3 } edges -2 4 edge -3 4 edge -4 { 5 6 } edges - -[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test - -[ t ] [ 2 get instructions>> [ _spill? ] any? ] unit-test - -[ t ] [ 3 get predecessors>> first instructions>> [ _spill? ] any? ] unit-test - -[ t ] [ 5 get instructions>> [ _reload? ] any? ] unit-test - -! A more complicated failure case with resolve that came up after the above -! got fixed -V{ T{ ##branch } } 0 test-bb -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{ ##peek f 4 D 0 } - T{ ##branch } -} 1 test-bb -V{ T{ ##branch } } 2 test-bb -V{ T{ ##branch } } 3 test-bb -V{ - - T{ ##replace f 1 D 1 } - T{ ##replace f 2 D 2 } - T{ ##replace f 3 D 3 } - T{ ##replace f 4 D 4 } - T{ ##replace f 0 D 0 } - T{ ##branch } -} 4 test-bb -V{ T{ ##replace f 0 D 0 } T{ ##branch } } 5 test-bb -V{ T{ ##return } } 6 test-bb -V{ T{ ##branch } } 7 test-bb -V{ - T{ ##replace f 1 D 1 } - T{ ##replace f 2 D 2 } - T{ ##replace f 3 D 3 } - T{ ##peek f 5 D 1 } - T{ ##peek f 6 D 2 } - T{ ##peek f 7 D 3 } - T{ ##peek f 8 D 4 } - T{ ##replace f 5 D 1 } - T{ ##replace f 6 D 2 } - T{ ##replace f 7 D 3 } - T{ ##replace f 8 D 4 } - T{ ##branch } -} 8 test-bb -V{ - T{ ##replace f 1 D 1 } - T{ ##replace f 2 D 2 } - T{ ##replace f 3 D 3 } - T{ ##return } -} 9 test-bb - -0 1 edge -1 { 2 7 } edges -7 8 edge -8 9 edge -2 { 3 5 } edges -3 4 edge -4 9 edge -5 6 edge - -[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test - -[ _spill ] [ 1 get instructions>> second class ] unit-test -[ _reload ] [ 4 get instructions>> 4 swap nth class ] unit-test -[ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ dst>> n>> cell / ] map ] unit-test -[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ src>> n>> cell / ] map ] unit-test - -! Resolve pass should insert this -[ _reload ] [ 5 get predecessors>> first instructions>> first class ] unit-test - -! Some random bug -V{ - T{ ##peek f 1 D 1 } - T{ ##peek f 2 D 2 } - T{ ##replace f 1 D 1 } - T{ ##replace f 2 D 2 } - T{ ##peek f 3 D 0 } - T{ ##peek f 0 D 0 } - T{ ##branch } -} 0 test-bb - -V{ T{ ##branch } } 1 test-bb - -V{ - T{ ##peek f 1 D 1 } - T{ ##peek f 2 D 2 } - T{ ##replace f 3 D 3 } - T{ ##replace f 1 D 1 } - T{ ##replace f 2 D 2 } - T{ ##replace f 0 D 3 } - T{ ##branch } -} 2 test-bb - -V{ T{ ##branch } } 3 test-bb - -V{ - T{ ##return } -} 4 test-bb - -test-diamond - -[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test - -! Spilling an interval immediately after its activated; -! and the interval does not have a use at the activation point -V{ - T{ ##peek f 1 D 1 } - T{ ##peek f 2 D 2 } - T{ ##replace f 1 D 1 } - T{ ##replace f 2 D 2 } - T{ ##peek f 0 D 0 } - T{ ##branch } -} 0 test-bb - -V{ T{ ##branch } } 1 test-bb - -V{ - T{ ##peek f 1 D 1 } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##replace f 1 D 1 } - T{ ##peek f 2 D 2 } - T{ ##replace f 2 D 2 } - T{ ##branch } -} 3 test-bb - -V{ T{ ##branch } } 4 test-bb - -V{ - T{ ##replace f 0 D 0 } - T{ ##return } -} 5 test-bb - -0 1 edge -1 { 2 4 } edges -4 5 edge -2 3 edge -3 5 edge - -[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test - -! Reduction of push-all regression, x86-32 -V{ T{ ##prologue } T{ ##branch } } 0 test-bb - -V{ - T{ ##load-immediate { dst 61 } } - T{ ##peek { dst 62 } { loc D 0 } } - T{ ##peek { dst 64 } { loc D 1 } } - T{ ##slot-imm - { dst 69 } - { obj 64 } - { slot 1 } - { tag 2 } - } - T{ ##copy { dst 79 } { src 69 } { rep int-rep } } - T{ ##slot-imm - { dst 85 } - { obj 62 } - { slot 2 } - { tag 7 } - } - T{ ##compare-branch - { src1 69 } - { src2 85 } - { cc cc> } - } -} 1 test-bb - -V{ - T{ ##slot-imm - { dst 97 } - { obj 62 } - { slot 2 } - { tag 7 } - } - T{ ##replace { src 79 } { loc D 3 } } - T{ ##replace { src 62 } { loc D 4 } } - T{ ##replace { src 79 } { loc D 1 } } - T{ ##replace { src 62 } { loc D 2 } } - T{ ##replace { src 61 } { loc D 5 } } - T{ ##replace { src 62 } { loc R 0 } } - T{ ##replace { src 69 } { loc R 1 } } - T{ ##replace { src 97 } { loc D 0 } } - T{ ##call { word resize-array } } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##peek { dst 98 } { loc R 0 } } - T{ ##peek { dst 100 } { loc D 0 } } - T{ ##set-slot-imm - { src 100 } - { obj 98 } - { slot 2 } - { tag 7 } - } - T{ ##peek { dst 108 } { loc D 2 } } - T{ ##peek { dst 110 } { loc D 3 } } - T{ ##peek { dst 112 } { loc D 0 } } - T{ ##peek { dst 114 } { loc D 1 } } - T{ ##peek { dst 116 } { loc D 4 } } - T{ ##peek { dst 119 } { loc R 0 } } - T{ ##copy { dst 109 } { src 108 } { rep int-rep } } - T{ ##copy { dst 111 } { src 110 } { rep int-rep } } - T{ ##copy { dst 113 } { src 112 } { rep int-rep } } - T{ ##copy { dst 115 } { src 114 } { rep int-rep } } - T{ ##copy { dst 117 } { src 116 } { rep int-rep } } - T{ ##copy { dst 120 } { src 119 } { rep int-rep } } - T{ ##branch } -} 3 test-bb - -V{ - T{ ##copy { dst 109 } { src 62 } { rep int-rep } } - T{ ##copy { dst 111 } { src 61 } { rep int-rep } } - T{ ##copy { dst 113 } { src 62 } { rep int-rep } } - T{ ##copy { dst 115 } { src 79 } { rep int-rep } } - T{ ##copy { dst 117 } { src 64 } { rep int-rep } } - T{ ##copy { dst 120 } { src 69 } { rep int-rep } } - T{ ##branch } -} 4 test-bb - -V{ - T{ ##replace { src 120 } { loc D 0 } } - T{ ##replace { src 109 } { loc D 3 } } - T{ ##replace { src 111 } { loc D 4 } } - T{ ##replace { src 113 } { loc D 1 } } - T{ ##replace { src 115 } { loc D 2 } } - T{ ##replace { src 117 } { loc D 5 } } - T{ ##epilogue } - T{ ##return } -} 5 test-bb - -0 1 edge -1 { 2 4 } edges -2 3 edge -3 5 edge -4 5 edge - -[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test - -! Another reduction of push-all -V{ T{ ##prologue } T{ ##branch } } 0 test-bb - -V{ - T{ ##peek { dst 85 } { loc D 0 } } - T{ ##slot-imm - { dst 89 } - { obj 85 } - { slot 3 } - { tag 7 } - } - T{ ##peek { dst 91 } { loc D 1 } } - T{ ##slot-imm - { dst 96 } - { obj 91 } - { slot 1 } - { tag 2 } - } - T{ ##add - { dst 109 } - { src1 89 } - { src2 96 } - } - T{ ##slot-imm - { dst 115 } - { obj 85 } - { slot 2 } - { tag 7 } - } - T{ ##slot-imm - { dst 118 } - { obj 115 } - { slot 1 } - { tag 2 } - } - T{ ##compare-branch - { src1 109 } - { src2 118 } - { cc cc> } - } -} 1 test-bb - -V{ - T{ ##add-imm - { dst 128 } - { src1 109 } - { src2 8 } - } - T{ ##load-immediate { dst 129 } { val 24 } } - T{ ##inc-d { n 4 } } - T{ ##inc-r { n 1 } } - T{ ##replace { src 109 } { loc D 2 } } - T{ ##replace { src 85 } { loc D 3 } } - T{ ##replace { src 128 } { loc D 0 } } - T{ ##replace { src 85 } { loc D 1 } } - T{ ##replace { src 89 } { loc D 4 } } - T{ ##replace { src 96 } { loc R 0 } } - T{ ##replace { src 129 } { loc R 0 } } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##peek { dst 134 } { loc D 1 } } - T{ ##slot-imm - { dst 140 } - { obj 134 } - { slot 2 } - { tag 7 } - } - T{ ##inc-d { n 1 } } - T{ ##inc-r { n 1 } } - T{ ##replace { src 140 } { loc D 0 } } - T{ ##replace { src 134 } { loc R 0 } } - T{ ##call { word resize-array } } - T{ ##branch } -} 3 test-bb - -V{ - T{ ##peek { dst 141 } { loc R 0 } } - T{ ##peek { dst 143 } { loc D 0 } } - T{ ##set-slot-imm - { src 143 } - { obj 141 } - { slot 2 } - { tag 7 } - } - T{ ##write-barrier-imm - { src 141 } - { slot 2 } - { temp1 145 } - { temp2 146 } - } - T{ ##inc-d { n -1 } } - T{ ##inc-r { n -1 } } - T{ ##peek { dst 156 } { loc D 2 } } - T{ ##peek { dst 158 } { loc D 3 } } - T{ ##peek { dst 160 } { loc D 0 } } - T{ ##peek { dst 162 } { loc D 1 } } - T{ ##peek { dst 164 } { loc D 4 } } - T{ ##peek { dst 167 } { loc R 0 } } - T{ ##copy { dst 157 } { src 156 } { rep int-rep } } - T{ ##copy { dst 159 } { src 158 } { rep int-rep } } - T{ ##copy { dst 161 } { src 160 } { rep int-rep } } - T{ ##copy { dst 163 } { src 162 } { rep int-rep } } - T{ ##copy { dst 165 } { src 164 } { rep int-rep } } - T{ ##copy { dst 168 } { src 167 } { rep int-rep } } - T{ ##branch } -} 4 test-bb - -V{ - T{ ##inc-d { n 3 } } - T{ ##inc-r { n 1 } } - T{ ##copy { dst 157 } { src 85 } } - T{ ##copy { dst 159 } { src 89 } } - T{ ##copy { dst 161 } { src 85 } } - T{ ##copy { dst 163 } { src 109 } } - T{ ##copy { dst 165 } { src 91 } } - T{ ##copy { dst 168 } { src 96 } } - T{ ##branch } -} 5 test-bb - -V{ - T{ ##set-slot-imm - { src 163 } - { obj 161 } - { slot 3 } - { tag 7 } - } - T{ ##inc-d { n 1 } } - T{ ##inc-r { n -1 } } - T{ ##replace { src 168 } { loc D 0 } } - T{ ##replace { src 157 } { loc D 3 } } - T{ ##replace { src 159 } { loc D 4 } } - T{ ##replace { src 161 } { loc D 1 } } - T{ ##replace { src 163 } { loc D 2 } } - T{ ##replace { src 165 } { loc D 5 } } - T{ ##epilogue } - T{ ##return } -} 6 test-bb - -0 1 edge -1 { 2 5 } edges -2 3 edge -3 4 edge -4 6 edge -5 6 edge - -[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test - -! Fencepost error in assignment pass -V{ T{ ##branch } } 0 test-bb - -V{ - T{ ##peek f 0 D 0 } - T{ ##compare-imm-branch f 0 5 cc= } -} 1 test-bb - -V{ T{ ##branch } } 2 test-bb - -V{ - T{ ##peek f 1 D 0 } - T{ ##peek f 2 D 0 } - T{ ##replace f 1 D 0 } - T{ ##replace f 2 D 0 } - T{ ##branch } -} 3 test-bb - -V{ - T{ ##replace f 0 D 0 } - T{ ##return } -} 4 test-bb - -test-diamond - -[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test - -[ 0 ] [ 1 get instructions>> [ _spill? ] count ] unit-test - -[ 1 ] [ 2 get instructions>> [ _spill? ] count ] unit-test - -[ 1 ] [ 3 get predecessors>> first instructions>> [ _spill? ] count ] unit-test - -[ 1 ] [ 4 get instructions>> [ _reload? ] count ] unit-test - -! Another test case for fencepost error in assignment pass -V{ T{ ##branch } } 0 test-bb - -V{ - T{ ##peek f 0 D 0 } - T{ ##compare-imm-branch f 0 5 cc= } -} 1 test-bb - -V{ - T{ ##peek f 1 D 0 } - T{ ##peek f 2 D 0 } - T{ ##replace f 1 D 0 } - T{ ##replace f 2 D 0 } - T{ ##replace f 0 D 0 } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##branch } -} 3 test-bb - -V{ - T{ ##replace f 0 D 0 } - T{ ##return } -} 4 test-bb - -test-diamond - -[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test - -[ 0 ] [ 1 get instructions>> [ _spill? ] count ] unit-test - -[ 1 ] [ 2 get instructions>> [ _spill? ] count ] unit-test - -[ 1 ] [ 2 get instructions>> [ _reload? ] count ] unit-test - -[ 0 ] [ 3 get instructions>> [ _spill? ] count ] unit-test - -[ 0 ] [ 4 get instructions>> [ _reload? ] count ] unit-test - -V{ - T{ ##peek f 0 D 0 } - T{ ##peek f 1 D 1 } - T{ ##replace f 1 D 1 } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##gc f 2 3 } - T{ ##branch } -} 1 test-bb - -V{ - T{ ##replace f 0 D 0 } - T{ ##return } -} 2 test-bb - -0 1 edge -1 2 edge - -[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test - -[ { { 0 1 } } ] [ 1 get instructions>> first tagged-values>> ] unit-test - -V{ - T{ ##peek f 0 D 0 } - T{ ##peek f 1 D 1 } - T{ ##compare-imm-branch f 1 5 cc= } -} 0 test-bb - -V{ - T{ ##gc f 2 3 } - T{ ##replace f 0 D 0 } - T{ ##return } -} 1 test-bb - -V{ - T{ ##return } -} 2 test-bb - -0 { 1 2 } edges - -[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test - -[ { { 0 1 } } ] [ 1 get instructions>> first tagged-values>> ] unit-test diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor index 5e723f098a..7657937d33 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan.factor +++ b/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 diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 00d6f73517..cb697c2136 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/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 -combinators binary-search compiler.cfg.instructions compiler.cfg.registers -compiler.cfg.def-use compiler.cfg.liveness compiler.cfg.linearization.order -compiler.cfg ; +USING: namespaces kernel assocs accessors locals sequences math +math.order fry combinators binary-search +compiler.cfg.instructions +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 +SYMBOLS: +def+ +use+ +memory+ ; + +TUPLE: vreg-use rep n type ; + +C: 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 -- ? ) @@ -29,7 +46,7 @@ M: live-interval covers? ( insn# live-interval -- ? ) [ drop ] [ [ from>> <=> ] with search nip ] 2bi covers? ] if ; - + : add-new-range ( from to live-interval -- ) [ ] dip ranges>> push ; @@ -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 + live-interval uses>> push + ] unless ; -M: vreg-insn operands-in-registers? drop t ; - -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 ; - -: ( vreg -- live-interval ) +: ( vreg reg-class -- 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* - nip [ start>> ] [ end>> 1000 * ] bi + ; +SYMBOLS: from to ; ! Mapping from vreg to live-interval SYMBOL: live-intervals : live-interval ( vreg -- live-interval ) - live-intervals get [ ] cache ; + leader live-intervals get + [ dup rep-of reg-class-of ] cache ; GENERIC: compute-live-intervals* ( insn -- ) M: insn compute-live-intervals* drop ; -: handle-output ( insn vreg -- ) - live-interval - [ [ insn#>> ] dip shorten-range ] [ add-def ] 2bi ; +:: record-def ( vreg n type -- ) + vreg rep-of :> rep + vreg live-interval :> live-interval -: handle-input ( insn vreg -- ) - live-interval - [ [ [ basic-block get block-from ] dip insn#>> ] dip add-range ] [ add-use ] 2bi ; + n live-interval shorten-range + rep n type live-interval add-use ; -: handle-temp ( insn vreg -- ) - live-interval - [ [ insn#>> dup ] dip add-range ] [ add-use ] 2bi ; +:: record-use ( vreg n type -- ) + vreg rep-of :> rep + vreg live-interval :> live-interval -M: vreg-insn compute-live-intervals* - [ dup defs-vreg [ handle-output ] with when* ] - [ dup uses-vregs [ handle-input ] with each ] - [ dup temp-vregs [ handle-temp ] with each ] - tri ; + from get n live-interval add-range + rep n type live-interval add-use ; + +:: record-temp ( vreg n -- ) + 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-interval add-range ] with with each ; + live-out dup assoc-empty? [ drop ] [ + [ 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,21 +148,24 @@ SYMBOL: sync-points GENERIC: compute-sync-points* ( insn -- ) -M: partial-sync-insn compute-sync-points* +M: clobber-insn compute-sync-points* insn#>> sync-points get push ; M: insn compute-sync-points* drop ; : compute-live-intervals-step ( bb -- ) - [ basic-block set ] - [ handle-live-out ] - [ - instructions>> [ - [ compute-live-intervals* ] - [ compute-sync-points* ] - bi - ] each - ] tri ; + { + [ block-from from set ] + [ block-to to set ] + [ handle-live-out ] + [ + instructions>> [ + [ compute-live-intervals* ] + [ compute-sync-points* ] + bi + ] each + ] + } cleave ; : init-live-intervals ( -- ) H{ } clone live-intervals set diff --git a/basis/compiler/cfg/linear-scan/numbering/numbering.factor b/basis/compiler/cfg/linear-scan/numbering/numbering.factor index 44b2ff907a..391edf21d6 100644 --- a/basis/compiler/cfg/linear-scan/numbering/numbering.factor +++ b/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 ; diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor index e7f291d613..7aff066e0b 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor +++ b/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 -] [ - { { { 0 int-rep } { 1 int-rep } } { { 1 int-rep } { 0 int-rep } } } +[ t ] [ + { + { T{ location f 0 int-rep int-regs } T{ location f 1 int-rep int-regs } } + { 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 diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor index 20c9ee4e99..9d3c91ca18 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor +++ b/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 } ; + +: ( 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 , ; + '[ _ ] bi@ 2array , ; -:: resolve-value-data-flow ( bb to vreg -- ) - vreg bb vreg-at-end - vreg to vreg-at-start +:: resolve-value-data-flow ( vreg live-out live-in edge-live-in -- ) + vreg live-out ?at [ bad-vreg ] unless + 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 ) - dup live-in dup assoc-empty? [ 3drop f ] [ - [ keys [ resolve-value-data-flow ] with with each ] { } make +:: compute-mappings ( bb to -- mappings ) + bb machine-live-out :> live-out + 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 ] } - { [ dup first spill-slot? ] [ register->memory ] } + { [ over reg>> spill-slot? ] [ memory->register ] } + { [ 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 ; diff --git a/basis/compiler/cfg/linearization/order/order-tests.factor b/basis/compiler/cfg/linearization/linearization-tests.factor similarity index 83% rename from basis/compiler/cfg/linearization/order/order-tests.factor rename to basis/compiler/cfg/linearization/linearization-tests.factor index 67fb55f507..edaeb720c7 100644 --- a/basis/compiler/cfg/linearization/order/order-tests.factor +++ b/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 diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index a0360e9d9c..c44b29d271 100644 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/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 -combinators assocs arrays locals layouts hashtables -cpu.architecture generalizations -compiler.cfg -compiler.cfg.comparisons -compiler.cfg.stack-frame -compiler.cfg.instructions -compiler.cfg.utilities -compiler.cfg.linearization.order ; +USING: accessors arrays assocs deques dlists hashtables 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 +! This is RPO except loops are rotated and unlikely blocks go +! at the end. Based on SBCL's src/compiler/control.lisp + 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>> [ 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 ; - -! 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 - ; +: number-blocks ( bbs -- ) + [ 2array ] map-index >hashtable numbers set ; diff --git a/basis/compiler/cfg/linearization/order/order.factor b/basis/compiler/cfg/linearization/order/order.factor deleted file mode 100644 index 166a0f0d50..0000000000 --- a/basis/compiler/cfg/linearization/order/order.factor +++ /dev/null @@ -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 - - 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>> [ 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 ; diff --git a/basis/compiler/cfg/linearization/summary.txt b/basis/compiler/cfg/linearization/summary.txt deleted file mode 100644 index 96daec8046..0000000000 --- a/basis/compiler/cfg/linearization/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Flattening CFG into MR (machine representation) diff --git a/basis/compiler/cfg/liveness/ssa/ssa-tests.factor b/basis/compiler/cfg/liveness/ssa/ssa-tests.factor new file mode 100644 index 0000000000..5413c65b32 --- /dev/null +++ b/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 diff --git a/basis/compiler/cfg/liveness/ssa/ssa.factor b/basis/compiler/cfg/liveness/ssa/ssa.factor index 5215c9c487..84428514aa 100644 --- a/basis/compiler/cfg/liveness/ssa/ssa.factor +++ b/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 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? ; diff --git a/basis/compiler/cfg/loop-detection/loop-detection.factor b/basis/compiler/cfg/loop-detection/loop-detection.factor index 2e2dab00f1..d8fc92aaa6 100644 --- a/basis/compiler/cfg/loop-detection/loop-detection.factor +++ b/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 ; diff --git a/basis/compiler/cfg/mr/authors.txt b/basis/compiler/cfg/mr/authors.txt deleted file mode 100644 index d4f5d6b3ae..0000000000 --- a/basis/compiler/cfg/mr/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov \ No newline at end of file diff --git a/basis/compiler/cfg/mr/mr.factor b/basis/compiler/cfg/mr/mr.factor deleted file mode 100644 index a46e6c15cb..0000000000 --- a/basis/compiler/cfg/mr/mr.factor +++ /dev/null @@ -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 ; \ No newline at end of file diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index d43e4adcc8..ba7d31d141 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/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 -compiler.cfg.tco +USING: 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 - select-representations - schedule-instructions - destruct-ssa - delete-empty-blocks - ?check ; + eliminate-write-barriers ; diff --git a/basis/compiler/cfg/representations/coalescing/authors.txt b/basis/compiler/cfg/representations/coalescing/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/compiler/cfg/representations/coalescing/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/compiler/cfg/representations/coalescing/coalescing-tests.factor b/basis/compiler/cfg/representations/coalescing/coalescing-tests.factor new file mode 100644 index 0000000000..cc1bde36f1 --- /dev/null +++ b/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 diff --git a/basis/compiler/cfg/representations/coalescing/coalescing.factor b/basis/compiler/cfg/representations/coalescing/coalescing.factor new file mode 100644 index 0000000000..20610649bc --- /dev/null +++ b/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 -- ) + + [ init-components ] + [ merge-components ] + [ components set drop ] 2tri ; + +: vreg>scc ( vreg -- scc ) + components get representative ; diff --git a/basis/compiler/cfg/representations/conversion/authors.txt b/basis/compiler/cfg/representations/conversion/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/compiler/cfg/representations/conversion/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/compiler/cfg/representations/conversion/conversion.factor b/basis/compiler/cfg/representations/conversion/conversion.factor new file mode 100644 index 0000000000..b8346fed6a --- /dev/null +++ b/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 ; diff --git a/basis/compiler/cfg/representations/peephole/authors.txt b/basis/compiler/cfg/representations/peephole/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/compiler/cfg/representations/peephole/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/compiler/cfg/representations/peephole/peephole.factor b/basis/compiler/cfg/representations/peephole/peephole.factor new file mode 100644 index 0000000000..22366f5714 --- /dev/null +++ b/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 ; diff --git a/basis/compiler/cfg/representations/preferred/preferred.factor b/basis/compiler/cfg/representations/preferred/preferred.factor index ffb8f9a390..e1a9ec0d93 100644 --- a/basis/compiler/cfg/representations/preferred/preferred.factor +++ b/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-def-rep ] - [ each-use-rep ] - [ each-temp-rep ] 2tri + _ each-rep ] each-non-phi ] bi ] each-basic-block ; inline diff --git a/basis/compiler/cfg/representations/representations-tests.factor b/basis/compiler/cfg/representations/representations-tests.factor index c50cfc4c86..ef64908f78 100644 --- a/basis/compiler/cfg/representations/representations-tests.factor +++ b/basis/compiler/cfg/representations/representations-tests.factor @@ -1,6 +1,11 @@ -USING: tools.test cpu.architecture -compiler.cfg.registers compiler.cfg.instructions -compiler.cfg.representations.preferred ; +USING: accessors compiler.cfg compiler.cfg.debugger +compiler.cfg.instructions compiler.cfg.registers +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 \ No newline at end of file diff --git a/basis/compiler/cfg/representations/representations.factor b/basis/compiler/cfg/representations/representations.factor index 05e365e5e4..2160ad26e6 100644 --- a/basis/compiler/cfg/representations/representations.factor +++ b/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 -arrays combinators combinators.short-circuit math make locals -deques dlists layouts byte-arrays cpu.architecture -compiler.utilities -compiler.constants +USING: combinators compiler.cfg -compiler.cfg.rpo -compiler.cfg.hats compiler.cfg.registers -compiler.cfg.instructions -compiler.cfg.def-use -compiler.cfg.utilities +compiler.cfg.predecessors compiler.cfg.loop-detection -compiler.cfg.renaming.functor -compiler.cfg.representations.preferred ; -FROM: namespaces => set ; +compiler.cfg.representations.rewrite +compiler.cfg.representations.peephole +compiler.cfg.representations.selection +compiler.cfg.representations.coalescing ; IN: compiler.cfg.representations -! Virtual register representation selection. - -ERROR: bad-conversion dst src dst-rep src-rep ; - -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 ; - -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 ( -- ) - 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> +! Virtual register representation selection. This is where +! decisions about integer tagging and float and vector boxing +! are made. The appropriate conversion operations inserted +! after a cost analysis. : select-representations ( cfg -- cfg' ) needs-loops + needs-predecessors { + [ compute-components ] [ compute-possibilities ] [ compute-representations ] [ insert-conversions ] [ ] - } cleave - representations get cfg get (>>reps) ; + } cleave ; diff --git a/basis/compiler/cfg/representations/rewrite/authors.txt b/basis/compiler/cfg/representations/rewrite/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/compiler/cfg/representations/rewrite/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/compiler/cfg/representations/rewrite/rewrite.factor b/basis/compiler/cfg/representations/rewrite/rewrite.factor new file mode 100644 index 0000000000..b0da0d190a --- /dev/null +++ b/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 ; diff --git a/basis/compiler/cfg/representations/selection/authors.txt b/basis/compiler/cfg/representations/selection/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/compiler/cfg/representations/selection/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/compiler/cfg/representations/selection/selection.factor b/basis/compiler/cfg/representations/selection/selection.factor new file mode 100644 index 0000000000..6cabe27e85 --- /dev/null +++ b/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 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 ; diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor index 6e09d9885f..a76beca181 100644 --- a/basis/compiler/cfg/rpo/rpo.factor +++ b/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' ) - dupd '[ _ optimize-basic-block ] each-basic-block ; inline +: simple-optimization ( ... cfg quot: ( ... insns -- ... insns' ) -- ... ) + '[ _ optimize-basic-block ] each-basic-block ; inline : needs-post-order ( cfg -- cfg' ) dup post-order drop ; diff --git a/basis/compiler/cfg/save-contexts/save-contexts.factor b/basis/compiler/cfg/save-contexts/save-contexts.factor index c7b6db0671..e5edd7cdff 100644 --- a/basis/compiler/cfg/save-contexts/save-contexts.factor +++ b/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 - int-rep next-vreg-rep + tagged-rep next-vreg-rep + tagged-rep next-vreg-rep \ ##save-context new-insn prefix >>instructions drop ] [ 2drop ] if ; diff --git a/basis/compiler/cfg/ssa/construction/construction-tests.factor b/basis/compiler/cfg/ssa/construction/construction-tests.factor index 3d743176b1..54b02b7450 100644 --- a/basis/compiler/cfg/ssa/construction/construction-tests.factor +++ b/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 diff --git a/basis/compiler/cfg/ssa/cssa/cssa.factor b/basis/compiler/cfg/ssa/cssa/cssa.factor index d58cebac65..06ae6767ca 100644 --- a/basis/compiler/cfg/ssa/cssa/cssa.factor +++ b/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.representations ; +compiler.cfg.instructions ; 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 ; diff --git a/basis/compiler/cfg/ssa/destruction/destruction.factor b/basis/compiler/cfg/ssa/destruction/destruction.factor index 8b766c8114..ede012eb2f 100644 --- a/basis/compiler/cfg/ssa/destruction/destruction.factor +++ b/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 ; +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 - [ defs-vreg ] [ uses-vregs ] bi - 2dup empty? not and [ - first - 2dup [ rep-of ] bi@ eq? - [ try-to-coalesce ] [ 2drop ] if - ] [ 2drop ] if ; + [ temp-vregs [ leader-map get conjoin ] each ] + [ + [ defs-vreg ] [ uses-vregs ] bi + 2dup empty? not and [ + first + 2dup [ rep-of reg-class-of ] bi@ eq? + [ try-to-coalesce ] [ 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 -- ? ) - dup ##copy? [ [ dst>> ] [ src>> ] bi eq? ] [ drop f ] if ; +GENERIC: useful-insn? ( insn -- ? ) -: perform-renaming ( cfg -- ) - leader-map get keys [ dup leader ] H{ } map>assoc renamings set - [ - instructions>> [ - [ rename-insn-defs ] - [ rename-insn-uses ] - [ [ useless-copy? ] [ ##phi? ] bi or not ] tri - ] filter! drop - ] each-basic-block ; +: useful-copy? ( insn -- ? ) + [ dst>> leader ] [ src>> leader ] bi eq? not ; inline + +M: ##copy useful-insn? useful-copy? ; + +M: ##tagged>integer useful-insn? useful-copy? ; + +M: ##phi useful-insn? drop f ; + +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 ; diff --git a/basis/compiler/cfg/ssa/interference/interference-tests.factor b/basis/compiler/cfg/ssa/interference/interference-tests.factor index 2f13331024..c48ae4ad58 100644 --- a/basis/compiler/cfg/ssa/interference/interference-tests.factor +++ b/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 ; diff --git a/basis/compiler/cfg/ssa/liveness/liveness-tests.factor b/basis/compiler/cfg/ssa/liveness/liveness-tests.factor deleted file mode 100644 index bc5807087d..0000000000 --- a/basis/compiler/cfg/ssa/liveness/liveness-tests.factor +++ /dev/null @@ -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 diff --git a/basis/compiler/cfg/ssa/liveness/liveness.factor b/basis/compiler/cfg/ssa/liveness/liveness.factor deleted file mode 100644 index 6e84b8b77d..0000000000 --- a/basis/compiler/cfg/ssa/liveness/liveness.factor +++ /dev/null @@ -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 - -> ] [ 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 ; - - - -: live-in? ( vreg node -- ? ) - [ drop ] live? ; - - - -:: 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 ; diff --git a/basis/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor index 3cfade23e1..8ad55d76d8 100644 --- a/basis/compiler/cfg/stack-frame/stack-frame.factor +++ b/basis/compiler/cfg/stack-frame/stack-frame.factor @@ -1,15 +1,15 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: math math.order namespaces accessors kernel layouts combinators -combinators.smart assocs sequences cpu.architecture ; +USING: math math.order namespaces accessors kernel layouts +combinators combinators.smart assocs sequences cpu.architecture +words compiler.cfg.instructions ; IN: compiler.cfg.stack-frame TUPLE: stack-frame { params integer } { return integer } -{ total-size integer } -{ gc-root-size integer } { spill-area-size integer } +{ total-size integer } { calls-vm? boolean } ; ! Stack frame utilities @@ -19,19 +19,9 @@ TUPLE: stack-frame : spill-offset ( n -- offset ) param-base + ; -: gc-root-base ( -- n ) - stack-frame get spill-area-size>> param-base + ; - -: gc-root-offset ( n -- n' ) gc-root-base + ; - : (stack-frame-size) ( stack-frame -- n ) [ - { - [ params>> ] - [ return>> ] - [ gc-root-size>> ] - [ spill-area-size>> ] - } cleave + [ params>> ] [ return>> ] [ spill-area-size>> ] tri ] sum-outputs ; : max-stack-frame ( frame1 frame2 -- frame3 ) @@ -39,6 +29,11 @@ TUPLE: stack-frame { [ [ params>> ] bi@ max >>params ] [ [ return>> ] bi@ max >>return ] - [ [ gc-root-size>> ] bi@ max >>gc-root-size ] + [ [ spill-area-size>> ] bi@ max >>spill-area-size ] [ [ calls-vm?>> ] bi@ or >>calls-vm? ] - } 2cleave ; \ No newline at end of file + } 2cleave ; + +! PowerPC backend sets frame-required? for ##integer>float too +\ ##spill t "frame-required?" set-word-prop +\ ##unary-float-function t "frame-required?" set-word-prop +\ ##binary-float-function t "frame-required?" set-word-prop \ No newline at end of file diff --git a/basis/compiler/cfg/stacks/finalize/finalize.factor b/basis/compiler/cfg/stacks/finalize/finalize.factor index ad3453704b..41512f206f 100644 --- a/basis/compiler/cfg/stacks/finalize/finalize.factor +++ b/basis/compiler/cfg/stacks/finalize/finalize.factor @@ -44,8 +44,8 @@ ERROR: bad-peek dst loc ; ! If both blocks are subroutine calls, don't bother ! computing anything. 2dup [ kill-block? ] both? [ 2drop ] [ - 2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ] V{ } make - [ 2drop ] [ insert-simple-basic-block ] if-empty + 2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ##branch ] V{ } make + [ 2drop ] [ insert-basic-block ] if-empty ] if ; : visit-block ( bb -- ) diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor index 6cf362c230..fdd6e405f5 100644 --- a/basis/compiler/cfg/stacks/stacks.factor +++ b/basis/compiler/cfg/stacks/stacks.factor @@ -68,9 +68,14 @@ IN: compiler.cfg.stacks : 3inputs ( -- vreg1 vreg2 vreg3 ) (3inputs) -3 inc-d ; +: binary-op ( quot -- ) + [ 2inputs ] dip call ds-push ; inline + +: unary-op ( quot -- ) + [ ds-pop ] dip call ds-push ; inline + ! adjust-d/adjust-r: these are called when other instructions which ! internally adjust the stack height are emitted, such as ##call and ! ##alien-invoke : adjust-d ( n -- ) current-height get [ + ] change-d drop ; : adjust-r ( n -- ) current-height get [ + ] change-r drop ; - diff --git a/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor index 5b2bbf3765..3d7519e14b 100644 --- a/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor +++ b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor @@ -33,14 +33,19 @@ M: ##inc-r visit-insn n>> rs-loc handle-inc ; ERROR: uninitialized-peek insn ; -M: ##peek visit-insn +: visit-peek ( ##peek -- ) dup loc>> [ n>> ] [ class get ] bi ?nth 0 = - [ uninitialized-peek ] [ drop ] if ; + [ uninitialized-peek ] [ drop ] if ; inline -M: ##replace visit-insn +M: ##peek visit-insn visit-peek ; + +: visit-replace ( ##replace -- ) loc>> [ n>> ] [ class get ] bi 2dup length < [ [ 1 ] 2dip set-nth ] [ 2drop ] if ; +M: ##replace visit-insn visit-replace ; +M: ##replace-imm visit-insn visit-replace ; + M: insn visit-insn drop ; : prepare ( pair -- ) diff --git a/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor b/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor index a2885ae26e..b2529655bb 100644 --- a/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor +++ b/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor @@ -1,19 +1,22 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors sequences math combinators combinators.short-circuit -classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo +USING: kernel accessors sequences math combinators +combinators.short-circuit vectors compiler.cfg +compiler.cfg.instructions compiler.cfg.rpo compiler.cfg.utilities ; IN: compiler.cfg.useless-conditionals : delete-conditional? ( bb -- ? ) { [ - instructions>> last class { - ##compare-branch - ##compare-imm-branch - ##compare-float-ordered-branch - ##compare-float-unordered-branch - } member-eq? + instructions>> last { + [ ##compare-branch? ] + [ ##compare-imm-branch? ] + [ ##compare-integer-branch? ] + [ ##compare-integer-imm-branch? ] + [ ##compare-float-ordered-branch? ] + [ ##compare-float-unordered-branch? ] + } 1|| ] [ successors>> first2 [ skip-empty-blocks ] bi@ eq? ] } 1&& ; diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index bee2226ec4..ae860c52ce 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.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 combinators combinators.short-circuit cpu.architecture kernel layouts locals make math namespaces sequences @@ -37,11 +37,24 @@ SYMBOL: visited : skip-empty-blocks ( bb -- bb' ) H{ } clone visited [ (skip-empty-blocks) ] with-variable ; -:: insert-basic-block ( froms to bb -- ) - bb froms V{ } like >>predecessors drop - bb to 1vector >>successors drop - to predecessors>> [ dup froms member-eq? [ drop bb ] when ] map! drop - froms [ successors>> [ dup to eq? [ drop bb ] when ] map! drop ] each ; +:: update-predecessors ( from to bb -- ) + ! Update 'to' predecessors for insertion of 'bb' between + ! 'from' and 'to'. + to predecessors>> [ dup from eq? [ drop bb ] when ] map! drop ; + +:: update-successors ( from to bb -- ) + ! Update 'from' successors for insertion of 'bb' between + ! 'from' and 'to'. + from successors>> [ dup to eq? [ drop bb ] when ] map! drop ; + +:: insert-basic-block ( from to insns -- ) + ! Insert basic block on the edge between 'from' and 'to'. + :> bb + insns V{ } like bb (>>instructions) + V{ from } bb (>>predecessors) + V{ to } bb (>>successors) + from to bb update-predecessors + from to bb update-successors ; : add-instructions ( bb quot -- ) [ instructions>> building ] dip '[ @@ -50,15 +63,6 @@ SYMBOL: visited , ] with-variable ; inline -: ( insns -- bb ) - - swap >vector - \ ##branch new-insn over push - >>instructions ; - -: insert-simple-basic-block ( from to insns -- ) - [ 1vector ] 2dip insert-basic-block ; - : has-phis? ( bb -- ? ) instructions>> first ##phi? ; @@ -79,3 +83,5 @@ SYMBOL: visited : predecessor ( bb -- pred ) predecessors>> first ; inline +: ( dst src -- insn ) + any-rep \ ##copy new-insn ; diff --git a/basis/compiler/cfg/value-numbering/alien/alien.factor b/basis/compiler/cfg/value-numbering/alien/alien.factor new file mode 100644 index 0000000000..190d911ad5 --- /dev/null +++ b/basis/compiler/cfg/value-numbering/alien/alien.factor @@ -0,0 +1,126 @@ +! Copyright (C) 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators combinators.short-circuit fry +kernel make math sequences +cpu.architecture +compiler.cfg.hats +compiler.cfg.utilities +compiler.cfg.registers +compiler.cfg.instructions +compiler.cfg.value-numbering.math +compiler.cfg.value-numbering.graph +compiler.cfg.value-numbering.rewrite ; +IN: compiler.cfg.value-numbering.alien + +M: ##box-displaced-alien rewrite + dup displacement>> vreg>insn zero-insn? + [ [ dst>> ] [ base>> ] bi ] [ drop f ] if ; + +! ##box-displaced-alien f 1 2 3 +! ##unbox-c-ptr 4 1 +! => +! ##box-displaced-alien f 1 2 3 +! ##unbox-c-ptr 5 3 +! ##add 4 5 2 + +: rewrite-unbox-alien ( insn box-insn -- insn ) + [ dst>> ] [ src>> ] bi* ; + +: rewrite-unbox-displaced-alien ( insn box-insn -- insns ) + [ + [ dst>> ] + [ [ base>> ] [ base-class>> ] [ displacement>> ] tri ] bi* + [ ^^unbox-c-ptr ] dip + ##add + ] { } make ; + +: rewrite-unbox-any-c-ptr ( insn -- insn/f ) + dup src>> vreg>insn + { + { [ dup ##box-alien? ] [ rewrite-unbox-alien ] } + { [ dup ##box-displaced-alien? ] [ rewrite-unbox-displaced-alien ] } + [ 2drop f ] + } cond ; + +M: ##unbox-any-c-ptr rewrite rewrite-unbox-any-c-ptr ; + +M: ##unbox-alien rewrite rewrite-unbox-any-c-ptr ; + +! Fuse ##add-imm into ##load-memory(-imm) and ##store-memory(-imm) +! just update the offset in the instruction +: fuse-base-offset? ( insn -- ? ) + base>> vreg>insn ##add-imm? ; + +: fuse-base-offset ( insn -- insn' ) + dup base>> vreg>insn + [ src1>> ] [ src2>> ] bi + [ >>base ] [ '[ _ + ] change-offset ] bi* ; + +! Fuse ##add-imm into ##load-memory and ##store-memory +! just update the offset in the instruction +: fuse-displacement-offset? ( insn -- ? ) + { [ scale>> 0 = ] [ displacement>> vreg>insn ##add-imm? ] } 1&& ; + +: fuse-displacement-offset ( insn -- insn' ) + dup displacement>> vreg>insn + [ src1>> ] [ src2>> ] bi + [ >>displacement ] [ '[ _ + ] change-offset ] bi* ; + +! Fuse ##add into ##load-memory-imm and ##store-memory-imm +! construct a new ##load-memory or ##store-memory with the +! ##add's operand as the displacement +: fuse-displacement? ( insn -- ? ) + base>> vreg>insn ##add? ; + +GENERIC: alien-insn-value ( insn -- value ) + +M: ##load-memory-imm alien-insn-value dst>> ; +M: ##store-memory-imm alien-insn-value src>> ; + +GENERIC: new-alien-insn ( value base displacement scale offset rep c-type insn -- insn ) + +M: ##load-memory-imm new-alien-insn drop \ ##load-memory new-insn ; +M: ##store-memory-imm new-alien-insn drop \ ##store-memory new-insn ; + +: fuse-displacement ( insn -- insn' ) + { + [ alien-insn-value ] + [ base>> vreg>insn [ src1>> ] [ src2>> ] bi ] + [ drop 0 ] + [ offset>> ] + [ rep>> ] + [ c-type>> ] + [ ] + } cleave new-alien-insn ; + +! Fuse ##shl-imm into ##load-memory or ##store-memory +: scale-insn? ( insn -- ? ) + { [ ##shl-imm? ] [ src2>> { 1 2 3 } member? ] } 1&& ; + +: fuse-scale? ( insn -- ? ) + { [ scale>> 0 = ] [ displacement>> vreg>insn scale-insn? ] } 1&& ; + +: fuse-scale ( insn -- insn' ) + dup displacement>> vreg>insn + [ src1>> ] [ src2>> ] bi + [ >>displacement ] [ >>scale ] bi* ; + +: rewrite-memory-op ( insn -- insn/f ) + { + { [ dup fuse-base-offset? ] [ fuse-base-offset ] } + { [ dup fuse-displacement-offset? ] [ fuse-displacement-offset ] } + { [ dup fuse-scale? ] [ fuse-scale ] } + [ drop f ] + } cond ; + +: rewrite-memory-imm-op ( insn -- insn/f ) + { + { [ dup fuse-base-offset? ] [ fuse-base-offset ] } + { [ dup fuse-displacement? ] [ fuse-displacement ] } + [ drop f ] + } cond ; + +M: ##load-memory rewrite rewrite-memory-op ; +M: ##load-memory-imm rewrite rewrite-memory-imm-op ; +M: ##store-memory rewrite rewrite-memory-op ; +M: ##store-memory-imm rewrite rewrite-memory-imm-op ; diff --git a/basis/compiler/cfg/value-numbering/alien/authors.txt b/basis/compiler/cfg/value-numbering/alien/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/compiler/cfg/value-numbering/alien/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/compiler/cfg/value-numbering/comparisons/authors.txt b/basis/compiler/cfg/value-numbering/comparisons/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/compiler/cfg/value-numbering/comparisons/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor b/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor new file mode 100644 index 0000000000..f28092d8cc --- /dev/null +++ b/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor @@ -0,0 +1,209 @@ +! Copyright (C) 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators kernel math math.order namespaces +sequences vectors combinators.short-circuit compiler.cfg +compiler.cfg.comparisons compiler.cfg.instructions +compiler.cfg.registers +compiler.cfg.value-numbering.math +compiler.cfg.value-numbering.graph +compiler.cfg.value-numbering.rewrite ; +IN: compiler.cfg.value-numbering.comparisons + +! Optimizations performed here: +! +! 1) Eliminating intermediate boolean values when the result of +! a comparison is used by a compare-branch +! 2) Folding comparisons where both inputs are literal +! 3) Folding comparisons where both inputs are congruent +! 4) Converting compare instructions into compare-imm instructions + +: fold-compare-imm? ( insn -- ? ) + src1>> vreg>insn literal-insn? ; + +: evaluate-compare-imm ( insn -- ? ) + [ src1>> vreg>literal ] [ src2>> ] [ cc>> ] tri + { + { cc= [ eq? ] } + { cc/= [ eq? not ] } + } case ; + +: fold-compare-integer-imm? ( insn -- ? ) + src1>> vreg>insn ##load-integer? ; + +: evaluate-compare-integer-imm ( insn -- ? ) + [ src1>> vreg>integer ] [ src2>> ] [ cc>> ] tri + [ <=> ] dip evaluate-cc ; + +: >compare< ( insn -- in1 in2 cc ) + [ src1>> ] [ src2>> ] [ cc>> ] tri ; inline + +: >test-vector< ( insn -- src1 temp rep vcc ) + { + [ src1>> ] + [ drop next-vreg ] + [ rep>> ] + [ vcc>> ] + } cleave ; inline + +UNION: scalar-compare-insn + ##compare + ##compare-imm + ##compare-integer + ##compare-integer-imm + ##compare-float-unordered + ##compare-float-ordered ; + +UNION: general-compare-insn scalar-compare-insn ##test-vector ; + +: rewrite-boolean-comparison? ( insn -- ? ) + { + [ src1>> vreg>insn general-compare-insn? ] + [ src2>> not ] + [ cc>> cc/= eq? ] + } 1&& ; inline + +: rewrite-boolean-comparison ( insn -- insn ) + src1>> vreg>insn { + { [ dup ##compare? ] [ >compare< \ ##compare-branch new-insn ] } + { [ dup ##compare-imm? ] [ >compare< \ ##compare-imm-branch new-insn ] } + { [ dup ##compare-integer? ] [ >compare< \ ##compare-integer-branch new-insn ] } + { [ dup ##compare-integer-imm? ] [ >compare< \ ##compare-integer-imm-branch new-insn ] } + { [ dup ##compare-float-unordered? ] [ >compare< \ ##compare-float-unordered-branch new-insn ] } + { [ dup ##compare-float-ordered? ] [ >compare< \ ##compare-float-ordered-branch new-insn ] } + { [ dup ##test-vector? ] [ >test-vector< \ ##test-vector-branch new-insn ] } + } cond ; + +: fold-branch ( ? -- insn ) + 0 1 ? + basic-block get [ nth 1vector ] change-successors drop + \ ##branch new-insn ; + +: fold-compare-imm-branch ( insn -- insn/f ) + evaluate-compare-imm fold-branch ; + +M: ##compare-imm-branch rewrite + { + { [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] } + { [ dup fold-compare-imm? ] [ fold-compare-imm-branch ] } + [ drop f ] + } cond ; + +: fold-compare-integer-imm-branch ( insn -- insn/f ) + evaluate-compare-integer-imm fold-branch ; + +M: ##compare-integer-imm-branch rewrite + { + { [ dup fold-compare-integer-imm? ] [ fold-compare-integer-imm-branch ] } + [ drop f ] + } cond ; + +: swap-compare ( src1 src2 cc swap? -- src1 src2 cc ) + [ [ swap ] dip swap-cc ] when ; inline + +: (>compare-imm-branch) ( insn swap? -- src1 src2 cc ) + [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] dip swap-compare ; inline + +: >compare-imm-branch ( insn swap? -- insn' ) + (>compare-imm-branch) + [ vreg>literal ] dip + \ ##compare-imm-branch new-insn ; inline + +: >compare-integer-imm-branch ( insn swap? -- insn' ) + (>compare-imm-branch) + [ vreg>integer ] dip + \ ##compare-integer-imm-branch new-insn ; inline + +: evaluate-self-compare ( insn -- ? ) + cc>> { cc= cc<= cc>= } member-eq? ; + +: rewrite-self-compare-branch ( insn -- insn' ) + evaluate-self-compare fold-branch ; + +M: ##compare-branch rewrite + { + { [ dup src1>> vreg-immediate-comparand? ] [ t >compare-imm-branch ] } + { [ dup src2>> vreg-immediate-comparand? ] [ f >compare-imm-branch ] } + { [ dup diagonal? ] [ rewrite-self-compare-branch ] } + [ drop f ] + } cond ; + +M: ##compare-integer-branch rewrite + { + { [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-integer-imm-branch ] } + { [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-integer-imm-branch ] } + { [ dup diagonal? ] [ rewrite-self-compare-branch ] } + [ drop f ] + } cond ; + +: (>compare-imm) ( insn swap? -- dst src1 src2 cc ) + [ { [ dst>> ] [ src1>> ] [ src2>> ] [ cc>> ] } cleave ] dip + swap-compare ; inline + +: >compare-imm ( insn swap? -- insn' ) + (>compare-imm) + [ vreg>literal ] dip + next-vreg \ ##compare-imm new-insn ; inline + +: >compare-integer-imm ( insn swap? -- insn' ) + (>compare-imm) + [ vreg>integer ] dip + next-vreg \ ##compare-integer-imm new-insn ; inline + +: >boolean-insn ( insn ? -- insn' ) + [ dst>> ] dip \ ##load-reference new-insn ; + +: rewrite-self-compare ( insn -- insn' ) + dup evaluate-self-compare >boolean-insn ; + +M: ##compare rewrite + { + { [ dup src1>> vreg-immediate-comparand? ] [ t >compare-imm ] } + { [ dup src2>> vreg-immediate-comparand? ] [ f >compare-imm ] } + { [ dup diagonal? ] [ rewrite-self-compare ] } + [ drop f ] + } cond ; + +M: ##compare-integer rewrite + { + { [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-integer-imm ] } + { [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-integer-imm ] } + { [ dup diagonal? ] [ rewrite-self-compare ] } + [ drop f ] + } cond ; + +: rewrite-redundant-comparison? ( insn -- ? ) + { + [ src1>> vreg>insn scalar-compare-insn? ] + [ src2>> not ] + [ cc>> { cc= cc/= } member? ] + } 1&& ; inline + +: rewrite-redundant-comparison ( insn -- insn' ) + [ cc>> ] [ dst>> ] [ src1>> vreg>insn ] tri { + { [ dup ##compare? ] [ >compare< next-vreg \ ##compare new-insn ] } + { [ dup ##compare-imm? ] [ >compare< next-vreg \ ##compare-imm new-insn ] } + { [ dup ##compare-integer? ] [ >compare< next-vreg \ ##compare-integer new-insn ] } + { [ dup ##compare-integer-imm? ] [ >compare< next-vreg \ ##compare-integer-imm new-insn ] } + { [ dup ##compare-float-unordered? ] [ >compare< next-vreg \ ##compare-float-unordered new-insn ] } + { [ dup ##compare-float-ordered? ] [ >compare< next-vreg \ ##compare-float-ordered new-insn ] } + } cond + swap cc= eq? [ [ negate-cc ] change-cc ] when ; + +: fold-compare-imm ( insn -- insn' ) + dup evaluate-compare-imm >boolean-insn ; + +M: ##compare-imm rewrite + { + { [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] } + { [ dup fold-compare-imm? ] [ fold-compare-imm ] } + [ drop f ] + } cond ; + +: fold-compare-integer-imm ( insn -- insn' ) + dup evaluate-compare-integer-imm >boolean-insn ; + +M: ##compare-integer-imm rewrite + { + { [ dup fold-compare-integer-imm? ] [ fold-compare-integer-imm ] } + [ drop f ] + } cond ; diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor index d2e7c2ac86..46e5a09907 100644 --- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor +++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor @@ -1,77 +1,84 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors classes classes.algebra classes.parser -classes.tuple combinators combinators.short-circuit fry +USING: accessors arrays classes classes.algebra combinators fry generic.parser kernel math namespaces quotations sequences slots -splitting words compiler.cfg.instructions +words make +compiler.cfg.instructions compiler.cfg.instructions.syntax compiler.cfg.value-numbering.graph ; +FROM: sequences.private => set-array-nth ; IN: compiler.cfg.value-numbering.expressions -TUPLE: constant-expr < expr value ; - -C: constant-expr - -M: constant-expr equal? - over constant-expr? [ - [ value>> ] bi@ - 2dup [ float? ] both? [ fp-bitwise= ] [ - { [ [ class ] bi@ = ] [ = ] } 2&& - ] if - ] [ 2drop f ] if ; - -TUPLE: reference-expr < expr value ; - -C: reference-expr - -M: reference-expr equal? - over reference-expr? [ [ value>> ] bi@ eq? ] [ 2drop f ] if ; - -M: reference-expr hashcode* - nip value>> identity-hashcode ; - -: constant>vn ( constant -- vn ) expr>vn ; inline - -GENERIC: >expr ( insn -- expr ) - -M: insn >expr drop next-input-expr ; - -M: ##load-immediate >expr val>> ; - -M: ##load-reference >expr obj>> ; - -M: ##load-constant >expr obj>> ; - << +GENERIC: >expr ( insn -- expr ) + : input-values ( slot-specs -- slot-specs' ) - [ type>> { use literal constant } member-eq? ] filter ; + [ type>> { use literal } member-eq? ] filter ; -: expr-class ( insn -- expr ) - name>> "##" ?head drop "-expr" append create-class-in ; +: slot->expr-quot ( slot-spec -- quot ) + [ name>> reader-word 1quotation ] + [ + type>> { + { use [ [ vreg>vn ] ] } + { literal [ [ ] ] } + } case + ] bi append ; -: define-expr-class ( insn expr slot-specs -- ) - [ nip expr ] dip [ name>> ] map define-tuple-class ; +: narray-quot ( length -- quot ) + [ + [ , [ f ] % ] + [ + dup iota [ + - 1 - , [ swap [ set-array-nth ] keep ] % + ] with each + ] bi + ] [ ] make ; -: >expr-quot ( expr slot-specs -- quot ) - [ - [ name>> reader-word 1quotation ] +: >expr-quot ( insn slot-specs -- quot ) + [ + [ literalize , \ swap , ] [ - type>> { - { use [ [ vreg>vn ] ] } - { literal [ [ ] ] } - { constant [ [ constant>vn ] ] } - } case - ] bi append - ] map cleave>quot swap suffix \ boa suffix ; + [ [ slot->expr-quot ] map cleave>quot % ] + [ length 1 + narray-quot % ] + bi + ] bi* + ] [ ] make ; -: define->expr-method ( insn expr slot-specs -- ) - [ 2drop \ >expr create-method-in ] [ >expr-quot nip ] 3bi define ; +: define->expr-method ( insn slot-specs -- ) + [ drop \ >expr create-method-in ] [ >expr-quot ] 2bi define ; -: handle-pure-insn ( insn -- ) - [ ] [ expr-class ] [ "insn-slots" word-prop input-values ] tri - [ define-expr-class ] [ define->expr-method ] 3bi ; - -insn-classes get [ pure-insn class<= ] filter [ handle-pure-insn ] each +insn-classes get +[ pure-insn class<= ] filter +[ + dup "insn-slots" word-prop input-values + define->expr-method +] each >> + +TUPLE: integer-expr value ; + +C: integer-expr + +TUPLE: reference-expr value ; + +C: reference-expr + +M: reference-expr equal? + over reference-expr? [ + [ value>> ] bi@ + 2dup [ float? ] both? + [ fp-bitwise= ] [ eq? ] if + ] [ 2drop f ] if ; + +M: reference-expr hashcode* + nip value>> dup float? [ double>bits ] [ identity-hashcode ] if ; + +M: insn >expr drop input-expr-counter counter neg ; + +M: ##copy >expr "Fail" throw ; + +M: ##load-integer >expr val>> ; + +M: ##load-reference >expr obj>> ; diff --git a/basis/compiler/cfg/value-numbering/folding/authors.txt b/basis/compiler/cfg/value-numbering/folding/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/compiler/cfg/value-numbering/folding/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/compiler/cfg/value-numbering/folding/folding.factor b/basis/compiler/cfg/value-numbering/folding/folding.factor new file mode 100644 index 0000000000..4d79ed5655 --- /dev/null +++ b/basis/compiler/cfg/value-numbering/folding/folding.factor @@ -0,0 +1,39 @@ +! Copyright (C) 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel layouts math math.bitwise +compiler.cfg.instructions +compiler.cfg.value-numbering.graph +compiler.cfg.value-numbering.rewrite ; +IN: compiler.cfg.value-numbering.folding + +: binary-constant-fold? ( insn -- ? ) + src1>> vreg>insn ##load-integer? ; inline + +GENERIC: binary-constant-fold* ( x y insn -- z ) + +M: ##add-imm binary-constant-fold* drop + ; +M: ##sub-imm binary-constant-fold* drop - ; +M: ##mul-imm binary-constant-fold* drop * ; +M: ##and-imm binary-constant-fold* drop bitand ; +M: ##or-imm binary-constant-fold* drop bitor ; +M: ##xor-imm binary-constant-fold* drop bitxor ; +M: ##shr-imm binary-constant-fold* drop [ cell-bits 2^ wrap ] dip neg shift ; +M: ##sar-imm binary-constant-fold* drop neg shift ; +M: ##shl-imm binary-constant-fold* drop shift ; + +: binary-constant-fold ( insn -- insn' ) + [ dst>> ] + [ [ src1>> vreg>integer ] [ src2>> ] [ ] tri binary-constant-fold* ] bi + \ ##load-integer new-insn ; inline + +: unary-constant-fold? ( insn -- ? ) + src>> vreg>insn ##load-integer? ; inline + +GENERIC: unary-constant-fold* ( x insn -- y ) + +M: ##not unary-constant-fold* drop bitnot ; +M: ##neg unary-constant-fold* drop neg ; + +: unary-constant-fold ( insn -- insn' ) + [ dst>> ] [ [ src>> vreg>integer ] [ ] bi unary-constant-fold* ] bi + \ ##load-integer new-insn ; inline diff --git a/basis/compiler/cfg/value-numbering/graph/graph.factor b/basis/compiler/cfg/value-numbering/graph/graph.factor index f380ecd02f..1ea1a52d02 100644 --- a/basis/compiler/cfg/value-numbering/graph/graph.factor +++ b/basis/compiler/cfg/value-numbering/graph/graph.factor @@ -1,46 +1,30 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel math namespaces assocs biassocs ; +USING: accessors kernel math namespaces assocs ; IN: compiler.cfg.value-numbering.graph -SYMBOL: vn-counter - -: next-vn ( -- vn ) vn-counter [ dup 1 + ] change ; - -! biassoc mapping expressions to value numbers -SYMBOL: exprs>vns - -TUPLE: expr ; - -: expr>vn ( expr -- vn ) exprs>vns get [ drop next-vn ] cache ; - -: vn>expr ( vn -- expr ) exprs>vns get value-at ; - -! Expressions whose values are inputs to the basic block. -TUPLE: input-expr < expr n ; - SYMBOL: input-expr-counter -: next-input-expr ( -- expr ) - input-expr-counter counter input-expr boa ; - +! assoc mapping vregs to value numbers +! this is the identity on canonical representatives SYMBOL: vregs>vns -: vreg>vn ( vreg -- vn ) - vregs>vns get [ drop next-input-expr expr>vn ] cache ; +! assoc mapping expressions to value numbers +SYMBOL: exprs>vns -: vn>vreg ( vn -- vreg ) vregs>vns get value-at ; +! assoc mapping value numbers to instructions +SYMBOL: vns>insns + +: vn>insn ( vn -- insn ) vns>insns get at ; + +: vreg>vn ( vreg -- vn ) vregs>vns get [ ] cache ; : set-vn ( vn vreg -- ) vregs>vns get set-at ; -: vreg>expr ( vreg -- expr ) vreg>vn vn>expr ; inline - -: vn>constant ( vn -- constant ) vn>expr value>> ; inline - -: vreg>constant ( vreg -- constant ) vreg>vn vn>constant ; inline +: vreg>insn ( vreg -- insn ) vreg>vn vn>insn ; : init-value-graph ( -- ) - 0 vn-counter set 0 input-expr-counter set - exprs>vns set - vregs>vns set ; + H{ } clone vregs>vns set + H{ } clone exprs>vns set + H{ } clone vns>insns set ; diff --git a/basis/compiler/cfg/value-numbering/math/authors.txt b/basis/compiler/cfg/value-numbering/math/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/compiler/cfg/value-numbering/math/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/compiler/cfg/value-numbering/math/math.factor b/basis/compiler/cfg/value-numbering/math/math.factor new file mode 100644 index 0000000000..c2f63692ac --- /dev/null +++ b/basis/compiler/cfg/value-numbering/math/math.factor @@ -0,0 +1,287 @@ +! Copyright (C) 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators combinators.short-circuit +cpu.architecture fry kernel layouts locals make math sequences +compiler.cfg.instructions +compiler.cfg.registers +compiler.cfg.utilities +compiler.cfg.value-numbering.folding +compiler.cfg.value-numbering.graph +compiler.cfg.value-numbering.rewrite ; +IN: compiler.cfg.value-numbering.math + +: f-insn? ( insn -- ? ) + { [ ##load-reference? ] [ obj>> not ] } 1&& ; inline + +: zero-insn? ( insn -- ? ) + { [ ##load-integer? ] [ val>> 0 = ] } 1&& ; inline + +M: ##tagged>integer rewrite + [ dst>> ] [ src>> vreg>insn ] bi { + { [ dup ##load-integer? ] [ val>> tag-fixnum \ ##load-integer new-insn ] } + { [ dup f-insn? ] [ drop \ f type-number \ ##load-integer new-insn ] } + [ 2drop f ] + } cond ; + +: self-inverse ( insn -- insn' ) + [ dst>> ] [ src>> vreg>insn src>> ] bi ; + +: identity ( insn -- insn' ) + [ dst>> ] [ src1>> ] bi ; + +M: ##neg rewrite + { + { [ dup src>> vreg>insn ##neg? ] [ self-inverse ] } + { [ dup unary-constant-fold? ] [ unary-constant-fold ] } + [ drop f ] + } cond ; + +M: ##not rewrite + { + { [ dup src>> vreg>insn ##not? ] [ self-inverse ] } + { [ dup unary-constant-fold? ] [ unary-constant-fold ] } + [ drop f ] + } cond ; + +! Reassociation converts +! ## *-imm 2 1 X +! ## *-imm 3 2 Y +! into +! ## *-imm 3 1 (X $ Y) +! If * is associative, then $ is the same operation as *. +! In the case of shifts, $ is addition. +: (reassociate) ( insn -- dst src1 src2' src2'' ) + { + [ dst>> ] + [ src1>> vreg>insn [ src1>> ] [ src2>> ] bi ] + [ src2>> ] + } cleave ; inline + +: reassociate ( insn -- dst src1 src2 ) + [ (reassociate) ] keep binary-constant-fold* ; + +: ?new-insn ( dst src1 src2 ? class -- insn/f ) + '[ _ new-insn ] [ 3drop f ] if ; inline + +: reassociate-arithmetic ( insn new-insn -- insn/f ) + [ reassociate dup immediate-arithmetic? ] dip ?new-insn ; inline + +: reassociate-bitwise ( insn new-insn -- insn/f ) + [ reassociate dup immediate-bitwise? ] dip ?new-insn ; inline + +: reassociate-shift ( insn new-insn -- insn/f ) + [ (reassociate) + dup immediate-shift-count? ] dip ?new-insn ; inline + +M: ##add-imm rewrite + { + { [ dup src2>> 0 = ] [ identity ] } + { [ dup binary-constant-fold? ] [ binary-constant-fold ] } + { [ dup src1>> vreg>insn ##add-imm? ] [ \ ##add-imm reassociate-arithmetic ] } + [ drop f ] + } cond ; + +: sub-imm>add-imm ( insn -- insn' ) + [ dst>> ] [ src1>> ] [ src2>> neg ] tri + dup immediate-arithmetic? + \ ##add-imm ?new-insn ; + +M: ##sub-imm rewrite sub-imm>add-imm ; + +! Convert ##mul-imm -1 => ##neg +: mul-to-neg? ( insn -- ? ) + src2>> -1 = ; + +: mul-to-neg ( insn -- insn' ) + [ dst>> ] [ src1>> ] bi \ ##neg new-insn ; + +! Convert ##mul-imm 2^X => ##shl-imm X +: mul-to-shl? ( insn -- ? ) + src2>> power-of-2? ; + +: mul-to-shl ( insn -- insn' ) + [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ; + +! Distribution converts +! ##+-imm 2 1 X +! ##*-imm 3 2 Y +! Into +! ##*-imm 4 1 Y +! ##+-imm 3 4 X*Y +! Where * is mul or shl, + is add or sub +! Have to make sure that X*Y fits in an immediate +:: (distribute) ( outer inner imm temp add-op mul-op -- new-outers/f ) + imm immediate-arithmetic? [ + [ + temp inner src1>> outer src2>> mul-op execute + outer dst>> temp imm add-op execute + ] { } make + ] [ f ] if ; inline + +: distribute-over-add? ( insn -- ? ) + src1>> vreg>insn ##add-imm? ; + +: distribute-over-sub? ( insn -- ? ) + src1>> vreg>insn ##sub-imm? ; + +: distribute ( insn add-op mul-op -- new-insns/f ) + [ + dup src1>> vreg>insn + 2dup src2>> swap [ src2>> ] keep binary-constant-fold* + next-vreg + ] 2dip (distribute) ; inline + +M: ##mul-imm rewrite + { + { [ dup binary-constant-fold? ] [ binary-constant-fold ] } + { [ dup mul-to-neg? ] [ mul-to-neg ] } + { [ dup mul-to-shl? ] [ mul-to-shl ] } + { [ dup src1>> vreg>insn ##mul-imm? ] [ \ ##mul-imm reassociate-arithmetic ] } + { [ dup distribute-over-add? ] [ \ ##add-imm \ ##mul-imm distribute ] } + { [ dup distribute-over-sub? ] [ \ ##sub-imm \ ##mul-imm distribute ] } + [ drop f ] + } cond ; + +M: ##and-imm rewrite + { + { [ dup binary-constant-fold? ] [ binary-constant-fold ] } + { [ dup src1>> vreg>insn ##and-imm? ] [ \ ##and-imm reassociate-bitwise ] } + { [ dup src2>> 0 = ] [ dst>> 0 \ ##load-integer new-insn ] } + { [ dup src2>> -1 = ] [ identity ] } + [ drop f ] + } cond ; + +M: ##or-imm rewrite + { + { [ dup src2>> 0 = ] [ identity ] } + { [ dup src2>> -1 = ] [ dst>> -1 \ ##load-integer new-insn ] } + { [ dup binary-constant-fold? ] [ binary-constant-fold ] } + { [ dup src1>> vreg>insn ##or-imm? ] [ \ ##or-imm reassociate-bitwise ] } + [ drop f ] + } cond ; + +M: ##xor-imm rewrite + { + { [ dup src2>> 0 = ] [ identity ] } + { [ dup src2>> -1 = ] [ [ dst>> ] [ src1>> ] bi \ ##not new-insn ] } + { [ dup binary-constant-fold? ] [ binary-constant-fold ] } + { [ dup src1>> vreg>insn ##xor-imm? ] [ \ ##xor-imm reassociate-bitwise ] } + [ drop f ] + } cond ; + +M: ##shl-imm rewrite + { + { [ dup src2>> 0 = ] [ identity ] } + { [ dup binary-constant-fold? ] [ binary-constant-fold ] } + { [ dup src1>> vreg>insn ##shl-imm? ] [ \ ##shl-imm reassociate-shift ] } + { [ dup distribute-over-add? ] [ \ ##add-imm \ ##shl-imm distribute ] } + { [ dup distribute-over-sub? ] [ \ ##sub-imm \ ##shl-imm distribute ] } + [ drop f ] + } cond ; + +M: ##shr-imm rewrite + { + { [ dup src2>> 0 = ] [ identity ] } + { [ dup binary-constant-fold? ] [ binary-constant-fold ] } + { [ dup src1>> vreg>insn ##shr-imm? ] [ \ ##shr-imm reassociate-shift ] } + [ drop f ] + } cond ; + +M: ##sar-imm rewrite + { + { [ dup src2>> 0 = ] [ identity ] } + { [ dup binary-constant-fold? ] [ binary-constant-fold ] } + { [ dup src1>> vreg>insn ##sar-imm? ] [ \ ##sar-imm reassociate-shift ] } + [ drop f ] + } cond ; + +! Convert +! ##load-integer 2 X +! ##* 3 1 2 +! Where * is an operation with an -imm equivalent into +! ##*-imm 3 1 X +: insn>imm-insn ( insn op swap? -- new-insn ) + swap [ + [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] dip + [ swap ] when vreg>integer + ] dip new-insn ; inline + +M: ##add rewrite + { + { [ dup src2>> vreg-immediate-arithmetic? ] [ \ ##add-imm f insn>imm-insn ] } + { [ dup src1>> vreg-immediate-arithmetic? ] [ \ ##add-imm t insn>imm-insn ] } + [ drop f ] + } cond ; + +: diagonal? ( insn -- ? ) + [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi = ; inline + +! ##sub 2 1 1 => ##load-integer 2 0 +: rewrite-subtraction-identity ( insn -- insn' ) + dst>> 0 \ ##load-integer new-insn ; + +! ##load-integer 1 0 +! ##sub 3 1 2 +! => +! ##neg 3 2 +: sub-to-neg? ( ##sub -- ? ) + src1>> vreg>insn zero-insn? ; + +: sub-to-neg ( ##sub -- insn ) + [ dst>> ] [ src2>> ] bi \ ##neg new-insn ; + +M: ##sub rewrite + { + { [ dup sub-to-neg? ] [ sub-to-neg ] } + { [ dup diagonal? ] [ rewrite-subtraction-identity ] } + { [ dup src2>> vreg-immediate-arithmetic? ] [ \ ##sub-imm f insn>imm-insn ] } + [ drop f ] + } cond ; + +M: ##mul rewrite + { + { [ dup src2>> vreg-immediate-arithmetic? ] [ \ ##mul-imm f insn>imm-insn ] } + { [ dup src1>> vreg-immediate-arithmetic? ] [ \ ##mul-imm t insn>imm-insn ] } + [ drop f ] + } cond ; + +M: ##and rewrite + { + { [ dup diagonal? ] [ identity ] } + { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##and-imm f insn>imm-insn ] } + { [ dup src1>> vreg-immediate-bitwise? ] [ \ ##and-imm t insn>imm-insn ] } + [ drop f ] + } cond ; + +M: ##or rewrite + { + { [ dup diagonal? ] [ identity ] } + { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##or-imm f insn>imm-insn ] } + { [ dup src1>> vreg-immediate-bitwise? ] [ \ ##or-imm t insn>imm-insn ] } + [ drop f ] + } cond ; + +M: ##xor rewrite + { + { [ dup diagonal? ] [ dst>> 0 \ ##load-integer new-insn ] } + { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##xor-imm f insn>imm-insn ] } + { [ dup src1>> vreg-immediate-bitwise? ] [ \ ##xor-imm t insn>imm-insn ] } + [ drop f ] + } cond ; + +M: ##shl rewrite + { + { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##shl-imm f insn>imm-insn ] } + [ drop f ] + } cond ; + +M: ##shr rewrite + { + { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##shr-imm f insn>imm-insn ] } + [ drop f ] + } cond ; + +M: ##sar rewrite + { + { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##sar-imm f insn>imm-insn ] } + [ drop f ] + } cond ; diff --git a/basis/compiler/cfg/value-numbering/misc/authors.txt b/basis/compiler/cfg/value-numbering/misc/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/compiler/cfg/value-numbering/misc/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/compiler/cfg/value-numbering/misc/misc.factor b/basis/compiler/cfg/value-numbering/misc/misc.factor new file mode 100644 index 0000000000..2624b29b61 --- /dev/null +++ b/basis/compiler/cfg/value-numbering/misc/misc.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors cpu.architecture kernel +compiler.cfg.instructions +compiler.cfg.value-numbering.graph +compiler.cfg.value-numbering.rewrite ; +IN: compiler.cfg.value-numbering.misc + +M: ##replace rewrite + [ loc>> ] [ src>> vreg>insn ] bi + dup literal-insn? [ + insn>literal dup immediate-store? + [ swap \ ##replace-imm new-insn ] [ 2drop f ] if + ] [ 2drop f ] if ; diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor index 0fa0314c3e..4f22c5bec2 100644 --- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor +++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor @@ -1,479 +1,48 @@ -! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman, Daniel Ehrenberg. +! Copyright (C) 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators combinators.short-circuit arrays -fry kernel layouts math namespaces sequences cpu.architecture -math.bitwise math.order classes -vectors locals make alien.c-types io.binary grouping -compiler.cfg -compiler.cfg.registers -compiler.cfg.comparisons +USING: accessors combinators combinators.short-circuit kernel +layouts math cpu.architecture compiler.cfg.instructions -compiler.cfg.value-numbering.expressions -compiler.cfg.value-numbering.graph -compiler.cfg.value-numbering.simplify ; +compiler.cfg.value-numbering.graph ; IN: compiler.cfg.value-numbering.rewrite -: vreg-immediate-arithmetic? ( vreg -- ? ) - vreg>expr { - [ constant-expr? ] - [ value>> fixnum? ] - [ value>> immediate-arithmetic? ] - } 1&& ; - -: vreg-immediate-bitwise? ( vreg -- ? ) - vreg>expr { - [ constant-expr? ] - [ value>> fixnum? ] - [ value>> immediate-bitwise? ] - } 1&& ; - ! Outputs f to mean no change - GENERIC: rewrite ( insn -- insn/f ) M: insn rewrite drop f ; -: ##branch-t? ( insn -- ? ) - dup ##compare-imm-branch? [ - { - [ cc>> cc/= eq? ] - [ src2>> \ f type-number eq? ] - } 1&& - ] [ drop f ] if ; inline +! Utilities +GENERIC: insn>integer ( insn -- n ) -: general-compare-expr? ( insn -- ? ) - { - [ compare-expr? ] - [ compare-imm-expr? ] - [ compare-float-unordered-expr? ] - [ compare-float-ordered-expr? ] - } 1|| ; +M: ##load-integer insn>integer val>> ; -: general-or-vector-compare-expr? ( insn -- ? ) - { - [ compare-expr? ] - [ compare-imm-expr? ] - [ compare-float-unordered-expr? ] - [ compare-float-ordered-expr? ] - [ test-vector-expr? ] - } 1|| ; +: vreg>integer ( vreg -- n ) vreg>insn insn>integer ; inline -: rewrite-boolean-comparison? ( insn -- ? ) - dup ##branch-t? [ - src1>> vreg>expr general-or-vector-compare-expr? - ] [ drop f ] if ; inline - -: >compare-expr< ( expr -- in1 in2 cc ) - [ src1>> vn>vreg ] [ src2>> vn>vreg ] [ cc>> ] tri ; inline +: vreg-immediate-arithmetic? ( vreg -- ? ) + vreg>insn { + [ ##load-integer? ] + [ val>> immediate-arithmetic? ] + } 1&& ; -: >compare-imm-expr< ( expr -- in1 in2 cc ) - [ src1>> vn>vreg ] [ src2>> vn>constant ] [ cc>> ] tri ; inline +: vreg-immediate-bitwise? ( vreg -- ? ) + vreg>insn { + [ ##load-integer? ] + [ val>> immediate-bitwise? ] + } 1&& ; -: >test-vector-expr< ( expr -- src1 temp rep vcc ) - { - [ src1>> vn>vreg ] - [ drop next-vreg ] - [ rep>> ] - [ vcc>> ] - } cleave ; inline +UNION: literal-insn ##load-integer ##load-reference ; -: rewrite-boolean-comparison ( expr -- insn ) - src1>> vreg>expr { - { [ dup compare-expr? ] [ >compare-expr< \ ##compare-branch new-insn ] } - { [ dup compare-imm-expr? ] [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] } - { [ dup compare-float-unordered-expr? ] [ >compare-expr< \ ##compare-float-unordered-branch new-insn ] } - { [ dup compare-float-ordered-expr? ] [ >compare-expr< \ ##compare-float-ordered-branch new-insn ] } - { [ dup test-vector-expr? ] [ >test-vector-expr< \ ##test-vector-branch new-insn ] } - } cond ; +GENERIC: insn>literal ( insn -- n ) -: tag-fixnum-expr? ( expr -- ? ) - dup shl-imm-expr? - [ src2>> vn>constant tag-bits get = ] [ drop f ] if ; +M: ##load-integer insn>literal val>> >fixnum ; -: rewrite-tagged-comparison? ( insn -- ? ) - #! Are we comparing two tagged fixnums? Then untag them. - { - [ src1>> vreg>expr tag-fixnum-expr? ] - [ src2>> tag-mask get bitand 0 = ] - } 1&& ; inline +M: ##load-reference insn>literal obj>> ; -: tagged>constant ( n -- n' ) - tag-bits get neg shift ; inline +: vreg>literal ( vreg -- n ) vreg>insn insn>literal ; inline -: (rewrite-tagged-comparison) ( insn -- src1 src2 cc ) - [ src1>> vreg>expr src1>> vn>vreg ] - [ src2>> tagged>constant ] - [ cc>> ] - tri ; inline - -GENERIC: rewrite-tagged-comparison ( insn -- insn/f ) - -M: ##compare-imm-branch rewrite-tagged-comparison - (rewrite-tagged-comparison) \ ##compare-imm-branch new-insn ; - -M: ##compare-imm rewrite-tagged-comparison - [ dst>> ] [ (rewrite-tagged-comparison) ] bi - next-vreg \ ##compare-imm new-insn ; - -: rewrite-redundant-comparison? ( insn -- ? ) - { - [ src1>> vreg>expr general-compare-expr? ] - [ src2>> \ f type-number = ] - [ cc>> { cc= cc/= } member-eq? ] - } 1&& ; inline - -: rewrite-redundant-comparison ( insn -- insn' ) - [ cc>> ] [ dst>> ] [ src1>> vreg>expr ] tri { - { [ dup compare-expr? ] [ >compare-expr< next-vreg \ ##compare new-insn ] } - { [ dup compare-imm-expr? ] [ >compare-imm-expr< next-vreg \ ##compare-imm new-insn ] } - { [ dup compare-float-unordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-unordered new-insn ] } - { [ dup compare-float-ordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-ordered new-insn ] } - } cond - swap cc= eq? [ [ negate-cc ] change-cc ] when ; - -ERROR: bad-comparison ; - -: (fold-compare-imm) ( insn -- ? ) - [ [ src1>> vreg>constant ] [ src2>> ] bi ] [ cc>> ] bi - pick integer? - [ [ <=> ] dip evaluate-cc ] - [ - 2nip { - { cc= [ f ] } - { cc/= [ t ] } - [ bad-comparison ] - } case - ] if ; - -: fold-compare-imm? ( insn -- ? ) - src1>> vreg>expr [ constant-expr? ] [ reference-expr? ] bi or ; - -: fold-branch ( ? -- insn ) - 0 1 ? - basic-block get [ nth 1vector ] change-successors drop - \ ##branch new-insn ; - -: fold-compare-imm-branch ( insn -- insn/f ) - (fold-compare-imm) fold-branch ; - -M: ##compare-imm-branch rewrite - { - { [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] } - { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] } - { [ dup fold-compare-imm? ] [ fold-compare-imm-branch ] } +: vreg-immediate-comparand? ( vreg -- ? ) + vreg>insn { + { [ dup ##load-integer? ] [ val>> tag-fixnum immediate-comparand? ] } + { [ dup ##load-reference? ] [ obj>> immediate-comparand? ] } [ drop f ] } cond ; - -: swap-compare ( src1 src2 cc swap? -- src1 src2 cc ) - [ [ swap ] dip swap-cc ] when ; inline - -: >compare-imm-branch ( insn swap? -- insn' ) - [ - [ src1>> ] - [ src2>> ] - [ cc>> ] - tri - ] dip - swap-compare - [ vreg>constant ] dip - \ ##compare-imm-branch new-insn ; inline - -: self-compare? ( insn -- ? ) - [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ = ; inline - -: (rewrite-self-compare) ( insn -- ? ) - cc>> { cc= cc<= cc>= } member-eq? ; - -: rewrite-self-compare-branch ( insn -- insn' ) - (rewrite-self-compare) fold-branch ; - -M: ##compare-branch rewrite - { - { [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-imm-branch ] } - { [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-imm-branch ] } - { [ dup self-compare? ] [ rewrite-self-compare-branch ] } - [ drop f ] - } cond ; - -: >compare-imm ( insn swap? -- insn' ) - [ - { - [ dst>> ] - [ src1>> ] - [ src2>> ] - [ cc>> ] - } cleave - ] dip - swap-compare - [ vreg>constant ] dip - next-vreg \ ##compare-imm new-insn ; inline - -: >boolean-insn ( insn ? -- insn' ) - [ dst>> ] dip - { - { t [ t \ ##load-constant new-insn ] } - { f [ \ f type-number \ ##load-immediate new-insn ] } - } case ; - -: rewrite-self-compare ( insn -- insn' ) - dup (rewrite-self-compare) >boolean-insn ; - -M: ##compare rewrite - { - { [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-imm ] } - { [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-imm ] } - { [ dup self-compare? ] [ rewrite-self-compare ] } - [ drop f ] - } cond ; - -: fold-compare-imm ( insn -- insn' ) - dup (fold-compare-imm) >boolean-insn ; - -M: ##compare-imm rewrite - { - { [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] } - { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] } - { [ dup fold-compare-imm? ] [ fold-compare-imm ] } - [ drop f ] - } cond ; - -: constant-fold? ( insn -- ? ) - src1>> vreg>expr constant-expr? ; inline - -GENERIC: constant-fold* ( x y insn -- z ) - -M: ##add-imm constant-fold* drop + ; -M: ##sub-imm constant-fold* drop - ; -M: ##mul-imm constant-fold* drop * ; -M: ##and-imm constant-fold* drop bitand ; -M: ##or-imm constant-fold* drop bitor ; -M: ##xor-imm constant-fold* drop bitxor ; -M: ##shr-imm constant-fold* drop [ cell-bits 2^ wrap ] dip neg shift ; -M: ##sar-imm constant-fold* drop neg shift ; -M: ##shl-imm constant-fold* drop shift ; - -: constant-fold ( insn -- insn' ) - [ dst>> ] - [ [ src1>> vreg>constant ] [ src2>> ] [ ] tri constant-fold* ] bi - \ ##load-immediate new-insn ; inline - -: unary-constant-fold? ( insn -- ? ) - src>> vreg>expr constant-expr? ; inline - -GENERIC: unary-constant-fold* ( x insn -- y ) - -M: ##not unary-constant-fold* drop bitnot ; -M: ##neg unary-constant-fold* drop neg ; - -: unary-constant-fold ( insn -- insn' ) - [ dst>> ] - [ [ src>> vreg>constant ] [ ] bi unary-constant-fold* ] bi - \ ##load-immediate new-insn ; inline - -: maybe-unary-constant-fold ( insn -- insn' ) - dup unary-constant-fold? [ unary-constant-fold ] [ drop f ] if ; - -M: ##neg rewrite - maybe-unary-constant-fold ; - -M: ##not rewrite - maybe-unary-constant-fold ; - -: arithmetic-op? ( op -- ? ) - { - ##add - ##add-imm - ##sub - ##sub-imm - ##mul - ##mul-imm - } member-eq? ; - -: immediate? ( value op -- ? ) - arithmetic-op? [ immediate-arithmetic? ] [ immediate-bitwise? ] if ; - -: reassociate ( insn op -- insn ) - [ - { - [ dst>> ] - [ src1>> vreg>expr [ src1>> vn>vreg ] [ src2>> vn>constant ] bi ] - [ src2>> ] - [ ] - } cleave constant-fold* - ] dip - 2dup immediate? [ new-insn ] [ 2drop 2drop f ] if ; inline - -M: ##add-imm rewrite - { - { [ dup constant-fold? ] [ constant-fold ] } - { [ dup src1>> vreg>expr add-imm-expr? ] [ \ ##add-imm reassociate ] } - [ drop f ] - } cond ; - -: sub-imm>add-imm ( insn -- insn' ) - [ dst>> ] [ src1>> ] [ src2>> neg ] tri dup immediate-arithmetic? - [ \ ##add-imm new-insn ] [ 3drop f ] if ; - -M: ##sub-imm rewrite - { - { [ dup constant-fold? ] [ constant-fold ] } - [ sub-imm>add-imm ] - } cond ; - -: mul-to-neg? ( insn -- ? ) - src2>> -1 = ; - -: mul-to-neg ( insn -- insn' ) - [ dst>> ] [ src1>> ] bi \ ##neg new-insn ; - -: mul-to-shl? ( insn -- ? ) - src2>> power-of-2? ; - -: mul-to-shl ( insn -- insn' ) - [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ; - -M: ##mul-imm rewrite - { - { [ dup constant-fold? ] [ constant-fold ] } - { [ dup mul-to-neg? ] [ mul-to-neg ] } - { [ dup mul-to-shl? ] [ mul-to-shl ] } - { [ dup src1>> vreg>expr mul-imm-expr? ] [ \ ##mul-imm reassociate ] } - [ drop f ] - } cond ; - -M: ##and-imm rewrite - { - { [ dup constant-fold? ] [ constant-fold ] } - { [ dup src1>> vreg>expr and-imm-expr? ] [ \ ##and-imm reassociate ] } - [ drop f ] - } cond ; - -M: ##or-imm rewrite - { - { [ dup constant-fold? ] [ constant-fold ] } - { [ dup src1>> vreg>expr or-imm-expr? ] [ \ ##or-imm reassociate ] } - [ drop f ] - } cond ; - -M: ##xor-imm rewrite - { - { [ dup constant-fold? ] [ constant-fold ] } - { [ dup src1>> vreg>expr xor-imm-expr? ] [ \ ##xor-imm reassociate ] } - [ drop f ] - } cond ; - -M: ##shl-imm rewrite - { - { [ dup constant-fold? ] [ constant-fold ] } - [ drop f ] - } cond ; - -M: ##shr-imm rewrite - { - { [ dup constant-fold? ] [ constant-fold ] } - [ drop f ] - } cond ; - -M: ##sar-imm rewrite - { - { [ dup constant-fold? ] [ constant-fold ] } - [ drop f ] - } cond ; - -: insn>imm-insn ( insn op swap? -- ) - swap [ - [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] dip - [ swap ] when vreg>constant - ] dip new-insn ; inline - -: vreg-immediate? ( vreg op -- ? ) - arithmetic-op? - [ vreg-immediate-arithmetic? ] [ vreg-immediate-bitwise? ] if ; - -: rewrite-arithmetic ( insn op -- ? ) - { - { [ over src2>> over vreg-immediate? ] [ f insn>imm-insn ] } - [ 2drop f ] - } cond ; inline - -: rewrite-arithmetic-commutative ( insn op -- ? ) - { - { [ over src2>> over vreg-immediate? ] [ f insn>imm-insn ] } - { [ over src1>> over vreg-immediate? ] [ t insn>imm-insn ] } - [ 2drop f ] - } cond ; inline - -M: ##add rewrite \ ##add-imm rewrite-arithmetic-commutative ; - -: subtraction-identity? ( insn -- ? ) - [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ eq? ; - -: rewrite-subtraction-identity ( insn -- insn' ) - dst>> 0 \ ##load-immediate new-insn ; - -: sub-to-neg? ( ##sub -- ? ) - src1>> vn>expr expr-zero? ; - -: sub-to-neg ( ##sub -- insn ) - [ dst>> ] [ src2>> ] bi \ ##neg new-insn ; - -M: ##sub rewrite - { - { [ dup sub-to-neg? ] [ sub-to-neg ] } - { [ dup subtraction-identity? ] [ rewrite-subtraction-identity ] } - [ \ ##sub-imm rewrite-arithmetic ] - } cond ; - -M: ##mul rewrite \ ##mul-imm rewrite-arithmetic-commutative ; - -M: ##and rewrite \ ##and-imm rewrite-arithmetic-commutative ; - -M: ##or rewrite \ ##or-imm rewrite-arithmetic-commutative ; - -M: ##xor rewrite \ ##xor-imm rewrite-arithmetic-commutative ; - -M: ##shl rewrite \ ##shl-imm rewrite-arithmetic ; - -M: ##shr rewrite \ ##shr-imm rewrite-arithmetic ; - -M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ; - -! ##box-displaced-alien f 1 2 3 -! ##unbox-c-ptr 4 1 -! => -! ##box-displaced-alien f 1 2 3 -! ##unbox-c-ptr 5 3 -! ##add 4 5 2 - -:: rewrite-unbox-displaced-alien ( insn expr -- insns ) - [ - next-vreg :> temp - temp expr base>> vn>vreg expr base-class>> ##unbox-c-ptr - insn dst>> temp expr displacement>> vn>vreg ##add - ] { } make ; - -M: ##unbox-any-c-ptr rewrite - dup src>> vreg>expr dup box-displaced-alien-expr? - [ rewrite-unbox-displaced-alien ] [ 2drop f ] if ; - -! More efficient addressing for alien intrinsics -: rewrite-alien-addressing ( insn -- insn' ) - dup src>> vreg>expr dup add-imm-expr? [ - [ src1>> vn>vreg ] [ src2>> vn>constant ] bi - [ >>src ] [ '[ _ + ] change-offset ] bi* - ] [ 2drop f ] if ; - -M: ##alien-unsigned-1 rewrite rewrite-alien-addressing ; -M: ##alien-unsigned-2 rewrite rewrite-alien-addressing ; -M: ##alien-unsigned-4 rewrite rewrite-alien-addressing ; -M: ##alien-signed-1 rewrite rewrite-alien-addressing ; -M: ##alien-signed-2 rewrite rewrite-alien-addressing ; -M: ##alien-signed-4 rewrite rewrite-alien-addressing ; -M: ##alien-float rewrite rewrite-alien-addressing ; -M: ##alien-double rewrite rewrite-alien-addressing ; -M: ##set-alien-integer-1 rewrite rewrite-alien-addressing ; -M: ##set-alien-integer-2 rewrite rewrite-alien-addressing ; -M: ##set-alien-integer-4 rewrite rewrite-alien-addressing ; -M: ##set-alien-float rewrite rewrite-alien-addressing ; -M: ##set-alien-double rewrite rewrite-alien-addressing ; - diff --git a/basis/compiler/cfg/value-numbering/simd/simd.factor b/basis/compiler/cfg/value-numbering/simd/simd.factor index 16d38bc5bb..1983c07190 100644 --- a/basis/compiler/cfg/value-numbering/simd/simd.factor +++ b/basis/compiler/cfg/value-numbering/simd/simd.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 combinators combinators.short-circuit arrays fry kernel layouts math namespaces sequences cpu.architecture @@ -7,23 +7,23 @@ vectors locals make alien.c-types io.binary grouping math.vectors.simd.intrinsics compiler.cfg compiler.cfg.registers +compiler.cfg.utilities compiler.cfg.comparisons compiler.cfg.instructions -compiler.cfg.value-numbering.expressions +compiler.cfg.value-numbering.math compiler.cfg.value-numbering.graph -compiler.cfg.value-numbering.rewrite -compiler.cfg.value-numbering.simplify ; +compiler.cfg.value-numbering.rewrite ; IN: compiler.cfg.value-numbering.simd -M: ##alien-vector rewrite rewrite-alien-addressing ; -M: ##set-alien-vector rewrite rewrite-alien-addressing ; - ! Some lame constant folding for SIMD intrinsics. Eventually this ! should be redone completely. -: rewrite-shuffle-vector-imm ( insn expr -- insn' ) +: useless-shuffle-vector-imm? ( insn -- ? ) + [ shuffle>> ] [ rep>> rep-length iota ] bi sequence= ; + +: compose-shuffle-vector-imm ( outer inner -- insn' ) 2dup [ rep>> ] bi@ eq? [ - [ [ dst>> ] [ src>> vn>vreg ] bi* ] + [ [ dst>> ] [ src>> ] bi* ] [ [ shuffle>> ] bi@ nths ] [ drop rep>> ] 2tri \ ##shuffle-vector-imm new-insn @@ -32,65 +32,71 @@ M: ##set-alien-vector rewrite rewrite-alien-addressing ; : (fold-shuffle-vector-imm) ( shuffle bytes -- bytes' ) 2dup length swap length /i group nths concat ; -: fold-shuffle-vector-imm ( insn expr -- insn' ) - [ [ dst>> ] [ shuffle>> ] bi ] dip value>> - (fold-shuffle-vector-imm) \ ##load-constant new-insn ; +: fold-shuffle-vector-imm ( outer inner -- insn' ) + [ [ dst>> ] [ shuffle>> ] bi ] [ obj>> ] bi* + (fold-shuffle-vector-imm) \ ##load-reference new-insn ; M: ##shuffle-vector-imm rewrite - dup src>> vreg>expr { - { [ dup shuffle-vector-imm-expr? ] [ rewrite-shuffle-vector-imm ] } - { [ dup reference-expr? ] [ fold-shuffle-vector-imm ] } - { [ dup constant-expr? ] [ fold-shuffle-vector-imm ] } + dup src>> vreg>insn { + { [ over useless-shuffle-vector-imm? ] [ drop [ dst>> ] [ src>> ] bi ] } + { [ dup ##shuffle-vector-imm? ] [ compose-shuffle-vector-imm ] } + { [ dup ##load-reference? ] [ fold-shuffle-vector-imm ] } [ 2drop f ] } cond ; : (fold-scalar>vector) ( insn bytes -- insn' ) [ [ dst>> ] [ rep>> rep-length ] bi ] dip concat - \ ##load-constant new-insn ; + \ ##load-reference new-insn ; -: fold-scalar>vector ( insn expr -- insn' ) - value>> over rep>> { +: fold-scalar>vector ( outer inner -- insn' ) + obj>> over rep>> { { float-4-rep [ float>bits 4 >le (fold-scalar>vector) ] } { double-2-rep [ double>bits 8 >le (fold-scalar>vector) ] } [ [ untag-fixnum ] dip rep-component-type heap-size >le (fold-scalar>vector) ] } case ; M: ##scalar>vector rewrite - dup src>> vreg>expr dup constant-expr? - [ fold-scalar>vector ] [ 2drop f ] if ; + dup src>> vreg>insn { + { [ dup ##load-reference? ] [ fold-scalar>vector ] } + { [ dup ##vector>scalar? ] [ [ dst>> ] [ src>> ] bi* ] } + [ 2drop f ] + } cond ; M: ##xor-vector rewrite - dup [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi eq? + dup diagonal? [ [ dst>> ] [ rep>> ] bi \ ##zero-vector new-insn ] [ drop f ] if ; -: vector-not? ( expr -- ? ) +: vector-not? ( insn -- ? ) { - [ not-vector-expr? ] + [ ##not-vector? ] [ { - [ xor-vector-expr? ] - [ [ src1>> ] [ src2>> ] bi [ vn>expr fill-vector-expr? ] either? ] + [ ##xor-vector? ] + [ [ src1>> ] [ src2>> ] bi [ vreg>insn ##fill-vector? ] either? ] } 1&& ] } 1|| ; -GENERIC: vector-not-src ( expr -- vreg ) -M: not-vector-expr vector-not-src src>> vn>vreg ; -M: xor-vector-expr vector-not-src - dup src1>> vn>expr fill-vector-expr? [ src2>> ] [ src1>> ] if vn>vreg ; +GENERIC: vector-not-src ( insn -- vreg ) + +M: ##not-vector vector-not-src + src>> ; + +M: ##xor-vector vector-not-src + dup src1>> vreg>insn ##fill-vector? [ src2>> ] [ src1>> ] if ; M: ##and-vector rewrite { - { [ dup src1>> vreg>expr vector-not? ] [ + { [ dup src1>> vreg>insn vector-not? ] [ { [ dst>> ] - [ src1>> vreg>expr vector-not-src ] + [ src1>> vreg>insn vector-not-src ] [ src2>> ] [ rep>> ] } cleave \ ##andn-vector new-insn ] } - { [ dup src2>> vreg>expr vector-not? ] [ + { [ dup src2>> vreg>insn vector-not? ] [ { [ dst>> ] - [ src2>> vreg>expr vector-not-src ] + [ src2>> vreg>insn vector-not-src ] [ src1>> ] [ rep>> ] } cleave \ ##andn-vector new-insn @@ -99,22 +105,11 @@ M: ##and-vector rewrite } cond ; M: ##andn-vector rewrite - dup src1>> vreg>expr vector-not? [ + dup src1>> vreg>insn vector-not? [ { [ dst>> ] - [ src1>> vreg>expr vector-not-src ] + [ src1>> vreg>insn vector-not-src ] [ src2>> ] [ rep>> ] } cleave \ ##and-vector new-insn ] [ drop f ] if ; - -M: scalar>vector-expr simplify* - src>> vn>expr { - { [ dup vector>scalar-expr? ] [ src>> ] } - [ drop f ] - } cond ; - -M: shuffle-vector-imm-expr simplify* - [ src>> ] [ shuffle>> ] [ rep>> rep-length iota ] tri - sequence= [ drop f ] unless ; - diff --git a/basis/compiler/cfg/value-numbering/simplify/simplify.factor b/basis/compiler/cfg/value-numbering/simplify/simplify.factor deleted file mode 100644 index 7a95711b01..0000000000 --- a/basis/compiler/cfg/value-numbering/simplify/simplify.factor +++ /dev/null @@ -1,143 +0,0 @@ -! Copyright (C) 2008, 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors combinators classes math layouts -sequences -compiler.cfg.instructions -compiler.cfg.value-numbering.graph -compiler.cfg.value-numbering.expressions ; -IN: compiler.cfg.value-numbering.simplify - -! Return value of f means we didn't simplify. -GENERIC: simplify* ( expr -- vn/expr/f ) - -M: copy-expr simplify* src>> ; - -: simplify-unbox-alien ( expr -- vn/expr/f ) - src>> vn>expr dup box-alien-expr? [ src>> ] [ drop f ] if ; - -M: unbox-alien-expr simplify* simplify-unbox-alien ; - -M: unbox-any-c-ptr-expr simplify* simplify-unbox-alien ; - -: expr-zero? ( expr -- ? ) T{ constant-expr f 0 } = ; inline - -: expr-one? ( expr -- ? ) T{ constant-expr f 1 } = ; inline - -: expr-neg-one? ( expr -- ? ) T{ constant-expr f -1 } = ; inline - -: >unary-expr< ( expr -- in ) src>> vn>expr ; inline - -M: neg-expr simplify* - >unary-expr< { - { [ dup neg-expr? ] [ src>> ] } - [ drop f ] - } cond ; - -M: not-expr simplify* - >unary-expr< { - { [ dup not-expr? ] [ src>> ] } - [ drop f ] - } cond ; - -: >binary-expr< ( expr -- in1 in2 ) - [ src1>> vn>expr ] [ src2>> vn>expr ] bi ; inline - -: simplify-add ( expr -- vn/expr/f ) - >binary-expr< { - { [ over expr-zero? ] [ nip ] } - { [ dup expr-zero? ] [ drop ] } - [ 2drop f ] - } cond ; inline - -M: add-expr simplify* simplify-add ; -M: add-imm-expr simplify* simplify-add ; - -: simplify-sub ( expr -- vn/expr/f ) - >binary-expr< { - { [ dup expr-zero? ] [ drop ] } - [ 2drop f ] - } cond ; inline - -M: sub-expr simplify* simplify-sub ; -M: sub-imm-expr simplify* simplify-sub ; - -: simplify-mul ( expr -- vn/expr/f ) - >binary-expr< { - { [ over expr-one? ] [ drop ] } - { [ dup expr-one? ] [ drop ] } - [ 2drop f ] - } cond ; inline - -M: mul-expr simplify* simplify-mul ; -M: mul-imm-expr simplify* simplify-mul ; - -: simplify-and ( expr -- vn/expr/f ) - >binary-expr< { - { [ 2dup eq? ] [ drop ] } - [ 2drop f ] - } cond ; inline - -M: and-expr simplify* simplify-and ; -M: and-imm-expr simplify* simplify-and ; - -: simplify-or ( expr -- vn/expr/f ) - >binary-expr< { - { [ 2dup eq? ] [ drop ] } - { [ over expr-zero? ] [ nip ] } - { [ dup expr-zero? ] [ drop ] } - [ 2drop f ] - } cond ; inline - -M: or-expr simplify* simplify-or ; -M: or-imm-expr simplify* simplify-or ; - -: simplify-xor ( expr -- vn/expr/f ) - >binary-expr< { - { [ over expr-zero? ] [ nip ] } - { [ dup expr-zero? ] [ drop ] } - [ 2drop f ] - } cond ; inline - -M: xor-expr simplify* simplify-xor ; -M: xor-imm-expr simplify* simplify-xor ; - -: useless-shr? ( in1 in2 -- ? ) - over shl-imm-expr? - [ [ src2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline - -: simplify-shr ( expr -- vn/expr/f ) - >binary-expr< { - { [ 2dup useless-shr? ] [ drop src1>> ] } - { [ dup expr-zero? ] [ drop ] } - [ 2drop f ] - } cond ; inline - -M: shr-expr simplify* simplify-shr ; -M: shr-imm-expr simplify* simplify-shr ; - -: simplify-shl ( expr -- vn/expr/f ) - >binary-expr< { - { [ dup expr-zero? ] [ drop ] } - [ 2drop f ] - } cond ; inline - -M: shl-expr simplify* simplify-shl ; -M: shl-imm-expr simplify* simplify-shl ; - -M: box-displaced-alien-expr simplify* - [ base>> ] [ displacement>> ] bi { - { [ dup vn>expr expr-zero? ] [ drop ] } - [ 2drop f ] - } cond ; - -M: expr simplify* drop f ; - -: simplify ( expr -- vn ) - dup simplify* { - { [ dup not ] [ drop expr>vn ] } - { [ dup expr? ] [ expr>vn nip ] } - { [ dup integer? ] [ nip ] } - } cond ; - -: number-values ( insn -- ) - [ >expr simplify ] [ dst>> ] bi set-vn ; diff --git a/basis/compiler/cfg/value-numbering/simplify/summary.txt b/basis/compiler/cfg/value-numbering/simplify/summary.txt deleted file mode 100644 index 1027c83ce4..0000000000 --- a/basis/compiler/cfg/value-numbering/simplify/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Algebraic simplification of expressions diff --git a/basis/compiler/cfg/value-numbering/slots/authors.txt b/basis/compiler/cfg/value-numbering/slots/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/compiler/cfg/value-numbering/slots/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/compiler/cfg/value-numbering/slots/slots.factor b/basis/compiler/cfg/value-numbering/slots/slots.factor new file mode 100644 index 0000000000..7c2b562a84 --- /dev/null +++ b/basis/compiler/cfg/value-numbering/slots/slots.factor @@ -0,0 +1,24 @@ +! Copyright (C) 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators.short-circuit cpu.architecture fry +kernel math +compiler.cfg.instructions +compiler.cfg.value-numbering.graph +compiler.cfg.value-numbering.rewrite ; +IN: compiler.cfg.value-numbering.slots + +: simplify-slot-addressing? ( insn -- ? ) + complex-addressing? + [ slot>> vreg>insn ##add-imm? ] [ drop f ] if ; + +: simplify-slot-addressing ( insn -- insn/f ) + dup simplify-slot-addressing? [ + dup slot>> vreg>insn + [ src1>> >>slot ] + [ src2>> over scale>> '[ _ _ shift - ] change-tag ] + bi + ] [ drop f ] if ; + +M: ##slot rewrite simplify-slot-addressing ; +M: ##set-slot rewrite simplify-slot-addressing ; +M: ##write-barrier rewrite simplify-slot-addressing ; diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index ac992ff98d..7c281d0fe7 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -4,7 +4,9 @@ cpu.architecture tools.test kernel math combinators.short-circuit accessors sequences compiler.cfg.predecessors locals compiler.cfg.dce compiler.cfg.ssa.destruction compiler.cfg.loop-detection compiler.cfg.representations compiler.cfg assocs vectors arrays -layouts literals namespaces alien compiler.cfg.value-numbering.simd ; +layouts literals namespaces alien compiler.cfg.value-numbering.simd +system ; +QUALIFIED-WITH: alien.c-types c IN: compiler.cfg.value-numbering.tests : trim-temps ( insns -- insns ) @@ -12,6 +14,8 @@ IN: compiler.cfg.value-numbering.tests dup { [ ##compare? ] [ ##compare-imm? ] + [ ##compare-integer? ] + [ ##compare-integer-imm? ] [ ##compare-float-unordered? ] [ ##compare-float-ordered? ] [ ##test-vector? ] @@ -22,89 +26,195 @@ IN: compiler.cfg.value-numbering.tests ! Folding constants together [ { - T{ ##load-constant f 0 0.0 } - T{ ##load-constant f 1 -0.0 } - T{ ##replace f 0 D 0 } - T{ ##replace f 1 D 1 } + T{ ##load-reference f 0 0.0 } + T{ ##load-reference f 1 -0.0 } } ] [ { - T{ ##load-constant f 0 0.0 } - T{ ##load-constant f 1 -0.0 } - T{ ##replace f 0 D 0 } - T{ ##replace f 1 D 1 } + T{ ##load-reference f 0 0.0 } + T{ ##load-reference f 1 -0.0 } } value-numbering-step ] unit-test [ { - T{ ##load-constant f 0 0.0 } + T{ ##load-reference f 0 0.0 } T{ ##copy f 1 0 any-rep } - T{ ##replace f 0 D 0 } - T{ ##replace f 1 D 1 } } ] [ { - T{ ##load-constant f 0 0.0 } - T{ ##load-constant f 1 0.0 } - T{ ##replace f 0 D 0 } - T{ ##replace f 1 D 1 } + T{ ##load-reference f 0 0.0 } + T{ ##load-reference f 1 0.0 } } value-numbering-step ] unit-test [ { - T{ ##load-constant f 0 t } + T{ ##load-reference f 0 t } T{ ##copy f 1 0 any-rep } - T{ ##replace f 0 D 0 } - T{ ##replace f 1 D 1 } } ] [ { - T{ ##load-constant f 0 t } - T{ ##load-constant f 1 t } - T{ ##replace f 0 D 0 } - T{ ##replace f 1 D 1 } + T{ ##load-reference f 0 t } + T{ ##load-reference f 1 t } } value-numbering-step ] unit-test -! Compare propagation +! ##load-reference/##replace fusion +cpu x86? [ + [ + { + T{ ##load-integer f 0 10 } + T{ ##replace-imm f 10 D 0 } + } + ] [ + { + T{ ##load-integer f 0 10 } + T{ ##replace f 0 D 0 } + } value-numbering-step + ] unit-test + + [ + { + T{ ##load-reference f 0 f } + T{ ##replace-imm f f D 0 } + } + ] [ + { + T{ ##load-reference f 0 f } + T{ ##replace f 0 D 0 } + } value-numbering-step + ] unit-test +] when + +cpu x86.32? [ + [ + { + T{ ##load-reference f 0 + } + T{ ##replace-imm f 10 D + } + } + ] [ + { + T{ ##load-reference f 0 + } + T{ ##replace f 0 D 0 } + } value-numbering-step + ] unit-test +] when + +cpu x86.64? [ + [ + { + T{ ##load-integer f 0 10,000,000,000 } + T{ ##replace f 0 D 0 } + } + ] [ + { + T{ ##load-integer f 0 10,000,000,000 } + T{ ##replace f 0 D 0 } + } value-numbering-step + ] unit-test + + ! Boundary case + [ + { + T{ ##load-integer f 0 HEX: 7fffffff } + T{ ##replace f 0 D 0 } + } + ] [ + { + T{ ##load-integer f 0 HEX: 7fffffff } + T{ ##replace f 0 D 0 } + } value-numbering-step + ] unit-test +] when + +! Double compare elimination [ { - T{ ##load-reference f 1 + } - T{ ##peek f 2 D 0 } - T{ ##compare f 4 2 1 cc> } + T{ ##peek f 1 D 1 } + T{ ##peek f 2 D 2 } + T{ ##compare f 4 2 1 cc= } T{ ##copy f 6 4 any-rep } T{ ##replace f 6 D 0 } } ] [ { - T{ ##load-reference f 1 + } - T{ ##peek f 2 D 0 } - T{ ##compare f 4 2 1 cc> } - T{ ##compare-imm f 6 4 $[ \ f type-number ] cc/= } + T{ ##peek f 1 D 1 } + T{ ##peek f 2 D 2 } + T{ ##compare f 4 2 1 cc= } + T{ ##compare-imm f 6 4 f cc/= } T{ ##replace f 6 D 0 } } value-numbering-step trim-temps ] unit-test [ { - T{ ##load-reference f 1 + } - T{ ##peek f 2 D 0 } - T{ ##compare f 4 2 1 cc<= } - T{ ##compare f 6 2 1 cc/<= } + T{ ##peek f 1 D 1 } + T{ ##compare-imm f 2 1 16 cc= } + T{ ##copy f 3 2 any-rep } + T{ ##replace f 3 D 0 } + } +] [ + { + T{ ##peek f 1 D 1 } + T{ ##compare-imm f 2 1 16 cc= } + T{ ##compare-imm f 3 2 f cc/= } + T{ ##replace f 3 D 0 } + } value-numbering-step trim-temps +] unit-test + +[ + { + T{ ##peek f 1 D 1 } + T{ ##peek f 2 D 2 } + T{ ##compare-integer f 4 2 1 cc> } + T{ ##copy f 6 4 any-rep } T{ ##replace f 6 D 0 } } ] [ { - T{ ##load-reference f 1 + } - T{ ##peek f 2 D 0 } - T{ ##compare f 4 2 1 cc<= } - T{ ##compare-imm f 6 4 $[ \ f type-number ] cc= } + T{ ##peek f 1 D 1 } + T{ ##peek f 2 D 2 } + T{ ##compare-integer f 4 2 1 cc> } + T{ ##compare-imm f 6 4 f cc/= } T{ ##replace f 6 D 0 } } value-numbering-step trim-temps ] unit-test +[ + { + T{ ##peek f 1 D 1 } + T{ ##peek f 2 D 2 } + T{ ##compare-integer f 4 2 1 cc<= } + T{ ##compare-integer f 6 2 1 cc/<= } + T{ ##replace f 6 D 0 } + } +] [ + { + T{ ##peek f 1 D 1 } + T{ ##peek f 2 D 2 } + T{ ##compare-integer f 4 2 1 cc<= } + T{ ##compare-imm f 6 4 f cc= } + T{ ##replace f 6 D 0 } + } value-numbering-step trim-temps +] unit-test + +[ + { + T{ ##peek f 1 D 1 } + T{ ##compare-integer-imm f 2 1 100 cc<= } + T{ ##compare-integer-imm f 3 1 100 cc/<= } + T{ ##replace f 3 D 0 } + } +] [ + { + T{ ##peek f 1 D 1 } + T{ ##compare-integer-imm f 2 1 100 cc<= } + T{ ##compare-imm f 3 2 f cc= } + T{ ##replace f 3 D 0 } + } value-numbering-step trim-temps +] unit-test + [ { T{ ##peek f 8 D 0 } @@ -118,7 +228,7 @@ IN: compiler.cfg.value-numbering.tests T{ ##peek f 8 D 0 } T{ ##peek f 9 D -1 } T{ ##compare-float-unordered f 12 8 9 cc< } - T{ ##compare-imm f 14 12 $[ \ f type-number ] cc= } + T{ ##compare-imm f 14 12 f cc= } T{ ##replace f 14 D 0 } } value-numbering-step trim-temps ] unit-test @@ -127,15 +237,31 @@ IN: compiler.cfg.value-numbering.tests { T{ ##peek f 29 D -1 } T{ ##peek f 30 D -2 } - T{ ##compare f 33 29 30 cc<= } - T{ ##compare-branch f 29 30 cc<= } + T{ ##compare f 33 29 30 cc= } + T{ ##compare-branch f 29 30 cc= } } ] [ { T{ ##peek f 29 D -1 } T{ ##peek f 30 D -2 } - T{ ##compare f 33 29 30 cc<= } - T{ ##compare-imm-branch f 33 $[ \ f type-number ] cc/= } + T{ ##compare f 33 29 30 cc= } + T{ ##compare-imm-branch f 33 f cc/= } + } value-numbering-step trim-temps +] unit-test + +[ + { + T{ ##peek f 29 D -1 } + T{ ##peek f 30 D -2 } + T{ ##compare-integer f 33 29 30 cc<= } + T{ ##compare-integer-branch f 29 30 cc<= } + } +] [ + { + T{ ##peek f 29 D -1 } + T{ ##peek f 30 D -2 } + T{ ##compare-integer f 33 29 30 cc<= } + T{ ##compare-imm-branch f 33 f cc/= } } value-numbering-step trim-temps ] unit-test @@ -149,21 +275,37 @@ IN: compiler.cfg.value-numbering.tests { T{ ##peek f 1 D -1 } T{ ##test-vector f 2 1 f float-4-rep vcc-any } - T{ ##compare-imm-branch f 2 $[ \ f type-number ] cc/= } + T{ ##compare-imm-branch f 2 f cc/= } } value-numbering-step trim-temps ] unit-test -! Immediate operand conversion +cpu x86.32? [ + [ + { + T{ ##peek f 1 D 0 } + T{ ##compare-imm f 2 1 + cc= } + T{ ##compare-imm-branch f 1 + cc= } + } + ] [ + { + T{ ##peek f 1 D 0 } + T{ ##compare-imm f 2 1 + cc= } + T{ ##compare-imm-branch f 2 f cc/= } + } value-numbering-step trim-temps + ] unit-test +] when + +! Immediate operand fusion [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##add-imm f 2 0 100 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##add f 2 0 1 } } value-numbering-step ] unit-test @@ -171,13 +313,13 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##add-imm f 2 0 100 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##add f 2 1 0 } } value-numbering-step ] unit-test @@ -185,13 +327,13 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##add-imm f 2 0 -100 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##sub f 2 0 1 } } value-numbering-step ] unit-test @@ -199,7 +341,7 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 0 } + T{ ##load-integer f 1 0 } } ] [ { @@ -211,13 +353,13 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##mul-imm f 2 0 100 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##mul f 2 0 1 } } value-numbering-step ] unit-test @@ -225,13 +367,13 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##mul-imm f 2 0 100 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##mul f 2 1 0 } } value-numbering-step ] unit-test @@ -251,13 +393,13 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 -1 } + T{ ##load-integer f 1 -1 } T{ ##neg f 2 0 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 -1 } + T{ ##load-integer f 1 -1 } T{ ##mul f 2 0 1 } } value-numbering-step ] unit-test @@ -265,13 +407,13 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 -1 } + T{ ##load-integer f 1 -1 } T{ ##neg f 2 0 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 -1 } + T{ ##load-integer f 1 -1 } T{ ##mul f 2 1 0 } } value-numbering-step ] unit-test @@ -279,13 +421,13 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 0 } + T{ ##load-integer f 1 0 } T{ ##neg f 2 0 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 0 } + T{ ##load-integer f 1 0 } T{ ##sub f 2 1 0 } } value-numbering-step ] unit-test @@ -293,19 +435,33 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 0 } + T{ ##load-integer f 1 0 } T{ ##neg f 2 0 } T{ ##copy f 3 0 any-rep } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 0 } + T{ ##load-integer f 1 0 } T{ ##sub f 2 1 0 } T{ ##sub f 3 1 2 } } value-numbering-step ] unit-test +[ + { + T{ ##peek f 0 D 0 } + T{ ##neg f 1 0 } + T{ ##copy f 2 0 any-rep } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##neg f 1 0 } + T{ ##neg f 2 1 } + } value-numbering-step +] unit-test + [ { T{ ##peek f 0 D 0 } @@ -323,13 +479,13 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##and-imm f 2 0 100 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##and f 2 0 1 } } value-numbering-step ] unit-test @@ -337,13 +493,13 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##and-imm f 2 0 100 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##and f 2 1 0 } } value-numbering-step ] unit-test @@ -351,13 +507,13 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##or-imm f 2 0 100 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##or f 2 0 1 } } value-numbering-step ] unit-test @@ -365,13 +521,13 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##or-imm f 2 0 100 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##or f 2 1 0 } } value-numbering-step ] unit-test @@ -379,13 +535,13 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##xor-imm f 2 0 100 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##xor f 2 0 1 } } value-numbering-step ] unit-test @@ -393,13 +549,13 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##xor-imm f 2 0 100 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##xor f 2 1 0 } } value-numbering-step ] unit-test @@ -407,27 +563,13 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } - T{ ##compare-imm f 2 0 100 cc<= } + T{ ##load-integer f 1 100 } + T{ ##compare-imm f 2 0 100 cc= } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } - T{ ##compare f 2 0 1 cc<= } - } value-numbering-step trim-temps -] unit-test - -[ - { - T{ ##peek f 0 D 0 } - T{ ##load-constant f 1 3.5 } - T{ ##compare f 2 0 1 cc= } - } -] [ - { - T{ ##peek f 0 D 0 } - T{ ##load-constant f 1 3.5 } + T{ ##load-integer f 1 100 } T{ ##compare f 2 0 1 cc= } } value-numbering-step trim-temps ] unit-test @@ -435,74 +577,439 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } - T{ ##compare-imm f 2 0 100 cc>= } + T{ ##load-integer f 1 100 } + T{ ##compare-integer-imm f 2 0 100 cc<= } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } - T{ ##compare f 2 1 0 cc<= } + T{ ##load-integer f 1 100 } + T{ ##compare-integer f 2 0 1 cc<= } + } value-numbering-step trim-temps +] unit-test + +cpu x86.32? [ + [ + { + T{ ##peek f 0 D 0 } + T{ ##load-reference f 1 + } + T{ ##compare-imm f 2 0 + cc= } + } + ] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-reference f 1 + } + T{ ##compare f 2 0 1 cc= } + } value-numbering-step trim-temps + ] unit-test + + [ + { + T{ ##peek f 0 D 0 } + T{ ##load-reference f 1 + } + T{ ##compare-imm-branch f 0 + cc= } + } + ] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-reference f 1 + } + T{ ##compare-branch f 0 1 cc= } + } value-numbering-step trim-temps + ] unit-test +] when + +cpu x86.32? [ + [ + { + T{ ##peek f 0 D 0 } + T{ ##load-reference f 1 3.5 } + T{ ##compare f 2 0 1 cc= } + } + ] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-reference f 1 3.5 } + T{ ##compare f 2 0 1 cc= } + } value-numbering-step trim-temps + ] unit-test + + [ + { + T{ ##peek f 0 D 0 } + T{ ##load-reference f 1 3.5 } + T{ ##compare-branch f 0 1 cc= } + } + ] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-reference f 1 3.5 } + T{ ##compare-branch f 0 1 cc= } + } value-numbering-step trim-temps + ] unit-test +] unless + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-integer f 1 100 } + T{ ##compare-integer-imm f 2 0 100 cc>= } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-integer f 1 100 } + T{ ##compare-integer f 2 1 0 cc<= } } value-numbering-step trim-temps ] unit-test [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } - T{ ##compare-imm-branch f 0 100 cc<= } + T{ ##load-integer f 1 100 } + T{ ##compare-integer-imm-branch f 0 100 cc<= } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } - T{ ##compare-branch f 0 1 cc<= } + T{ ##load-integer f 1 100 } + T{ ##compare-integer-branch f 0 1 cc<= } } value-numbering-step ] unit-test [ { T{ ##peek f 0 D 0 } - T{ ##load-constant f 1 3.5 } - T{ ##compare-branch f 0 1 cc= } + T{ ##load-integer f 1 100 } + T{ ##compare-integer-imm-branch f 0 100 cc>= } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-constant f 1 3.5 } - T{ ##compare-branch f 0 1 cc= } + T{ ##load-integer f 1 100 } + T{ ##compare-integer-branch f 1 0 cc<= } + } value-numbering-step trim-temps +] unit-test + +! Compare folding +[ + { + T{ ##load-integer f 1 100 } + T{ ##load-integer f 2 200 } + T{ ##load-reference f 3 t } + } +] [ + { + T{ ##load-integer f 1 100 } + T{ ##load-integer f 2 200 } + T{ ##compare-integer f 3 1 2 cc<= } } value-numbering-step trim-temps ] unit-test +[ + { + T{ ##load-integer f 1 100 } + T{ ##load-integer f 2 200 } + T{ ##load-reference f 3 f } + } +] [ + { + T{ ##load-integer f 1 100 } + T{ ##load-integer f 2 200 } + T{ ##compare-integer f 3 1 2 cc= } + } value-numbering-step trim-temps +] unit-test + +[ + { + T{ ##load-integer f 1 100 } + T{ ##load-reference f 2 f } + } +] [ + { + T{ ##load-integer f 1 100 } + T{ ##compare-integer-imm f 2 1 123 cc= } + } value-numbering-step trim-temps +] unit-test + +[ + { + T{ ##load-integer f 1 10 } + T{ ##load-integer f 2 20 } + T{ ##load-reference f 3 f } + } +] [ + { + T{ ##load-integer f 1 10 } + T{ ##load-integer f 2 20 } + T{ ##compare-integer f 3 1 2 cc= } + } value-numbering-step +] unit-test + +[ + { + T{ ##load-integer f 1 1 } + T{ ##load-integer f 2 2 } + T{ ##load-reference f 3 t } + } +] [ + { + T{ ##load-integer f 1 1 } + T{ ##load-integer f 2 2 } + T{ ##compare-integer f 3 1 2 cc/= } + } value-numbering-step +] unit-test + +[ + { + T{ ##load-integer f 1 1 } + T{ ##load-integer f 2 2 } + T{ ##load-reference f 3 t } + } +] [ + { + T{ ##load-integer f 1 1 } + T{ ##load-integer f 2 2 } + T{ ##compare-integer f 3 1 2 cc< } + } value-numbering-step +] unit-test + +[ + { + T{ ##load-integer f 1 10 } + T{ ##load-integer f 2 20 } + T{ ##load-reference f 3 f } + } +] [ + { + T{ ##load-integer f 1 10 } + T{ ##load-integer f 2 20 } + T{ ##compare-integer f 3 2 1 cc< } + } value-numbering-step +] unit-test + [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } - T{ ##compare-imm-branch f 0 100 cc>= } + T{ ##load-reference f 1 f } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } - T{ ##compare-branch f 1 0 cc<= } - } value-numbering-step trim-temps + T{ ##compare-integer f 1 0 0 cc< } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##copy f 1 0 any-rep } + T{ ##load-reference f 2 f } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##copy f 1 0 any-rep } + T{ ##compare-integer f 2 0 1 cc< } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-reference f 1 t } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##compare-integer f 1 0 0 cc<= } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-reference f 1 f } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##compare-integer f 1 0 0 cc> } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-reference f 1 t } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##compare-integer f 1 0 0 cc>= } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-reference f 1 f } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##compare-integer f 1 0 0 cc/= } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-reference f 1 t } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##compare-integer f 1 0 0 cc= } + } value-numbering-step +] unit-test + +[ + { + T{ ##load-integer f 1 10 } + T{ ##load-reference f 2 t } + } +] [ + { + T{ ##load-integer f 1 10 } + T{ ##compare-imm f 2 1 10 cc= } + } value-numbering-step +] unit-test + +[ + { + T{ ##load-integer f 1 10 } + T{ ##load-reference f 2 f } + } +] [ + { + T{ ##load-integer f 1 10 } + T{ ##compare-imm f 2 1 20 cc= } + } value-numbering-step +] unit-test + +[ + { + T{ ##load-integer f 1 10 } + T{ ##load-reference f 2 t } + } +] [ + { + T{ ##load-integer f 1 10 } + T{ ##compare-imm f 2 1 100 cc/= } + } value-numbering-step +] unit-test + +[ + { + T{ ##load-integer f 1 10 } + T{ ##load-reference f 2 f } + } +] [ + { + T{ ##load-integer f 1 10 } + T{ ##compare-imm f 2 1 10 cc/= } + } value-numbering-step +] unit-test + +cpu x86.32? [ + [ + { + T{ ##load-reference f 1 + } + T{ ##load-reference f 2 f } + } + ] [ + { + T{ ##load-reference f 1 + } + T{ ##compare-imm f 2 1 + cc/= } + } value-numbering-step + ] unit-test + + [ + { + T{ ##load-reference f 1 + } + T{ ##load-reference f 2 t } + } + ] [ + { + T{ ##load-reference f 1 + } + T{ ##compare-imm f 2 1 * cc/= } + } value-numbering-step + ] unit-test + + [ + { + T{ ##load-reference f 1 + } + T{ ##load-reference f 2 t } + } + ] [ + { + T{ ##load-reference f 1 + } + T{ ##compare-imm f 2 1 + cc= } + } value-numbering-step + ] unit-test + + [ + { + T{ ##load-reference f 1 + } + T{ ##load-reference f 2 f } + } + ] [ + { + T{ ##load-reference f 1 + } + T{ ##compare-imm f 2 1 * cc= } + } value-numbering-step + ] unit-test +] when + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-reference f 1 t } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##compare f 1 0 0 cc= } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-reference f 1 f } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##compare f 1 0 0 cc/= } + } value-numbering-step ] unit-test ! Reassociation [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##add-imm f 2 0 100 } - T{ ##load-immediate f 3 50 } + T{ ##load-integer f 3 50 } T{ ##add-imm f 4 0 150 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##add f 2 0 1 } - T{ ##load-immediate f 3 50 } + T{ ##load-integer f 3 50 } T{ ##add f 4 2 3 } } value-numbering-step ] unit-test @@ -510,17 +1017,17 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##add-imm f 2 0 100 } - T{ ##load-immediate f 3 50 } + T{ ##load-integer f 3 50 } T{ ##add-imm f 4 0 150 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##add f 2 1 0 } - T{ ##load-immediate f 3 50 } + T{ ##load-integer f 3 50 } T{ ##add f 4 3 2 } } value-numbering-step ] unit-test @@ -528,17 +1035,17 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##add-imm f 2 0 100 } - T{ ##load-immediate f 3 50 } + T{ ##load-integer f 3 50 } T{ ##add-imm f 4 0 50 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##add f 2 0 1 } - T{ ##load-immediate f 3 50 } + T{ ##load-integer f 3 50 } T{ ##sub f 4 2 3 } } value-numbering-step ] unit-test @@ -546,17 +1053,17 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##add-imm f 2 0 -100 } - T{ ##load-immediate f 3 50 } + T{ ##load-integer f 3 50 } T{ ##add-imm f 4 0 -150 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##sub f 2 0 1 } - T{ ##load-immediate f 3 50 } + T{ ##load-integer f 3 50 } T{ ##sub f 4 2 3 } } value-numbering-step ] unit-test @@ -564,17 +1071,17 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##mul-imm f 2 0 100 } - T{ ##load-immediate f 3 50 } + T{ ##load-integer f 3 50 } T{ ##mul-imm f 4 0 5000 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##mul f 2 0 1 } - T{ ##load-immediate f 3 50 } + T{ ##load-integer f 3 50 } T{ ##mul f 4 2 3 } } value-numbering-step ] unit-test @@ -582,17 +1089,17 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##mul-imm f 2 0 100 } - T{ ##load-immediate f 3 50 } + T{ ##load-integer f 3 50 } T{ ##mul-imm f 4 0 5000 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##mul f 2 1 0 } - T{ ##load-immediate f 3 50 } + T{ ##load-integer f 3 50 } T{ ##mul f 4 3 2 } } value-numbering-step ] unit-test @@ -600,17 +1107,17 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##and-imm f 2 0 100 } - T{ ##load-immediate f 3 50 } + T{ ##load-integer f 3 50 } T{ ##and-imm f 4 0 32 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##and f 2 0 1 } - T{ ##load-immediate f 3 50 } + T{ ##load-integer f 3 50 } T{ ##and f 4 2 3 } } value-numbering-step ] unit-test @@ -618,17 +1125,17 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##and-imm f 2 0 100 } - T{ ##load-immediate f 3 50 } + T{ ##load-integer f 3 50 } T{ ##and-imm f 4 0 32 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##and f 2 1 0 } - T{ ##load-immediate f 3 50 } + T{ ##load-integer f 3 50 } T{ ##and f 4 3 2 } } value-numbering-step ] unit-test @@ -636,17 +1143,17 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##or-imm f 2 0 100 } - T{ ##load-immediate f 3 50 } + T{ ##load-integer f 3 50 } T{ ##or-imm f 4 0 118 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##or f 2 0 1 } - T{ ##load-immediate f 3 50 } + T{ ##load-integer f 3 50 } T{ ##or f 4 2 3 } } value-numbering-step ] unit-test @@ -654,17 +1161,17 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##or-imm f 2 0 100 } - T{ ##load-immediate f 3 50 } + T{ ##load-integer f 3 50 } T{ ##or-imm f 4 0 118 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##or f 2 1 0 } - T{ ##load-immediate f 3 50 } + T{ ##load-integer f 3 50 } T{ ##or f 4 3 2 } } value-numbering-step ] unit-test @@ -672,17 +1179,17 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##xor-imm f 2 0 100 } - T{ ##load-immediate f 3 50 } + T{ ##load-integer f 3 50 } T{ ##xor-imm f 4 0 86 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##xor f 2 0 1 } - T{ ##load-immediate f 3 50 } + T{ ##load-integer f 3 50 } T{ ##xor f 4 2 3 } } value-numbering-step ] unit-test @@ -690,27 +1197,209 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##xor-imm f 2 0 100 } - T{ ##load-immediate f 3 50 } + T{ ##load-integer f 3 50 } T{ ##xor-imm f 4 0 86 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 100 } + T{ ##load-integer f 1 100 } T{ ##xor f 2 1 0 } - T{ ##load-immediate f 3 50 } + T{ ##load-integer f 3 50 } T{ ##xor f 4 3 2 } } value-numbering-step ] unit-test +[ + { + T{ ##peek f 0 D 0 } + T{ ##shl-imm f 1 0 10 } + T{ ##shl-imm f 2 0 21 } + T{ ##replace f 2 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##shl-imm f 1 0 10 } + T{ ##shl-imm f 2 1 11 } + T{ ##replace f 2 D 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##shl-imm f 1 0 10 } + T{ ##shl-imm f 2 1 $[ cell-bits 1 - ] } + T{ ##replace f 2 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##shl-imm f 1 0 10 } + T{ ##shl-imm f 2 1 $[ cell-bits 1 - ] } + T{ ##replace f 2 D 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##sar-imm f 1 0 10 } + T{ ##sar-imm f 2 0 21 } + T{ ##replace f 2 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##sar-imm f 1 0 10 } + T{ ##sar-imm f 2 1 11 } + T{ ##replace f 2 D 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##sar-imm f 1 0 10 } + T{ ##sar-imm f 2 1 $[ cell-bits 1 - ] } + T{ ##replace f 2 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##sar-imm f 1 0 10 } + T{ ##sar-imm f 2 1 $[ cell-bits 1 - ] } + T{ ##replace f 2 D 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##shr-imm f 1 0 10 } + T{ ##shr-imm f 2 0 21 } + T{ ##replace f 2 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##shr-imm f 1 0 10 } + T{ ##shr-imm f 2 1 11 } + T{ ##replace f 2 D 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##shr-imm f 1 0 10 } + T{ ##shr-imm f 2 1 $[ cell-bits 1 - ] } + T{ ##replace f 2 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##shr-imm f 1 0 10 } + T{ ##shr-imm f 2 1 $[ cell-bits 1 - ] } + T{ ##replace f 2 D 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##shr-imm f 1 0 10 } + T{ ##sar-imm f 2 1 11 } + T{ ##replace f 2 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##shr-imm f 1 0 10 } + T{ ##sar-imm f 2 1 11 } + T{ ##replace f 2 D 0 } + } value-numbering-step +] unit-test + +! Distributive law +2 \ vreg-counter set-global + +[ + { + T{ ##peek f 0 D 0 } + T{ ##add-imm f 1 0 10 } + T{ ##shl-imm f 3 0 2 } + T{ ##add-imm f 2 3 40 } + T{ ##replace f 2 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##add-imm f 1 0 10 } + T{ ##shl-imm f 2 1 2 } + T{ ##replace f 2 D 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##add-imm f 1 0 10 } + T{ ##mul-imm f 4 0 3 } + T{ ##add-imm f 2 4 30 } + T{ ##replace f 2 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##add-imm f 1 0 10 } + T{ ##mul-imm f 2 1 3 } + T{ ##replace f 2 D 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##add-imm f 1 0 -10 } + T{ ##shl-imm f 5 0 2 } + T{ ##add-imm f 2 5 -40 } + T{ ##replace f 2 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##sub-imm f 1 0 10 } + T{ ##shl-imm f 2 1 2 } + T{ ##replace f 2 D 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##add-imm f 1 0 -10 } + T{ ##mul-imm f 6 0 3 } + T{ ##add-imm f 2 6 -30 } + T{ ##replace f 2 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##sub-imm f 1 0 10 } + T{ ##mul-imm f 2 1 3 } + T{ ##replace f 2 D 0 } + } value-numbering-step +] unit-test + ! Simplification [ { T{ ##peek f 0 D 0 } T{ ##peek f 1 D 1 } - T{ ##load-immediate f 2 0 } T{ ##copy f 3 0 any-rep } T{ ##replace f 3 D 0 } } @@ -718,8 +1407,7 @@ IN: compiler.cfg.value-numbering.tests { T{ ##peek f 0 D 0 } T{ ##peek f 1 D 1 } - T{ ##sub f 2 1 1 } - T{ ##add f 3 0 2 } + T{ ##add-imm f 3 0 0 } T{ ##replace f 3 D 0 } } value-numbering-step ] unit-test @@ -728,7 +1416,6 @@ IN: compiler.cfg.value-numbering.tests { T{ ##peek f 0 D 0 } T{ ##peek f 1 D 1 } - T{ ##load-immediate f 2 0 } T{ ##copy f 3 0 any-rep } T{ ##replace f 3 D 0 } } @@ -736,8 +1423,7 @@ IN: compiler.cfg.value-numbering.tests { T{ ##peek f 0 D 0 } T{ ##peek f 1 D 1 } - T{ ##sub f 2 1 1 } - T{ ##sub f 3 0 2 } + T{ ##or-imm f 3 0 0 } T{ ##replace f 3 D 0 } } value-numbering-step ] unit-test @@ -746,7 +1432,6 @@ IN: compiler.cfg.value-numbering.tests { T{ ##peek f 0 D 0 } T{ ##peek f 1 D 1 } - T{ ##load-immediate f 2 0 } T{ ##copy f 3 0 any-rep } T{ ##replace f 3 D 0 } } @@ -754,8 +1439,7 @@ IN: compiler.cfg.value-numbering.tests { T{ ##peek f 0 D 0 } T{ ##peek f 1 D 1 } - T{ ##sub f 2 1 1 } - T{ ##or f 3 0 2 } + T{ ##xor-imm f 3 0 0 } T{ ##replace f 3 D 0 } } value-numbering-step ] unit-test @@ -763,33 +1447,175 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##peek f 1 D 1 } - T{ ##load-immediate f 2 0 } - T{ ##copy f 3 0 any-rep } - T{ ##replace f 3 D 0 } + T{ ##load-integer f 1 0 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##peek f 1 D 1 } - T{ ##sub f 2 1 1 } - T{ ##xor f 3 0 2 } - T{ ##replace f 3 D 0 } + T{ ##and-imm f 1 0 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##copy f 1 0 any-rep } + T{ ##replace f 1 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##and-imm f 1 0 -1 } + T{ ##replace f 1 D 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##copy f 1 0 any-rep } + T{ ##replace f 1 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##and f 1 0 0 } + T{ ##replace f 1 D 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##copy f 1 0 any-rep } + T{ ##replace f 1 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##or-imm f 1 0 0 } + T{ ##replace f 1 D 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-integer f 1 -1 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##or-imm f 1 0 -1 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##copy f 1 0 any-rep } + T{ ##replace f 1 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##or f 1 0 0 } + T{ ##replace f 1 D 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##copy f 1 0 any-rep } + T{ ##replace f 1 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##xor-imm f 1 0 0 } + T{ ##replace f 1 D 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##not f 1 0 } + T{ ##replace f 1 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##xor-imm f 1 0 -1 } + T{ ##replace f 1 D 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-integer f 1 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##xor f 1 0 0 } } value-numbering-step ] unit-test [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 1 } T{ ##copy f 2 0 any-rep } T{ ##replace f 2 D 0 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 1 } - T{ ##mul f 2 0 1 } + T{ ##mul-imm f 2 0 1 } + T{ ##replace f 2 D 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##copy f 2 0 any-rep } + T{ ##replace f 2 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##shl-imm f 2 0 0 } + T{ ##replace f 2 D 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##copy f 2 0 any-rep } + T{ ##replace f 2 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##shr-imm f 2 0 0 } + T{ ##replace f 2 D 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##copy f 2 0 any-rep } + T{ ##replace f 2 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##sar-imm f 2 0 0 } T{ ##replace f 2 D 0 } } value-numbering-step ] unit-test @@ -798,15 +1624,15 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 1 } - T{ ##load-immediate f 2 3 } - T{ ##load-immediate f 3 4 } + T{ ##load-integer f 1 1 } + T{ ##load-integer f 2 3 } + T{ ##load-integer f 3 4 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 1 } - T{ ##load-immediate f 2 3 } + T{ ##load-integer f 1 1 } + T{ ##load-integer f 2 3 } T{ ##add f 3 1 2 } } value-numbering-step ] unit-test @@ -814,15 +1640,15 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 1 } - T{ ##load-immediate f 2 3 } - T{ ##load-immediate f 3 -2 } + T{ ##load-integer f 1 1 } + T{ ##load-integer f 2 3 } + T{ ##load-integer f 3 -2 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 1 } - T{ ##load-immediate f 2 3 } + T{ ##load-integer f 1 1 } + T{ ##load-integer f 2 3 } T{ ##sub f 3 1 2 } } value-numbering-step ] unit-test @@ -830,15 +1656,15 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 2 } - T{ ##load-immediate f 2 3 } - T{ ##load-immediate f 3 6 } + T{ ##load-integer f 1 2 } + T{ ##load-integer f 2 3 } + T{ ##load-integer f 3 6 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 2 } - T{ ##load-immediate f 2 3 } + T{ ##load-integer f 1 2 } + T{ ##load-integer f 2 3 } T{ ##mul f 3 1 2 } } value-numbering-step ] unit-test @@ -846,15 +1672,15 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 2 } - T{ ##load-immediate f 2 1 } - T{ ##load-immediate f 3 0 } + T{ ##load-integer f 1 2 } + T{ ##load-integer f 2 1 } + T{ ##load-integer f 3 0 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 2 } - T{ ##load-immediate f 2 1 } + T{ ##load-integer f 1 2 } + T{ ##load-integer f 2 1 } T{ ##and f 3 1 2 } } value-numbering-step ] unit-test @@ -862,15 +1688,15 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 2 } - T{ ##load-immediate f 2 1 } - T{ ##load-immediate f 3 3 } + T{ ##load-integer f 1 2 } + T{ ##load-integer f 2 1 } + T{ ##load-integer f 3 3 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 2 } - T{ ##load-immediate f 2 1 } + T{ ##load-integer f 1 2 } + T{ ##load-integer f 2 1 } T{ ##or f 3 1 2 } } value-numbering-step ] unit-test @@ -878,15 +1704,15 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 2 } - T{ ##load-immediate f 2 3 } - T{ ##load-immediate f 3 1 } + T{ ##load-integer f 1 2 } + T{ ##load-integer f 2 3 } + T{ ##load-integer f 3 1 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 2 } - T{ ##load-immediate f 2 3 } + T{ ##load-integer f 1 2 } + T{ ##load-integer f 2 3 } T{ ##xor f 3 1 2 } } value-numbering-step ] unit-test @@ -894,13 +1720,13 @@ IN: compiler.cfg.value-numbering.tests [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 1 } - T{ ##load-immediate f 3 8 } + T{ ##load-integer f 1 1 } + T{ ##load-integer f 3 8 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 1 } + T{ ##load-integer f 1 1 } T{ ##shl-imm f 3 1 3 } } value-numbering-step ] unit-test @@ -909,13 +1735,13 @@ cell 8 = [ [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 -1 } - T{ ##load-immediate f 3 HEX: ffffffffffff } + T{ ##load-integer f 1 -1 } + T{ ##load-integer f 3 HEX: ffffffffffff } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 -1 } + T{ ##load-integer f 1 -1 } T{ ##shr-imm f 3 1 16 } } value-numbering-step ] unit-test @@ -924,13 +1750,13 @@ cell 8 = [ [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 -8 } - T{ ##load-immediate f 3 -4 } + T{ ##load-integer f 1 -8 } + T{ ##load-integer f 3 -4 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 -8 } + T{ ##load-integer f 1 -8 } T{ ##sar-imm f 3 1 1 } } value-numbering-step ] unit-test @@ -939,14 +1765,14 @@ cell 8 = [ [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 65536 } - T{ ##load-immediate f 2 140737488355328 } + T{ ##load-integer f 1 65536 } + T{ ##load-integer f 2 140737488355328 } T{ ##add f 3 0 2 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 65536 } + T{ ##load-integer f 1 65536 } T{ ##shl-imm f 2 1 31 } T{ ##add f 3 0 2 } } value-numbering-step @@ -955,13 +1781,13 @@ cell 8 = [ [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 2 140737488355328 } + T{ ##load-integer f 2 140737488355328 } T{ ##add f 3 0 2 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 2 140737488355328 } + T{ ##load-integer f 2 140737488355328 } T{ ##add f 3 0 2 } } value-numbering-step ] unit-test @@ -969,14 +1795,14 @@ cell 8 = [ [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 2 2147483647 } + T{ ##load-integer f 2 2147483647 } T{ ##add-imm f 3 0 2147483647 } T{ ##add-imm f 4 3 2147483647 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 2 2147483647 } + T{ ##load-integer f 2 2147483647 } T{ ##add f 3 0 2 } T{ ##add f 4 3 2 } } value-numbering-step @@ -986,13 +1812,13 @@ cell 8 = [ [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 1 } - T{ ##load-immediate f 2 -1 } + T{ ##load-integer f 1 1 } + T{ ##load-integer f 2 -1 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 1 } + T{ ##load-integer f 1 1 } T{ ##neg f 2 1 } } value-numbering-step ] unit-test @@ -1000,24 +1826,101 @@ cell 8 = [ [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 1 } - T{ ##load-immediate f 2 -2 } + T{ ##load-integer f 1 1 } + T{ ##load-integer f 2 -2 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 1 } + T{ ##load-integer f 1 1 } T{ ##not f 2 1 } } value-numbering-step ] unit-test -! Displaced alien optimizations +! ##tagged>integer constant folding +[ + { + T{ ##load-reference f 1 f } + T{ ##load-integer f 2 $[ \ f type-number ] } + T{ ##copy f 3 2 any-rep } + } +] [ + { + T{ ##load-reference f 1 f } + T{ ##tagged>integer f 2 1 } + T{ ##and-imm f 3 2 15 } + } value-numbering-step +] unit-test + +[ + { + T{ ##load-integer f 1 100 } + T{ ##load-integer f 2 $[ 100 tag-fixnum ] } + T{ ##load-integer f 3 $[ 100 tag-fixnum 1 + ] } + } +] [ + { + T{ ##load-integer f 1 100 } + T{ ##tagged>integer f 2 1 } + T{ ##add-imm f 3 2 1 } + } value-numbering-step +] unit-test + +! Alien boxing and unboxing +[ + { + T{ ##peek f 0 D 0 } + T{ ##box-alien f 1 0 } + T{ ##copy f 2 0 any-rep } + T{ ##replace f 2 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##box-alien f 1 0 } + T{ ##unbox-alien f 2 1 } + T{ ##replace f 2 D 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##box-alien f 1 0 } + T{ ##copy f 2 0 any-rep } + T{ ##replace f 2 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##box-alien f 1 0 } + T{ ##unbox-any-c-ptr f 2 1 } + T{ ##replace f 2 D 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-integer f 2 0 } + T{ ##copy f 1 0 any-rep } + T{ ##replace f 1 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-integer f 2 0 } + T{ ##box-displaced-alien f 1 2 0 c-ptr } + T{ ##replace f 1 D 0 } + } value-numbering-step +] unit-test + 3 vreg-counter set-global [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 2 16 } + T{ ##load-integer f 2 16 } T{ ##box-displaced-alien f 1 2 0 c-ptr } T{ ##unbox-any-c-ptr f 4 0 } T{ ##add-imm f 3 4 16 } @@ -1025,7 +1928,7 @@ cell 8 = [ ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 2 16 } + T{ ##load-integer f 2 16 } T{ ##box-displaced-alien f 1 2 0 c-ptr } T{ ##unbox-any-c-ptr f 3 1 } } value-numbering-step @@ -1036,7 +1939,7 @@ cell 8 = [ [ { T{ ##box-alien f 0 1 } - T{ ##load-immediate f 2 16 } + T{ ##load-integer f 2 16 } T{ ##box-displaced-alien f 3 2 0 c-ptr } T{ ##copy f 5 1 any-rep } T{ ##add-imm f 4 5 16 } @@ -1044,7 +1947,7 @@ cell 8 = [ ] [ { T{ ##box-alien f 0 1 } - T{ ##load-immediate f 2 16 } + T{ ##load-integer f 2 16 } T{ ##box-displaced-alien f 3 2 0 c-ptr } T{ ##unbox-any-c-ptr f 4 3 } } value-numbering-step @@ -1055,148 +1958,20 @@ cell 8 = [ [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 2 0 } + T{ ##load-integer f 2 0 } T{ ##copy f 3 0 any-rep } T{ ##replace f 3 D 1 } } ] [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 2 0 } + T{ ##load-integer f 2 0 } T{ ##box-displaced-alien f 3 2 0 c-ptr } T{ ##replace f 3 D 1 } } value-numbering-step ] unit-test -! Branch folding -[ - { - T{ ##load-immediate f 1 10 } - T{ ##load-immediate f 2 20 } - T{ ##load-immediate f 3 $[ \ f type-number ] } - } -] [ - { - T{ ##load-immediate f 1 10 } - T{ ##load-immediate f 2 20 } - T{ ##compare f 3 1 2 cc= } - } value-numbering-step -] unit-test - -[ - { - T{ ##load-immediate f 1 1 } - T{ ##load-immediate f 2 2 } - T{ ##load-constant f 3 t } - } -] [ - { - T{ ##load-immediate f 1 1 } - T{ ##load-immediate f 2 2 } - T{ ##compare f 3 1 2 cc/= } - } value-numbering-step -] unit-test - -[ - { - T{ ##load-immediate f 1 1 } - T{ ##load-immediate f 2 2 } - T{ ##load-constant f 3 t } - } -] [ - { - T{ ##load-immediate f 1 1 } - T{ ##load-immediate f 2 2 } - T{ ##compare f 3 1 2 cc< } - } value-numbering-step -] unit-test - -[ - { - T{ ##load-immediate f 1 10 } - T{ ##load-immediate f 2 20 } - T{ ##load-immediate f 3 $[ \ f type-number ] } - } -] [ - { - T{ ##load-immediate f 1 10 } - T{ ##load-immediate f 2 20 } - T{ ##compare f 3 2 1 cc< } - } value-numbering-step -] unit-test - -[ - { - T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 $[ \ f type-number ] } - } -] [ - { - T{ ##peek f 0 D 0 } - T{ ##compare f 1 0 0 cc< } - } value-numbering-step -] unit-test - -[ - { - T{ ##peek f 0 D 0 } - T{ ##load-constant f 1 t } - } -] [ - { - T{ ##peek f 0 D 0 } - T{ ##compare f 1 0 0 cc<= } - } value-numbering-step -] unit-test - -[ - { - T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 $[ \ f type-number ] } - } -] [ - { - T{ ##peek f 0 D 0 } - T{ ##compare f 1 0 0 cc> } - } value-numbering-step -] unit-test - -[ - { - T{ ##peek f 0 D 0 } - T{ ##load-constant f 1 t } - } -] [ - { - T{ ##peek f 0 D 0 } - T{ ##compare f 1 0 0 cc>= } - } value-numbering-step -] unit-test - -[ - { - T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 $[ \ f type-number ] } - } -] [ - { - T{ ##peek f 0 D 0 } - T{ ##compare f 1 0 0 cc/= } - } value-numbering-step -] unit-test - -[ - { - T{ ##peek f 0 D 0 } - T{ ##load-constant f 1 t } - } -] [ - { - T{ ##peek f 0 D 0 } - T{ ##compare f 1 0 0 cc= } - } value-numbering-step -] unit-test - +! Various SIMD simplifications [ { T{ ##vector>scalar f 1 0 float-4-rep } @@ -1245,13 +2020,13 @@ cell 8 = [ [ { - T{ ##load-constant f 0 $[ 55 tag-fixnum ] } - T{ ##load-constant f 1 B{ 55 0 0 0 55 0 0 0 55 0 0 0 55 0 0 0 } } - T{ ##copy f 2 1 any-rep } + T{ ##load-reference f 0 $[ 55 tag-fixnum ] } + T{ ##load-reference f 1 B{ 55 0 0 0 55 0 0 0 55 0 0 0 55 0 0 0 } } + T{ ##load-reference f 2 B{ 55 0 0 0 55 0 0 0 55 0 0 0 55 0 0 0 } } } ] [ { - T{ ##load-constant f 0 $[ 55 tag-fixnum ] } + T{ ##load-reference f 0 $[ 55 tag-fixnum ] } T{ ##scalar>vector f 1 0 int-4-rep } T{ ##shuffle-vector-imm f 2 1 { 0 0 0 0 } float-4-rep } } value-numbering-step @@ -1259,13 +2034,13 @@ cell 8 = [ [ { - T{ ##load-constant f 0 1.25 } - T{ ##load-constant f 1 B{ 0 0 160 63 0 0 160 63 0 0 160 63 0 0 160 63 } } - T{ ##copy f 2 1 any-rep } + T{ ##load-reference f 0 1.25 } + T{ ##load-reference f 1 B{ 0 0 160 63 0 0 160 63 0 0 160 63 0 0 160 63 } } + T{ ##load-reference f 2 B{ 0 0 160 63 0 0 160 63 0 0 160 63 0 0 160 63 } } } ] [ { - T{ ##load-constant f 0 1.25 } + T{ ##load-reference f 0 1.25 } T{ ##scalar>vector f 1 0 float-4-rep } T{ ##shuffle-vector-imm f 2 1 { 0 0 0 0 } float-4-rep } } value-numbering-step @@ -1401,8 +2176,7 @@ cell 8 = [ } value-numbering-step ] unit-test -! branch folding - +! Branch folding : test-branch-folding ( insns -- insns' n ) [ V{ 0 1 } clone >>successors basic-block set value-numbering-step ] keep @@ -1410,61 +2184,61 @@ cell 8 = [ [ { - T{ ##load-immediate f 1 1 } - T{ ##load-immediate f 2 2 } + T{ ##load-integer f 1 1 } + T{ ##load-integer f 2 2 } T{ ##branch } } 1 ] [ { - T{ ##load-immediate f 1 1 } - T{ ##load-immediate f 2 2 } + T{ ##load-integer f 1 1 } + T{ ##load-integer f 2 2 } T{ ##compare-branch f 1 2 cc= } } test-branch-folding ] unit-test [ { - T{ ##load-immediate f 1 1 } - T{ ##load-immediate f 2 2 } + T{ ##load-integer f 1 1 } + T{ ##load-integer f 2 2 } T{ ##branch } } 0 ] [ { - T{ ##load-immediate f 1 1 } - T{ ##load-immediate f 2 2 } + T{ ##load-integer f 1 1 } + T{ ##load-integer f 2 2 } T{ ##compare-branch f 1 2 cc/= } } test-branch-folding ] unit-test [ { - T{ ##load-immediate f 1 1 } - T{ ##load-immediate f 2 2 } + T{ ##load-integer f 1 1 } + T{ ##load-integer f 2 2 } T{ ##branch } } 0 ] [ { - T{ ##load-immediate f 1 1 } - T{ ##load-immediate f 2 2 } - T{ ##compare-branch f 1 2 cc< } + T{ ##load-integer f 1 1 } + T{ ##load-integer f 2 2 } + T{ ##compare-integer-branch f 1 2 cc< } } test-branch-folding ] unit-test [ { - T{ ##load-immediate f 1 1 } - T{ ##load-immediate f 2 2 } + T{ ##load-integer f 1 1 } + T{ ##load-integer f 2 2 } T{ ##branch } } 1 ] [ { - T{ ##load-immediate f 1 1 } - T{ ##load-immediate f 2 2 } - T{ ##compare-branch f 2 1 cc< } + T{ ##load-integer f 1 1 } + T{ ##load-integer f 2 2 } + T{ ##compare-integer-branch f 2 1 cc< } } test-branch-folding ] unit-test @@ -1477,7 +2251,7 @@ cell 8 = [ ] [ { T{ ##peek f 0 D 0 } - T{ ##compare-branch f 0 0 cc< } + T{ ##compare-integer-branch f 0 0 cc< } } test-branch-folding ] unit-test @@ -1490,7 +2264,7 @@ cell 8 = [ ] [ { T{ ##peek f 0 D 0 } - T{ ##compare-branch f 0 0 cc<= } + T{ ##compare-integer-branch f 0 0 cc<= } } test-branch-folding ] unit-test @@ -1503,7 +2277,7 @@ cell 8 = [ ] [ { T{ ##peek f 0 D 0 } - T{ ##compare-branch f 0 0 cc> } + T{ ##compare-integer-branch f 0 0 cc> } } test-branch-folding ] unit-test @@ -1516,7 +2290,7 @@ cell 8 = [ ] [ { T{ ##peek f 0 D 0 } - T{ ##compare-branch f 0 0 cc>= } + T{ ##compare-integer-branch f 0 0 cc>= } } test-branch-folding ] unit-test @@ -1529,7 +2303,7 @@ cell 8 = [ ] [ { T{ ##peek f 0 D 0 } - T{ ##compare-branch f 0 0 cc= } + T{ ##compare-integer-branch f 0 0 cc= } } test-branch-folding ] unit-test @@ -1542,14 +2316,14 @@ cell 8 = [ ] [ { T{ ##peek f 0 D 0 } - T{ ##compare-branch f 0 0 cc/= } + T{ ##compare-integer-branch f 0 0 cc/= } } test-branch-folding ] unit-test [ { T{ ##peek f 0 D 0 } - T{ ##load-constant f 1 t } + T{ ##load-reference f 1 t } T{ ##branch } } 0 @@ -1557,7 +2331,7 @@ cell 8 = [ { T{ ##peek f 0 D 0 } T{ ##compare f 1 0 0 cc<= } - T{ ##compare-imm-branch f 1 $[ \ f type-number ] cc/= } + T{ ##compare-imm-branch f 1 f cc/= } } test-branch-folding ] unit-test @@ -1566,16 +2340,16 @@ V{ T{ ##branch } } 0 test-bb V{ T{ ##peek f 0 D 0 } - T{ ##compare-branch f 0 0 cc< } + T{ ##compare-integer-branch f 0 0 cc< } } 1 test-bb V{ - T{ ##load-immediate f 1 1 } + T{ ##load-integer f 1 1 } T{ ##branch } } 2 test-bb V{ - T{ ##load-immediate f 2 2 } + T{ ##load-integer f 2 2 } T{ ##branch } } 3 test-bb @@ -1607,7 +2381,7 @@ V{ V{ T{ ##peek f 1 D 1 } - T{ ##compare-branch f 1 1 cc< } + T{ ##compare-integer-branch f 1 1 cc< } } 1 test-bb V{ @@ -1616,7 +2390,7 @@ V{ } 2 test-bb V{ - T{ ##phi f 3 V{ } } + T{ ##phi f 3 H{ { 1 1 } { 2 0 } } } T{ ##branch } } 3 test-bb @@ -1625,9 +2399,6 @@ V{ T{ ##return } } 4 test-bb -1 get 1 2array -2 get 0 2array 2array 3 get instructions>> first (>>inputs) - test-diamond [ ] [ @@ -1659,7 +2430,7 @@ V{ T{ ##copy { dst 21 } { src 20 } { rep any-rep } } T{ ##compare-imm-branch { src1 21 } - { src2 $[ \ f type-number ] } + { src2 f } { cc cc/= } } } 1 test-bb @@ -1706,3 +2477,201 @@ V{ [ f ] [ 1 get instructions>> [ ##peek? ] any? ] unit-test +! Slot addressing optimization +cpu x86? [ + [ + V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##add-imm f 2 1 2 } + T{ ##slot f 3 0 1 $[ cell log2 ] $[ 7 2 cells - ] } + } + ] [ + V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##add-imm f 2 1 2 } + T{ ##slot f 3 0 2 $[ cell log2 ] 7 } + } value-numbering-step + ] unit-test +] when + +! Alien addressing optimization + +! Base offset fusion on ##load/store-memory-imm +[ + V{ + T{ ##peek f 1 D 0 } + T{ ##tagged>integer f 2 1 } + T{ ##add-imm f 3 2 10 } + T{ ##load-memory-imm f 4 2 10 int-rep c:uchar } + } +] [ + V{ + T{ ##peek f 1 D 0 } + T{ ##tagged>integer f 2 1 } + T{ ##add-imm f 3 2 10 } + T{ ##load-memory-imm f 4 3 0 int-rep c:uchar } + } value-numbering-step +] unit-test + +[ + V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##tagged>integer f 2 0 } + T{ ##tagged>integer f 3 1 } + T{ ##add-imm f 4 3 10 } + T{ ##store-memory-imm f 2 3 10 int-rep c:uchar } + } +] [ + V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##tagged>integer f 2 0 } + T{ ##tagged>integer f 3 1 } + T{ ##add-imm f 4 3 10 } + T{ ##store-memory-imm f 2 4 0 int-rep c:uchar } + } value-numbering-step +] unit-test + +! Displacement fusion on ##load/store-memory-imm +[ + V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##tagged>integer f 2 0 } + T{ ##tagged>integer f 3 1 } + T{ ##add f 4 2 3 } + T{ ##load-memory f 5 2 3 0 0 int-rep c:uchar } + } +] [ + V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##tagged>integer f 2 0 } + T{ ##tagged>integer f 3 1 } + T{ ##add f 4 2 3 } + T{ ##load-memory-imm f 5 4 0 int-rep c:uchar } + } value-numbering-step +] unit-test + +[ + V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##tagged>integer f 2 0 } + T{ ##tagged>integer f 3 1 } + T{ ##add f 4 2 3 } + T{ ##store-memory f 5 2 3 0 0 int-rep c:uchar } + } +] [ + V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##tagged>integer f 2 0 } + T{ ##tagged>integer f 3 1 } + T{ ##add f 4 2 3 } + T{ ##store-memory-imm f 5 4 0 int-rep c:uchar } + } value-numbering-step +] unit-test + +! Base offset fusion on ##load/store-memory +[ + V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##tagged>integer f 2 0 } + T{ ##tagged>integer f 3 1 } + T{ ##add-imm f 4 2 31337 } + T{ ##load-memory f 5 2 3 0 31337 int-rep c:uchar } + } +] [ + V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##tagged>integer f 2 0 } + T{ ##tagged>integer f 3 1 } + T{ ##add-imm f 4 2 31337 } + T{ ##load-memory f 5 4 3 0 0 int-rep c:uchar } + } value-numbering-step +] unit-test + +! Displacement offset fusion on ##load/store-memory +[ + V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##tagged>integer f 2 0 } + T{ ##tagged>integer f 3 1 } + T{ ##add-imm f 4 3 31337 } + T{ ##load-memory f 5 2 3 0 31338 int-rep c:uchar } + } +] [ + V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##tagged>integer f 2 0 } + T{ ##tagged>integer f 3 1 } + T{ ##add-imm f 4 3 31337 } + T{ ##load-memory f 5 2 4 0 1 int-rep c:uchar } + } value-numbering-step +] unit-test + +! Displacement offset fusion should not occur on +! ##load/store-memory with non-zero scale +[ ] [ + V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##tagged>integer f 2 0 } + T{ ##tagged>integer f 3 1 } + T{ ##add-imm f 4 3 10 } + T{ ##load-memory f 5 2 4 1 1 int-rep c:uchar } + } dup value-numbering-step assert= +] unit-test + +! Scale fusion on ##load/store-memory +[ + V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##tagged>integer f 2 0 } + T{ ##tagged>integer f 3 1 } + T{ ##shl-imm f 4 3 2 } + T{ ##load-memory f 5 2 3 2 0 int-rep c:uchar } + } +] [ + V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##tagged>integer f 2 0 } + T{ ##tagged>integer f 3 1 } + T{ ##shl-imm f 4 3 2 } + T{ ##load-memory f 5 2 4 0 0 int-rep c:uchar } + } value-numbering-step +] unit-test + +! Don't do scale fusion if there's already a scale +[ ] [ + V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##tagged>integer f 2 0 } + T{ ##tagged>integer f 3 1 } + T{ ##shl-imm f 4 3 2 } + T{ ##load-memory f 5 2 4 1 0 int-rep c:uchar } + } dup value-numbering-step assert= +] unit-test + +! Don't do scale fusion if the scale factor is out of range +[ ] [ + V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##tagged>integer f 2 0 } + T{ ##tagged>integer f 3 1 } + T{ ##shl-imm f 4 3 4 } + T{ ##load-memory f 5 2 4 0 0 int-rep c:uchar } + } dup value-numbering-step assert= +] unit-test diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor index 96ca3efcf2..23fae4932e 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering.factor @@ -1,31 +1,47 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces assocs kernel accessors -sorting sets sequences arrays +USING: namespaces arrays assocs kernel accessors +sorting sets sequences locals cpu.architecture sequences.deep compiler.cfg compiler.cfg.rpo compiler.cfg.def-use +compiler.cfg.utilities compiler.cfg.instructions +compiler.cfg.value-numbering.alien +compiler.cfg.value-numbering.comparisons compiler.cfg.value-numbering.graph -compiler.cfg.value-numbering.expressions -compiler.cfg.value-numbering.simplify -compiler.cfg.value-numbering.rewrite ; +compiler.cfg.value-numbering.math +compiler.cfg.value-numbering.rewrite +compiler.cfg.value-numbering.slots +compiler.cfg.value-numbering.misc +compiler.cfg.value-numbering.expressions ; IN: compiler.cfg.value-numbering -! Local value numbering. - -: >copy ( insn -- insn/##copy ) - dup defs-vreg dup vreg>vn vn>vreg - 2dup eq? [ 2drop ] [ any-rep \ ##copy new-insn nip ] if ; - GENERIC: process-instruction ( insn -- insn' ) +: redundant-instruction ( insn vn -- insn' ) + [ dst>> ] dip [ swap set-vn ] [ ] 2bi ; + +:: useful-instruction ( insn expr -- insn' ) + insn dst>> :> vn + vn vn vregs>vns get set-at + vn expr exprs>vns get set-at + insn vn vns>insns get set-at + insn ; + +: check-redundancy ( insn -- insn' ) + dup >expr dup exprs>vns get at + [ redundant-instruction ] [ useful-instruction ] ?if ; + M: insn process-instruction dup rewrite [ process-instruction ] - [ dup defs-vreg [ dup number-values >copy ] when ] ?if ; + [ dup defs-vreg [ check-redundancy ] when ] ?if ; + +M: ##copy process-instruction + dup [ src>> vreg>vn ] [ dst>> ] bi set-vn ; M: array process-instruction [ process-instruction ] map ; @@ -34,7 +50,7 @@ M: array process-instruction init-value-graph [ process-instruction ] map flatten ; -: value-numbering ( cfg -- cfg' ) - [ value-numbering-step ] local-optimization +: value-numbering ( cfg -- cfg ) + dup [ value-numbering-step ] simple-optimization cfg-changed predecessors-changed ; diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor index cecf5f7251..a34bf6c07f 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier.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 combinators.short-circuit compiler.cfg.instructions compiler.cfg.rpo kernel namespaces @@ -35,10 +35,10 @@ M: ##copy eliminate-write-barrier M: insn eliminate-write-barrier drop t ; -: write-barriers-step ( bb -- ) +: write-barriers-step ( insns -- insns' ) H{ } clone fresh-allocations set H{ } clone mutated-objects set - instructions>> [ eliminate-write-barrier ] filter! drop ; + [ eliminate-write-barrier ] filter! ; -: eliminate-write-barriers ( cfg -- cfg' ) - dup [ write-barriers-step ] each-basic-block ; +: eliminate-write-barriers ( cfg -- cfg ) + dup [ write-barriers-step ] simple-optimization ; diff --git a/basis/compiler/codegen/alien/alien.factor b/basis/compiler/codegen/alien/alien.factor new file mode 100644 index 0000000000..5123b1c62c --- /dev/null +++ b/basis/compiler/codegen/alien/alien.factor @@ -0,0 +1,231 @@ +! Copyright (C) 2008, 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien alien.complex alien.c-types +alien.libraries alien.private alien.strings arrays +classes.struct combinators compiler.alien +compiler.cfg.instructions compiler.codegen +compiler.codegen.fixup compiler.errors compiler.utilities +cpu.architecture fry kernel layouts libc locals make math +math.order math.parser namespaces quotations sequences strings ; +FROM: compiler.errors => no-such-symbol ; +IN: compiler.codegen.alien + +! ##alien-invoke +GENERIC: next-fastcall-param ( rep -- ) + +: ?dummy-stack-params ( rep -- ) + dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ; + +: ?dummy-int-params ( rep -- ) + dummy-int-params? [ rep-size cell /i 1 max int-regs +@ ] [ drop ] if ; + +: ?dummy-fp-params ( rep -- ) + drop dummy-fp-params? [ float-regs inc ] when ; + +M: int-rep next-fastcall-param + int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ; + +M: float-rep next-fastcall-param + float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ; + +M: double-rep next-fastcall-param + float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ; + +GENERIC# reg-class-full? 1 ( reg-class abi -- ? ) + +M: stack-params reg-class-full? 2drop t ; + +M: reg-class reg-class-full? + [ get ] swap '[ _ param-regs length ] bi >= ; + +: alloc-stack-param ( rep -- n reg-class rep ) + stack-params get + [ rep-size cell align stack-params +@ ] dip + stack-params dup ; + +: alloc-fastcall-param ( rep -- n reg-class rep ) + [ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ; + +:: alloc-parameter ( parameter abi -- reg rep ) + parameter c-type-rep dup reg-class-of abi reg-class-full? + [ alloc-stack-param ] [ alloc-fastcall-param ] if + [ abi param-reg ] dip ; + +SYMBOL: (stack-value) +<< void* c-type clone \ (stack-value) define-primitive-type +stack-params \ (stack-value) c-type (>>rep) >> + +: ((flatten-type)) ( type to-type -- seq ) + [ stack-size cell align cell /i ] dip c-type ; inline + +: (flatten-int-type) ( type -- seq ) + void* ((flatten-type)) ; +: (flatten-stack-type) ( type -- seq ) + (stack-value) ((flatten-type)) ; + +GENERIC: flatten-value-type ( type -- types ) + +M: object flatten-value-type 1array ; +M: struct-c-type flatten-value-type (flatten-int-type) ; +M: long-long-type flatten-value-type (flatten-int-type) ; +M: c-type-name flatten-value-type c-type flatten-value-type ; + +: flatten-value-types ( params -- params ) + #! Convert value type structs to consecutive void*s. + [ + 0 [ + c-type + [ parameter-align cell /i void* c-type % ] keep + [ stack-size cell align + ] keep + flatten-value-type % + ] reduce drop + ] { } make ; + +: each-parameter ( parameters quot -- ) + [ [ parameter-offsets nip ] keep ] dip 2each ; inline + +: reset-fastcall-counts ( -- ) + { int-regs float-regs stack-params } [ 0 swap set ] each ; + +: with-param-regs ( quot -- ) + #! In quot you can call alloc-parameter + [ reset-fastcall-counts call ] with-scope ; inline + +: move-parameters ( node word -- ) + #! Moves values from C stack to registers (if word is + #! %load-param-reg) and registers to C stack (if word is + #! %save-param-reg). + [ [ alien-parameters flatten-value-types ] [ abi>> ] bi ] + [ '[ _ alloc-parameter _ execute ] ] + bi* each-parameter ; inline + +: reverse-each-parameter ( parameters quot -- ) + [ [ parameter-offsets nip ] keep ] dip 2reverse-each ; inline + +: prepare-unbox-parameters ( parameters -- offsets types indices ) + [ parameter-offsets nip ] [ ] [ length iota ] tri ; + +: unbox-parameters ( offset node -- ) + parameters>> swap + '[ prepare-unbox-parameters [ %pop-stack [ _ + ] dip unbox-parameter ] 3each ] + [ length neg %inc-d ] + bi ; + +: prepare-box-struct ( node -- offset ) + #! Return offset on C stack where to store unboxed + #! parameters. If the C function is returning a structure, + #! the first parameter is an implicit target area pointer, + #! so we need to use a different offset. + return>> large-struct? + [ %prepare-box-struct cell ] [ 0 ] if ; + +: objects>registers ( params -- ) + #! Generate code for unboxing a list of C types, then + #! generate code for moving these parameters to registers on + #! architectures where parameters are passed in registers. + [ + [ prepare-box-struct ] keep + [ unbox-parameters ] keep + \ %load-param-reg move-parameters + ] with-param-regs ; + +: box-return* ( node -- ) + return>> [ ] [ box-return %push-stack ] if-void ; + +GENERIC# dlsym-valid? 1 ( symbols dll -- ? ) + +M: string dlsym-valid? dlsym ; + +M: array dlsym-valid? '[ _ dlsym ] any? ; + +: check-dlsym ( symbols dll -- ) + dup dll-valid? [ + dupd dlsym-valid? + [ drop ] [ compiling-word get no-such-symbol ] if + ] [ + dll-path compiling-word get no-such-library drop + ] if ; + +: decorated-symbol ( params -- symbols ) + [ function>> ] [ parameters>> parameter-offsets drop number>string ] bi + { + [ drop ] + [ "@" glue ] + [ "@" glue "_" prepend ] + [ "@" glue "@" prepend ] + } 2cleave + 4array ; + +: alien-invoke-dlsym ( params -- symbols dll ) + [ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ] + [ library>> load-library ] + bi 2dup check-dlsym ; + +M: ##alien-invoke generate-insn + params>> + ! Unbox parameters + dup objects>registers + %prepare-var-args + ! Call function + dup alien-invoke-dlsym %alien-invoke + ! Box return value + dup %cleanup + box-return* ; + +M: ##alien-assembly generate-insn + params>> + ! Unbox parameters + dup objects>registers + %prepare-var-args + ! Generate assembly + dup quot>> call( -- ) + ! Box return value + box-return* ; + +! ##alien-indirect +M: ##alien-indirect generate-insn + params>> + ! Save alien at top of stack to temporary storage + %prepare-alien-indirect + ! Unbox parameters + dup objects>registers + %prepare-var-args + ! Call alien in temporary storage + %alien-indirect + ! Box return value + dup %cleanup + box-return* ; + +! ##alien-callback +: box-parameters ( params -- ) + alien-parameters [ box-parameter %push-context-stack ] each-parameter ; + +: registers>objects ( node -- ) + ! Generate code for boxing input parameters in a callback. + [ + dup \ %save-param-reg move-parameters + %begin-callback + box-parameters + ] with-param-regs ; + +: callback-return-quot ( ctype -- quot ) + return>> { + { [ dup void? ] [ drop [ ] ] } + { [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] } + [ c-type c-type-unboxer-quot ] + } cond ; + +: callback-prep-quot ( params -- quot ) + parameters>> [ c-type c-type-boxer-quot ] map spread>quot ; + +: wrap-callback-quot ( params -- quot ) + [ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append + yield-hook get + '[ _ _ do-callback ] + >quotation ; + +M: ##alien-callback generate-insn + params>> + [ registers>objects ] + [ wrap-callback-quot %alien-callback ] + [ alien-return [ %end-callback ] [ %end-callback-value ] if-void ] tri ; diff --git a/basis/compiler/codegen/alien/authors.txt b/basis/compiler/codegen/alien/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/compiler/codegen/alien/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index b16f471d11..604fb2570e 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -2,23 +2,20 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces make math math.order math.parser sequences accessors kernel layouts assocs words summary arrays combinators -classes.algebra alien alien.private alien.c-types alien.strings -alien.arrays alien.complex alien.libraries sets libc -continuations.private fry cpu.architecture classes -classes.struct locals source-files.errors slots parser -generic.parser strings quotations -compiler.errors -compiler.alien +classes.algebra sets continuations.private fry cpu.architecture +classes classes.struct locals slots parser generic.parser +strings quotations hashtables compiler.constants compiler.cfg +compiler.cfg.linearization compiler.cfg.instructions +compiler.cfg.comparisons compiler.cfg.stack-frame compiler.cfg.registers compiler.cfg.builder compiler.codegen.fixup compiler.utilities ; FROM: namespaces => set ; -FROM: compiler.errors => no-such-symbol ; IN: compiler.codegen SYMBOL: insn-counts @@ -27,45 +24,88 @@ H{ } clone insn-counts set-global GENERIC: generate-insn ( insn -- ) -! Mapping _label IDs to label instances +! Control flow SYMBOL: labels -: generate ( mr -- code ) - dup label>> [ - H{ } clone labels set +: lookup-label ( bb -- label ) + labels get [ drop