Merge branch 'master' into s3
Conflicts: basis/compiler/cfg/optimizer/optimizer.factordb4
Daniel Ehrenberg
commit
5509604ffe
|
|
@ -12,6 +12,7 @@ Factor/factor
|
|||
*.res
|
||||
*.RES
|
||||
*.image
|
||||
factor.image.fresh
|
||||
*.dylib
|
||||
factor
|
||||
factor.com
|
||||
|
|
|
|||
42
GNUmakefile
42
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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: byte-arrays arrays assocs kernel kernel.private math
|
||||
USING: byte-arrays arrays assocs delegate kernel kernel.private math
|
||||
math.order math.parser namespaces make parser sequences strings
|
||||
words splitting cpu.architecture alien alien.accessors
|
||||
alien.strings quotations layouts system compiler.units io
|
||||
|
|
@ -79,74 +79,50 @@ GENERIC: c-type-class ( name -- class )
|
|||
|
||||
M: abstract-c-type c-type-class class>> ;
|
||||
|
||||
M: c-type-name c-type-class c-type c-type-class ;
|
||||
|
||||
GENERIC: c-type-boxed-class ( name -- class )
|
||||
|
||||
M: abstract-c-type c-type-boxed-class boxed-class>> ;
|
||||
|
||||
M: c-type-name c-type-boxed-class c-type c-type-boxed-class ;
|
||||
|
||||
GENERIC: c-type-boxer ( name -- boxer )
|
||||
|
||||
M: c-type c-type-boxer boxer>> ;
|
||||
|
||||
M: c-type-name c-type-boxer c-type c-type-boxer ;
|
||||
|
||||
GENERIC: c-type-boxer-quot ( name -- quot )
|
||||
|
||||
M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
|
||||
|
||||
M: c-type-name c-type-boxer-quot c-type c-type-boxer-quot ;
|
||||
|
||||
GENERIC: c-type-unboxer ( name -- boxer )
|
||||
|
||||
M: c-type c-type-unboxer unboxer>> ;
|
||||
|
||||
M: c-type-name c-type-unboxer c-type c-type-unboxer ;
|
||||
|
||||
GENERIC: c-type-unboxer-quot ( name -- quot )
|
||||
|
||||
M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
|
||||
|
||||
M: c-type-name c-type-unboxer-quot c-type c-type-unboxer-quot ;
|
||||
|
||||
GENERIC: c-type-rep ( name -- rep )
|
||||
|
||||
M: c-type c-type-rep rep>> ;
|
||||
|
||||
M: c-type-name c-type-rep c-type c-type-rep ;
|
||||
|
||||
GENERIC: c-type-getter ( name -- quot )
|
||||
|
||||
M: c-type c-type-getter getter>> ;
|
||||
|
||||
M: c-type-name c-type-getter c-type c-type-getter ;
|
||||
|
||||
GENERIC: c-type-setter ( name -- quot )
|
||||
|
||||
M: c-type c-type-setter setter>> ;
|
||||
|
||||
M: c-type-name c-type-setter c-type c-type-setter ;
|
||||
|
||||
GENERIC: c-type-align ( name -- n )
|
||||
|
||||
M: abstract-c-type c-type-align align>> ;
|
||||
|
||||
M: c-type-name c-type-align c-type c-type-align ;
|
||||
|
||||
GENERIC: c-type-align-first ( name -- n )
|
||||
|
||||
M: c-type-name c-type-align-first c-type c-type-align-first ;
|
||||
|
||||
M: abstract-c-type c-type-align-first align-first>> ;
|
||||
|
||||
GENERIC: c-type-stack-align? ( name -- ? )
|
||||
|
||||
M: c-type c-type-stack-align? stack-align?>> ;
|
||||
|
||||
M: c-type-name c-type-stack-align? c-type c-type-stack-align? ;
|
||||
|
||||
: c-type-box ( n c-type -- )
|
||||
[ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
|
||||
%box ;
|
||||
|
|
@ -159,38 +135,26 @@ GENERIC: box-parameter ( n c-type -- )
|
|||
|
||||
M: c-type box-parameter c-type-box ;
|
||||
|
||||
M: c-type-name box-parameter c-type box-parameter ;
|
||||
|
||||
GENERIC: box-return ( c-type -- )
|
||||
|
||||
M: c-type box-return f swap c-type-box ;
|
||||
|
||||
M: c-type-name box-return c-type box-return ;
|
||||
|
||||
GENERIC: unbox-parameter ( n c-type -- )
|
||||
|
||||
M: c-type unbox-parameter c-type-unbox ;
|
||||
|
||||
M: c-type-name unbox-parameter c-type unbox-parameter ;
|
||||
|
||||
GENERIC: unbox-return ( c-type -- )
|
||||
|
||||
M: c-type unbox-return f swap c-type-unbox ;
|
||||
|
||||
M: c-type-name unbox-return c-type unbox-return ;
|
||||
|
||||
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
|
||||
|
||||
GENERIC: heap-size ( name -- size )
|
||||
|
||||
M: c-type-name heap-size c-type heap-size ;
|
||||
|
||||
M: abstract-c-type heap-size size>> ;
|
||||
|
||||
GENERIC: stack-size ( name -- size )
|
||||
|
||||
M: c-type-name stack-size c-type stack-size ;
|
||||
|
||||
M: c-type stack-size size>> cell align ;
|
||||
|
||||
: >c-bool ( ? -- int ) 1 0 ? ; inline
|
||||
|
|
@ -217,6 +181,29 @@ MIXIN: value-type
|
|||
\ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
|
||||
] [ ] make ;
|
||||
|
||||
PROTOCOL: c-type-protocol
|
||||
c-type-class
|
||||
c-type-boxed-class
|
||||
c-type-boxer
|
||||
c-type-boxer-quot
|
||||
c-type-unboxer
|
||||
c-type-unboxer-quot
|
||||
c-type-rep
|
||||
c-type-getter
|
||||
c-type-setter
|
||||
c-type-align
|
||||
c-type-align-first
|
||||
c-type-stack-align?
|
||||
box-parameter
|
||||
box-return
|
||||
unbox-parameter
|
||||
unbox-return
|
||||
heap-size
|
||||
stack-size ;
|
||||
|
||||
CONSULT: c-type-protocol c-type-name
|
||||
c-type ;
|
||||
|
||||
PREDICATE: typedef-word < c-type-word
|
||||
"c-type" word-prop c-type-name? ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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:"
|
||||
|
|
|
|||
|
|
@ -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 [ <c-direct-array> ] 2curry ;
|
||||
|
||||
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
! Copyright (C) 2010 Erik Charlebois.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types alien.enums alien.enums.private
|
||||
alien.syntax sequences tools.test words ;
|
||||
IN: alien.enums.tests
|
||||
|
||||
ENUM: color_t red { green 3 } blue ;
|
||||
ENUM: instrument_t < ushort trombone trumpet ;
|
||||
|
||||
{ { red green blue 5 } }
|
||||
[ { 0 3 4 5 } [ <color_t> ] map ] unit-test
|
||||
|
||||
{ { 0 3 4 5 } }
|
||||
[ { red green blue 5 } [ enum>number ] map ] unit-test
|
||||
|
||||
{ { -1 trombone trumpet } }
|
||||
[ { -1 0 1 } [ <instrument_t> ] map ] unit-test
|
||||
|
||||
{ { -1 0 1 } }
|
||||
[ { -1 trombone trumpet } [ enum>number ] map ] unit-test
|
||||
|
||||
{ t }
|
||||
[ color_t "c-type" word-prop enum-c-type? ] unit-test
|
||||
|
||||
{ f }
|
||||
[ ushort "c-type" word-prop enum-c-type? ] unit-test
|
||||
|
||||
{ int }
|
||||
[ color_t "c-type" word-prop base-type>> ] unit-test
|
||||
|
||||
{ ushort }
|
||||
[ instrument_t "c-type" word-prop base-type>> ] unit-test
|
||||
|
||||
{ V{ { red 0 } { green 3 } { blue 4 } } }
|
||||
[ color_t "c-type" word-prop members>> ] unit-test
|
||||
|
|
@ -0,0 +1,55 @@
|
|||
! (c)2010 Joe Groff, Erik Charlebois bsd license
|
||||
USING: accessors alien.c-types arrays combinators delegate fry
|
||||
generic.parser kernel macros math parser sequences words words.symbol ;
|
||||
IN: alien.enums
|
||||
|
||||
<PRIVATE
|
||||
TUPLE: enum-c-type base-type members ;
|
||||
C: <enum-c-type> enum-c-type
|
||||
CONSULT: c-type-protocol enum-c-type
|
||||
base-type>> ;
|
||||
PRIVATE>
|
||||
|
||||
GENERIC: enum>number ( enum -- number ) foldable
|
||||
M: integer enum>number ;
|
||||
M: symbol enum>number "enum-value" word-prop ;
|
||||
|
||||
<PRIVATE
|
||||
: enum-boxer ( members -- quot )
|
||||
[ first2 swap '[ _ ] 2array ]
|
||||
{ } map-as [ ] suffix '[ _ case ] ;
|
||||
PRIVATE>
|
||||
|
||||
MACRO: number>enum ( enum-c-type -- )
|
||||
c-type members>> enum-boxer ;
|
||||
|
||||
M: enum-c-type c-type-boxed-class drop object ;
|
||||
M: enum-c-type c-type-boxer-quot members>> enum-boxer ;
|
||||
M: enum-c-type c-type-unboxer-quot drop [ enum>number ] ;
|
||||
M: enum-c-type c-type-setter
|
||||
[ enum>number ] swap base-type>> c-type-setter '[ _ 2dip @ ] ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: define-enum-value ( class value -- )
|
||||
"enum-value" set-word-prop ;
|
||||
|
||||
: define-enum-members ( member-names -- )
|
||||
[
|
||||
[ first define-symbol ]
|
||||
[ first2 define-enum-value ] bi
|
||||
] each ;
|
||||
|
||||
: define-enum-constructor ( word -- )
|
||||
[ name>> "<" ">" surround create-in ] keep
|
||||
[ number>enum ] curry (( number -- enum )) define-inline ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: define-enum ( word base-type members -- )
|
||||
[ dup define-enum-constructor ] 2dip
|
||||
dup define-enum-members
|
||||
<enum-c-type> swap typedef ;
|
||||
|
||||
PREDICATE: enum-c-type-word < c-type-word
|
||||
"c-type" word-prop enum-c-type? ;
|
||||
|
|
@ -75,19 +75,32 @@ M: pointer return-type-name to>> return-type-name CHAR: * suffix ;
|
|||
"*" ?head
|
||||
[ [ <pointer> ] dip parse-pointers ] when ;
|
||||
|
||||
: next-enum-member ( members name value -- members value' )
|
||||
[ 2array suffix! ] [ 1 + ] bi ;
|
||||
|
||||
: parse-enum-name ( -- name )
|
||||
scan (CREATE-C-TYPE) dup save-location ;
|
||||
|
||||
: parse-enum-base-type ( -- base-type token )
|
||||
scan dup "<" =
|
||||
[ drop scan-object scan ]
|
||||
[ [ int ] dip ] if ;
|
||||
|
||||
: parse-enum-member ( members name value -- members value' )
|
||||
over "{" =
|
||||
[ 2drop scan create-in scan-object next-enum-member "}" expect ]
|
||||
[ [ create-in ] dip next-enum-member ] if ;
|
||||
|
||||
: parse-enum-members ( members counter token -- members )
|
||||
dup ";" = not
|
||||
[ swap parse-enum-member scan parse-enum-members ] [ 2drop ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: define-enum-member ( word-string value -- next-value )
|
||||
[ 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 ;
|
||||
|
|
|
|||
|
|
@ -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>> ;
|
||||
|
|
|
|||
|
|
@ -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 "<type>" } " is defined for converting from integers to singletons. The generic word " { $link enum>number } " converts from singletons to integers. Enum-typed values are automatically prettyprinted as their singleton words. Unrecognizing enum numbers are kept as numbers." }
|
||||
{ $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 <color_t> [ green = ] [ enum>number 3 = ] bi and" }
|
||||
} ;
|
||||
|
||||
HELP: C-TYPE:
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -1,14 +1,14 @@
|
|||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays combinators hints kernel locals math
|
||||
math.order sequences ;
|
||||
math.order sequences sequences.private ;
|
||||
IN: binary-search
|
||||
|
||||
<PRIVATE
|
||||
|
||||
:: (search) ( seq from to quot: ( elt -- <=> ) -- i elt )
|
||||
from to + 2/ :> midpoint@
|
||||
midpoint@ seq nth :> midpoint
|
||||
midpoint@ seq nth-unsafe :> midpoint
|
||||
|
||||
to from - 1 <= [
|
||||
midpoint@ midpoint
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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... }" }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -8,10 +8,9 @@ IN: cocoa.application
|
|||
|
||||
: <NSString> ( str -- alien ) <CFString> -> 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ] ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 <copy> 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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
{
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math vectors arrays accessors namespaces ;
|
||||
IN: compiler.cfg
|
||||
|
|
@ -8,7 +8,8 @@ TUPLE: basic-block < identity-tuple
|
|||
number
|
||||
{ instructions vector }
|
||||
{ successors vector }
|
||||
{ predecessors vector } ;
|
||||
{ predecessors vector }
|
||||
{ unlikely? boolean } ;
|
||||
|
||||
: <basic-block> ( -- bb )
|
||||
basic-block new
|
||||
|
|
@ -20,7 +21,8 @@ number
|
|||
M: basic-block hashcode* nip id>> ;
|
||||
|
||||
TUPLE: cfg { entry basic-block } word label
|
||||
spill-area-size reps
|
||||
spill-area-size
|
||||
stack-frame
|
||||
post-order linear-order
|
||||
predecessors-valid? dominance-valid? loops-valid? ;
|
||||
|
||||
|
|
@ -41,11 +43,3 @@ predecessors-valid? dominance-valid? loops-valid? ;
|
|||
|
||||
: with-cfg ( ..a cfg quot: ( ..a cfg -- ..b ) -- ..b )
|
||||
[ dup cfg ] dip with-variable ; inline
|
||||
|
||||
TUPLE: mr { instructions array } word label ;
|
||||
|
||||
: <mr> ( instructions word label -- mr )
|
||||
mr new
|
||||
swap >>label
|
||||
swap >>word
|
||||
swap >>instructions ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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' )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: changed?
|
||||
|
||||
SYMBOL: copies
|
||||
|
||||
! Initialized per-basic-block; a mapping from inputs to dst for
|
||||
! eliminating redundant ##phi instructions
|
||||
SYMBOL: phis
|
||||
|
||||
: resolve ( vreg -- vreg )
|
||||
copies get at ;
|
||||
|
||||
: record-copy ( dst src -- )
|
||||
swap copies get maybe-set-at [ changed? on ] when ; inline
|
||||
|
||||
GENERIC: visit-insn ( insn -- )
|
||||
|
||||
M: ##copy visit-insn record-copy ;
|
||||
M: ##copy visit-insn
|
||||
[ dst>> ] [ src>> resolve ] bi
|
||||
dup [ record-copy ] [ 2drop ] if ;
|
||||
|
||||
: useless-phi ( dst inputs -- ) first (record-copy) ;
|
||||
: useless-phi ( dst inputs -- ) first record-copy ;
|
||||
|
||||
: redundant-phi ( dst inputs -- ) phis get at (record-copy) ;
|
||||
: redundant-phi ( dst inputs -- ) phis get at record-copy ;
|
||||
|
||||
: record-phi ( dst inputs -- ) phis get set-at ;
|
||||
: record-phi ( dst inputs -- )
|
||||
[ phis get set-at ] [ drop dup record-copy ] 2bi ;
|
||||
|
||||
M: ##phi visit-insn
|
||||
[ dst>> ] [ inputs>> values [ resolve ] map ] bi
|
||||
{
|
||||
{ [ dup 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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 -- ) <block pprint-word n>> pprint* block> ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 <alien> size assert= ] unit-test
|
||||
|
||||
2 \ vreg-counter set-global
|
||||
|
||||
[
|
||||
V{
|
||||
T{ ##load-tagged f 3 0 }
|
||||
T{ ##replace f 3 D 0 }
|
||||
T{ ##replace f 3 R 3 }
|
||||
}
|
||||
] [ [ { D 0 R 3 } wipe-locs ] V{ } make ] unit-test
|
||||
|
||||
: gc-check? ( bb -- ? )
|
||||
instructions>>
|
||||
{
|
||||
[ length 1 = ]
|
||||
[ first ##check-nursery-branch? ]
|
||||
} 1&& ;
|
||||
|
||||
[ t ] [ V{ } 100 <gc-check> gc-check? ] unit-test
|
||||
|
||||
4 \ vreg-counter set-global
|
||||
|
||||
[
|
||||
V{
|
||||
T{ ##load-tagged f 5 0 }
|
||||
T{ ##replace f 5 D 0 }
|
||||
T{ ##replace f 5 R 3 }
|
||||
T{ ##call-gc f { 0 1 2 } }
|
||||
T{ ##branch }
|
||||
}
|
||||
]
|
||||
[
|
||||
{ D 0 R 3 } { 0 1 2 } <gc-call> instructions>>
|
||||
] unit-test
|
||||
|
||||
30 \ vreg-counter set-global
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 4 test-bb
|
||||
|
||||
0 { 1 2 } edges
|
||||
1 3 edge
|
||||
2 3 edge
|
||||
3 4 edge
|
||||
|
||||
[ ] [ test-gc-checks ] unit-test
|
||||
|
||||
[ ] [ cfg get needs-predecessors drop ] unit-test
|
||||
|
||||
[ ] [ { D 1 R 2 } { 10 20 } V{ } 31337 3 get (insert-gc-check) ] unit-test
|
||||
|
||||
[ t ] [ 1 get successors>> first gc-check? ] unit-test
|
||||
|
||||
[ t ] [ 2 get successors>> first gc-check? ] unit-test
|
||||
|
||||
[ t ] [ 3 get predecessors>> first gc-check? ] unit-test
|
||||
|
||||
30 \ vreg-counter set-global
|
||||
|
||||
V{
|
||||
T{ ##prologue }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f 2 D 0 }
|
||||
T{ ##inc-d f 3 }
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##allot f 1 64 byte-array }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##replace f 2 D 1 }
|
||||
T{ ##branch }
|
||||
} 4 test-bb
|
||||
|
||||
V{
|
||||
T{ ##epilogue }
|
||||
T{ ##return }
|
||||
} 5 test-bb
|
||||
|
||||
0 1 edge
|
||||
1 { 2 3 } edges
|
||||
2 4 edge
|
||||
3 4 edge
|
||||
4 5 edge
|
||||
|
||||
[ ] [ test-gc-checks ] unit-test
|
||||
|
||||
H{
|
||||
{ 2 tagged-rep }
|
||||
} representations set
|
||||
|
||||
[ ] [ cfg get insert-gc-checks drop ] unit-test
|
||||
|
||||
[ 2 ] [ 2 get predecessors>> length ] unit-test
|
||||
|
||||
[ t ] [ 1 get successors>> first gc-check? ] unit-test
|
||||
|
||||
[ 64 ] [ 1 get successors>> first instructions>> first size>> ] unit-test
|
||||
|
||||
[ t ] [ 2 get predecessors>> first gc-check? ] unit-test
|
||||
|
||||
[
|
||||
V{
|
||||
T{ ##load-tagged f 31 0 }
|
||||
T{ ##replace f 31 D 0 }
|
||||
T{ ##replace f 31 D 1 }
|
||||
T{ ##replace f 31 D 2 }
|
||||
T{ ##call-gc f { 2 } }
|
||||
T{ ##branch }
|
||||
}
|
||||
] [ 2 get predecessors>> second instructions>> ] unit-test
|
||||
|
||||
! Don't forget to invalidate RPO after inserting basic blocks!
|
||||
[ 8 ] [ cfg get reverse-post-order length ] unit-test
|
||||
|
||||
! Do the right thing with ##phi instructions
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##load-reference f 1 "hi" }
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##load-reference f 2 "bye" }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##phi f 3 H{ { 1 1 } { 2 2 } } }
|
||||
T{ ##allot f 1 64 byte-array }
|
||||
T{ ##branch }
|
||||
} 3 test-bb
|
||||
|
||||
0 { 1 2 } edges
|
||||
1 3 edge
|
||||
2 3 edge
|
||||
|
||||
[ ] [ test-gc-checks ] unit-test
|
||||
|
||||
H{
|
||||
{ 1 tagged-rep }
|
||||
{ 2 tagged-rep }
|
||||
{ 3 tagged-rep }
|
||||
} representations set
|
||||
|
||||
[ ] [ cfg get insert-gc-checks drop ] unit-test
|
||||
[ t ] [ 2 get successors>> first instructions>> first ##phi? ] unit-test
|
||||
[ 2 ] [ 3 get instructions>> length ] unit-test
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
<PRIVATE
|
||||
|
||||
! Garbage collection check insertion. This pass runs after
|
||||
! representation selection, since it needs to know which vregs
|
||||
! can contain tagged pointers.
|
||||
|
||||
: insert-gc-check? ( bb -- ? )
|
||||
instructions>> [ ##allocation? ] any? ;
|
||||
|
|
@ -17,6 +27,54 @@ IN: compiler.cfg.gc-checks
|
|||
: blocks-with-gc ( cfg -- bbs )
|
||||
post-order [ insert-gc-check? ] filter ;
|
||||
|
||||
! A GC check for bb consists of two new basic blocks, gc-check
|
||||
! and gc-call:
|
||||
!
|
||||
! gc-check
|
||||
! / \
|
||||
! | gc-call
|
||||
! \ /
|
||||
! bb
|
||||
|
||||
! Any ##phi instructions at the start of bb are transplanted
|
||||
! into the gc-check block.
|
||||
|
||||
: <gc-check> ( phis size -- bb )
|
||||
[ <basic-block> ] 2dip
|
||||
[
|
||||
[ % ]
|
||||
[
|
||||
cc<= int-rep next-vreg-rep int-rep next-vreg-rep
|
||||
##check-nursery-branch
|
||||
] bi*
|
||||
] V{ } make >>instructions ;
|
||||
|
||||
: wipe-locs ( uninitialized-locs -- )
|
||||
'[
|
||||
int-rep next-vreg-rep
|
||||
[ 0 ##load-tagged ]
|
||||
[ '[ [ _ ] dip ##replace ] each ] bi
|
||||
] unless-empty ;
|
||||
|
||||
: <gc-call> ( uninitialized-locs gc-roots -- bb )
|
||||
[ <basic-block> ] 2dip
|
||||
[ [ wipe-locs ] [ ##call-gc ] bi* ##branch ] V{ } make
|
||||
>>instructions t >>unlikely? ;
|
||||
|
||||
:: insert-guard ( body check bb -- )
|
||||
bb predecessors>> check (>>predecessors)
|
||||
V{ bb body } check (>>successors)
|
||||
|
||||
V{ check } body (>>predecessors)
|
||||
V{ bb } body (>>successors)
|
||||
|
||||
V{ check body } bb (>>predecessors)
|
||||
|
||||
check predecessors>> [ bb check update-successors ] each ;
|
||||
|
||||
: (insert-gc-check) ( uninitialized-locs gc-roots phis size bb -- )
|
||||
[ [ <gc-call> ] 2dip <gc-check> ] dip insert-guard ;
|
||||
|
||||
GENERIC: allocation-size* ( insn -- n )
|
||||
|
||||
M: ##allot allocation-size* size>> ;
|
||||
|
|
@ -30,20 +88,35 @@ M: ##box-displaced-alien allocation-size* drop 5 cells ;
|
|||
[ ##allocation? ] filter
|
||||
[ allocation-size* data-alignment get align ] map-sum ;
|
||||
|
||||
: gc-live-in ( bb -- vregs )
|
||||
[ live-in keys ] [ instructions>> [ ##phi? ] filter [ dst>> ] map ] bi
|
||||
append ;
|
||||
|
||||
: live-tagged ( bb -- vregs )
|
||||
gc-live-in [ rep-of tagged-rep? ] filter ;
|
||||
|
||||
: remove-phis ( bb -- phis )
|
||||
[ [ ##phi? ] partition ] change-instructions drop ;
|
||||
|
||||
: insert-gc-check ( bb -- )
|
||||
dup dup '[
|
||||
int-rep next-vreg-rep
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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> 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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences alien math classes.algebra fry
|
||||
locals combinators combinators.short-circuit cpu.architecture
|
||||
|
|
@ -16,104 +16,72 @@ IN: compiler.cfg.intrinsics.alien
|
|||
|
||||
: emit-<displaced-alien> ( node -- )
|
||||
dup emit-<displaced-alien>? [
|
||||
[ 2inputs [ ^^untag-fixnum ] dip ] dip
|
||||
node-input-infos second class>>
|
||||
^^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) ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
[ ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ;
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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:<tuple-boa> [ emit-<tuple-boa> ] }
|
||||
{ arrays:<array> [ emit-<array> ] }
|
||||
|
|
@ -61,32 +64,32 @@ IN: compiler.cfg.intrinsics
|
|||
{ byte-arrays:(byte-array) [ emit-(byte-array) ] }
|
||||
{ kernel:<wrapper> [ emit-simple-allot ] }
|
||||
{ alien:<displaced-alien> [ emit-<displaced-alien> ] }
|
||||
{ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
|
||||
{ alien.accessors: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 -- )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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? ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ( -- )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
<spill-slot> ;
|
||||
|
||||
|
|
@ -127,8 +128,11 @@ SYMBOL: unhandled-sync-points
|
|||
! Mapping from vregs to spill slots
|
||||
SYMBOL: spill-slots
|
||||
|
||||
: vreg-spill-slot ( vreg -- spill-slot )
|
||||
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{ } <linked-assoc> map>assoc ;
|
||||
|
||||
: add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ;
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
<min-heap> pending-interval-heap set
|
||||
H{ } clone pending-interval-assoc set
|
||||
<min-heap> unhandled-intervals set
|
||||
H{ } clone register-live-ins set
|
||||
H{ } clone 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 ;
|
||||
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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> live-range
|
||||
|
||||
SYMBOLS: +def+ +use+ +memory+ ;
|
||||
|
||||
TUPLE: vreg-use rep n type ;
|
||||
|
||||
C: <vreg-use> vreg-use
|
||||
|
||||
TUPLE: live-interval
|
||||
vreg
|
||||
reg spill-to reload-from
|
||||
start end ranges uses ;
|
||||
start end ranges uses
|
||||
reg-class ;
|
||||
|
||||
: first-use ( live-interval -- use ) uses>> first ; inline
|
||||
|
||||
: last-use ( live-interval -- use ) uses>> last ; inline
|
||||
|
||||
GENERIC: covers? ( insn# obj -- ? )
|
||||
|
||||
|
|
@ -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 -- )
|
||||
[ <live-range> ] 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 <vreg-use>
|
||||
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 ;
|
||||
|
||||
: <live-interval> ( vreg -- live-interval )
|
||||
: <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 [ <live-interval> ] cache ;
|
||||
leader live-intervals get
|
||||
[ dup rep-of reg-class-of <live-interval> ] cache ;
|
||||
|
||||
GENERIC: compute-live-intervals* ( insn -- )
|
||||
|
||||
M: insn compute-live-intervals* drop ;
|
||||
|
||||
: handle-output ( insn vreg -- )
|
||||
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-point> sync-points get push ;
|
||||
|
||||
M: insn compute-sync-points* drop ;
|
||||
|
||||
: compute-live-intervals-step ( bb -- )
|
||||
[ basic-block set ]
|
||||
[ handle-live-out ]
|
||||
[
|
||||
instructions>> <reversed> [
|
||||
[ compute-live-intervals* ]
|
||||
[ compute-sync-points* ]
|
||||
bi
|
||||
] each
|
||||
] tri ;
|
||||
{
|
||||
[ block-from from set ]
|
||||
[ block-to to set ]
|
||||
[ handle-live-out ]
|
||||
[
|
||||
instructions>> <reversed> [
|
||||
[ compute-live-intervals* ]
|
||||
[ compute-sync-points* ]
|
||||
bi
|
||||
] each
|
||||
]
|
||||
} cleave ;
|
||||
|
||||
: init-live-intervals ( -- )
|
||||
H{ } clone live-intervals set
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! Copyright (C) 2009, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs combinators
|
||||
combinators.short-circuit fry kernel locals namespaces
|
||||
make math sequences hashtables
|
||||
cpu.architecture
|
||||
compiler.cfg
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.liveness
|
||||
|
|
@ -11,42 +12,67 @@ compiler.cfg.utilities
|
|||
compiler.cfg.instructions
|
||||
compiler.cfg.predecessors
|
||||
compiler.cfg.parallel-copy
|
||||
compiler.cfg.ssa.destruction
|
||||
compiler.cfg.linear-scan.assignment
|
||||
compiler.cfg.linear-scan.allocation.state ;
|
||||
IN: compiler.cfg.linear-scan.resolve
|
||||
|
||||
TUPLE: location
|
||||
{ reg read-only }
|
||||
{ rep read-only }
|
||||
{ reg-class read-only } ;
|
||||
|
||||
: <location> ( reg rep -- location )
|
||||
dup reg-class-of location boa ;
|
||||
|
||||
M: location equal?
|
||||
over location? [
|
||||
{ [ [ reg>> ] bi@ = ] [ [ reg-class>> ] bi@ = ] } 2&&
|
||||
] [ 2drop f ] if ;
|
||||
|
||||
M: location hashcode*
|
||||
reg>> hashcode* ;
|
||||
|
||||
SYMBOL: spill-temps
|
||||
|
||||
: spill-temp ( rep -- n )
|
||||
spill-temps get [ next-spill-slot ] cache ;
|
||||
rep-size spill-temps get [ next-spill-slot ] cache ;
|
||||
|
||||
: add-mapping ( from to rep -- )
|
||||
'[ _ 2array ] bi@ 2array , ;
|
||||
'[ _ <location> ] bi@ 2array , ;
|
||||
|
||||
:: resolve-value-data-flow ( bb to vreg -- )
|
||||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOLS: work-list loop-heads visited ;
|
||||
|
||||
: visited? ( bb -- ? ) visited get in? ;
|
||||
|
||||
: add-to-work-list ( bb -- )
|
||||
dup visited? [ drop ] [
|
||||
work-list get push-back
|
||||
] if ;
|
||||
|
||||
: init-linearization-order ( cfg -- )
|
||||
<dlist> work-list set
|
||||
HS{ } clone visited set
|
||||
entry>> add-to-work-list ;
|
||||
|
||||
: (find-alternate-loop-head) ( bb -- bb' )
|
||||
dup {
|
||||
[ predecessor visited? not ]
|
||||
[ predecessors>> length 1 = ]
|
||||
[ predecessor successors>> length 1 = ]
|
||||
[ [ number>> ] [ predecessor number>> ] bi > ]
|
||||
} 1&& [ predecessor (find-alternate-loop-head) ] when ;
|
||||
|
||||
: find-back-edge ( bb -- pred )
|
||||
[ predecessors>> ] keep '[ _ back-edge? ] find nip ;
|
||||
|
||||
: find-alternate-loop-head ( bb -- bb' )
|
||||
dup find-back-edge dup visited? [ drop ] [
|
||||
nip (find-alternate-loop-head)
|
||||
] if ;
|
||||
|
||||
: predecessors-ready? ( bb -- ? )
|
||||
[ predecessors>> ] keep '[
|
||||
_ 2dup back-edge?
|
||||
[ 2drop t ] [ drop visited? ] if
|
||||
] all? ;
|
||||
|
||||
: process-successor ( bb -- )
|
||||
dup predecessors-ready? [
|
||||
dup loop-entry? [ find-alternate-loop-head ] when
|
||||
add-to-work-list
|
||||
] [ drop ] if ;
|
||||
|
||||
: sorted-successors ( bb -- seq )
|
||||
successors>> <reversed> [ loop-nesting-at ] sort-with ;
|
||||
|
||||
: process-block ( bb -- )
|
||||
dup visited? [ drop ] [
|
||||
[ , ]
|
||||
[ visited get adjoin ]
|
||||
[ sorted-successors [ process-successor ] each ]
|
||||
tri
|
||||
] if ;
|
||||
|
||||
: (linearization-order) ( cfg -- bbs )
|
||||
init-linearization-order
|
||||
|
||||
[ work-list get [ process-block ] slurp-deque ] { } make
|
||||
! [ unlikely?>> not ] partition append
|
||||
;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: linearization-order ( cfg -- bbs )
|
||||
needs-post-order needs-loops needs-predecessors
|
||||
|
||||
dup linear-order>> [ ] [
|
||||
dup (linearization-order)
|
||||
>>linear-order linear-order>>
|
||||
] ?if ;
|
||||
|
||||
SYMBOL: numbers
|
||||
|
||||
: block-number ( bb -- n ) numbers get at ;
|
||||
|
||||
: number-blocks ( bbs -- ) [ 2array ] map-index >hashtable numbers set ;
|
||||
|
||||
! Convert CFG IR to machine IR.
|
||||
GENERIC: linearize-insn ( basic-block insn -- )
|
||||
|
||||
: linearize-basic-block ( bb -- )
|
||||
[ block-number _label ]
|
||||
[ dup instructions>> [ linearize-insn ] with each ]
|
||||
bi ;
|
||||
|
||||
M: insn linearize-insn , drop ;
|
||||
|
||||
: useless-branch? ( basic-block successor -- ? )
|
||||
! If our successor immediately follows us in linearization
|
||||
! order then we don't need to branch.
|
||||
[ block-number ] bi@ 1 - = ; inline
|
||||
|
||||
: emit-branch ( bb successor -- )
|
||||
2dup useless-branch? [ 2drop ] [ nip block-number _branch ] if ;
|
||||
|
||||
M: ##branch linearize-insn
|
||||
drop dup successors>> first emit-branch ;
|
||||
|
||||
: successors ( bb -- first second ) successors>> first2 ; inline
|
||||
|
||||
:: conditional ( bb insn n conditional-quot negate-cc-quot -- bb successor label etc... )
|
||||
bb insn
|
||||
conditional-quot
|
||||
[ drop dup successors>> second useless-branch? ] 2bi
|
||||
[ [ swap block-number ] n ndip ]
|
||||
[ [ block-number ] n ndip negate-cc-quot call ] if ; inline
|
||||
|
||||
: (binary-conditional) ( bb insn -- bb successor1 successor2 src1 src2 cc )
|
||||
[ dup successors ]
|
||||
[ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
|
||||
|
||||
: binary-conditional ( bb insn -- bb successor label2 src1 src2 cc )
|
||||
3 [ (binary-conditional) ] [ negate-cc ] conditional ;
|
||||
|
||||
: (test-vector-conditional) ( bb insn -- bb successor1 successor2 src1 temp rep vcc )
|
||||
[ dup successors ]
|
||||
[ { [ src1>> ] [ temp>> ] [ rep>> ] [ vcc>> ] } cleave ] bi* ; inline
|
||||
|
||||
: test-vector-conditional ( bb insn -- bb successor label src1 temp rep vcc )
|
||||
4 [ (test-vector-conditional) ] [ negate-vcc ] conditional ;
|
||||
|
||||
M: ##compare-branch linearize-insn
|
||||
binary-conditional _compare-branch emit-branch ;
|
||||
|
||||
M: ##compare-imm-branch linearize-insn
|
||||
binary-conditional _compare-imm-branch emit-branch ;
|
||||
|
||||
M: ##compare-float-ordered-branch linearize-insn
|
||||
binary-conditional _compare-float-ordered-branch emit-branch ;
|
||||
|
||||
M: ##compare-float-unordered-branch linearize-insn
|
||||
binary-conditional _compare-float-unordered-branch emit-branch ;
|
||||
|
||||
M: ##test-vector-branch linearize-insn
|
||||
test-vector-conditional _test-vector-branch emit-branch ;
|
||||
|
||||
: overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 )
|
||||
[ dup successors block-number ]
|
||||
[ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline
|
||||
|
||||
M: ##fixnum-add linearize-insn
|
||||
overflow-conditional _fixnum-add emit-branch ;
|
||||
|
||||
M: ##fixnum-sub linearize-insn
|
||||
overflow-conditional _fixnum-sub emit-branch ;
|
||||
|
||||
M: ##fixnum-mul linearize-insn
|
||||
overflow-conditional _fixnum-mul emit-branch ;
|
||||
|
||||
M: ##dispatch linearize-insn
|
||||
swap
|
||||
[ [ src>> ] [ temp>> ] bi _dispatch ]
|
||||
[ successors>> [ block-number _dispatch-label ] each ]
|
||||
bi* ;
|
||||
|
||||
: linearize-basic-blocks ( cfg -- insns )
|
||||
[
|
||||
[
|
||||
linearization-order
|
||||
[ number-blocks ]
|
||||
[ [ linearize-basic-block ] each ] bi
|
||||
] [ spill-area-size>> _spill-area-size ] bi
|
||||
] { } make ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: flatten-cfg ( cfg -- mr )
|
||||
[ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
|
||||
<mr> ;
|
||||
: number-blocks ( bbs -- )
|
||||
[ 2array ] map-index >hashtable numbers set ;
|
||||
|
|
|
|||
|
|
@ -1,81 +0,0 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs deques dlists kernel make sorting
|
||||
namespaces sequences combinators combinators.short-circuit
|
||||
fry math compiler.cfg.rpo compiler.cfg.utilities
|
||||
compiler.cfg.loop-detection compiler.cfg.predecessors
|
||||
sets hash-sets ;
|
||||
FROM: namespaces => set ;
|
||||
IN: compiler.cfg.linearization.order
|
||||
|
||||
! This is RPO except loops are rotated. Based on SBCL's src/compiler/control.lisp
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOLS: work-list loop-heads visited ;
|
||||
|
||||
: visited? ( bb -- ? ) visited get in? ;
|
||||
|
||||
: add-to-work-list ( bb -- )
|
||||
dup visited? [ drop ] [
|
||||
work-list get push-back
|
||||
] if ;
|
||||
|
||||
: init-linearization-order ( cfg -- )
|
||||
<dlist> work-list set
|
||||
HS{ } clone visited set
|
||||
entry>> add-to-work-list ;
|
||||
|
||||
: (find-alternate-loop-head) ( bb -- bb' )
|
||||
dup {
|
||||
[ predecessor visited? not ]
|
||||
[ predecessors>> length 1 = ]
|
||||
[ predecessor successors>> length 1 = ]
|
||||
[ [ number>> ] [ predecessor number>> ] bi > ]
|
||||
} 1&& [ predecessor (find-alternate-loop-head) ] when ;
|
||||
|
||||
: find-back-edge ( bb -- pred )
|
||||
[ predecessors>> ] keep '[ _ back-edge? ] find nip ;
|
||||
|
||||
: find-alternate-loop-head ( bb -- bb' )
|
||||
dup find-back-edge dup visited? [ drop ] [
|
||||
nip (find-alternate-loop-head)
|
||||
] if ;
|
||||
|
||||
: predecessors-ready? ( bb -- ? )
|
||||
[ predecessors>> ] keep '[
|
||||
_ 2dup back-edge?
|
||||
[ 2drop t ] [ drop visited? ] if
|
||||
] all? ;
|
||||
|
||||
: process-successor ( bb -- )
|
||||
dup predecessors-ready? [
|
||||
dup loop-entry? [ find-alternate-loop-head ] when
|
||||
add-to-work-list
|
||||
] [ drop ] if ;
|
||||
|
||||
: sorted-successors ( bb -- seq )
|
||||
successors>> <reversed> [ loop-nesting-at ] sort-with ;
|
||||
|
||||
: process-block ( bb -- )
|
||||
dup visited? [ drop ] [
|
||||
[ , ]
|
||||
[ visited get adjoin ]
|
||||
[ sorted-successors [ process-successor ] each ]
|
||||
tri
|
||||
] if ;
|
||||
|
||||
: (linearization-order) ( cfg -- bbs )
|
||||
init-linearization-order
|
||||
|
||||
[ work-list get [ process-block ] slurp-deque ] { } make ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: linearization-order ( cfg -- bbs )
|
||||
needs-post-order needs-loops needs-predecessors
|
||||
|
||||
dup linear-order>> [ ] [
|
||||
dup (linearization-order)
|
||||
>>linear-order linear-order>>
|
||||
] ?if ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
Flattening CFG into MR (machine representation)
|
||||
|
|
@ -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
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! Copyright (C) 2009, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces deques accessors sets sequences assocs fry
|
||||
hashtables dlists compiler.cfg.def-use compiler.cfg.instructions
|
||||
|
|
@ -11,9 +11,9 @@ IN: compiler.cfg.liveness.ssa
|
|||
|
||||
! Assoc mapping basic blocks to sequences of sets of vregs; each sequence
|
||||
! is in correspondence with a predecessor
|
||||
SYMBOL: phi-live-ins
|
||||
SYMBOL: edge-live-ins
|
||||
|
||||
: phi-live-in ( predecessor basic-block -- set ) phi-live-ins get at at ;
|
||||
: edge-live-in ( predecessor basic-block -- set ) edge-live-ins get at at ;
|
||||
|
||||
SYMBOL: work-list
|
||||
|
||||
|
|
@ -23,19 +23,19 @@ SYMBOL: work-list
|
|||
: compute-live-in ( basic-block -- live-in )
|
||||
[ live-out ] keep instructions>> transfer-liveness ;
|
||||
|
||||
: compute-phi-live-in ( basic-block -- phi-live-in )
|
||||
: compute-edge-live-in ( basic-block -- edge-live-in )
|
||||
H{ } clone [
|
||||
'[ inputs>> [ swap _ conjoin-at ] assoc-each ] each-phi
|
||||
] keep ;
|
||||
|
||||
: update-live-in ( basic-block -- changed? )
|
||||
[ [ compute-live-in ] keep live-ins get maybe-set-at ]
|
||||
[ [ compute-phi-live-in ] keep phi-live-ins get maybe-set-at ]
|
||||
[ [ compute-edge-live-in ] keep edge-live-ins get maybe-set-at ]
|
||||
bi or ;
|
||||
|
||||
: compute-live-out ( basic-block -- live-out )
|
||||
[ successors>> [ live-in ] map ]
|
||||
[ dup successors>> [ phi-live-in ] with map ] bi
|
||||
[ dup successors>> [ edge-live-in ] with map ] bi
|
||||
append assoc-combine ;
|
||||
|
||||
: update-live-out ( basic-block -- changed? )
|
||||
|
|
@ -48,14 +48,14 @@ SYMBOL: work-list
|
|||
[ predecessors>> add-to-work-list ] [ drop ] if
|
||||
] [ drop ] if ;
|
||||
|
||||
: compute-ssa-live-sets ( cfg -- cfg' )
|
||||
: compute-ssa-live-sets ( cfg -- )
|
||||
needs-predecessors
|
||||
|
||||
<hashed-dlist> work-list set
|
||||
H{ } clone live-ins set
|
||||
H{ } clone phi-live-ins set
|
||||
H{ } clone edge-live-ins set
|
||||
H{ } clone live-outs set
|
||||
dup post-order add-to-work-list
|
||||
post-order add-to-work-list
|
||||
work-list get [ liveness-step ] slurp-deque ;
|
||||
|
||||
: live-in? ( vreg bb -- ? ) live-in key? ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
Slava Pestov
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
! Copyright (C) 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs compiler.cfg.def-use
|
||||
compiler.cfg.instructions compiler.cfg.rpo disjoint-sets fry
|
||||
kernel namespaces sequences ;
|
||||
IN: compiler.cfg.representations.coalescing
|
||||
|
||||
! Find all strongly connected components in the graph where the
|
||||
! edges are ##phi or ##copy vreg uses
|
||||
SYMBOL: components
|
||||
|
||||
: init-components ( cfg components -- )
|
||||
'[
|
||||
instructions>> [
|
||||
defs-vreg [ _ add-atom ] when*
|
||||
] each
|
||||
] each-basic-block ;
|
||||
|
||||
GENERIC# visit-insn 1 ( insn disjoint-set -- )
|
||||
|
||||
M: ##copy visit-insn
|
||||
[ [ dst>> ] [ src>> ] bi ] dip equate ;
|
||||
|
||||
M: ##phi visit-insn
|
||||
[ [ inputs>> values ] [ dst>> ] bi ] dip equate-all-with ;
|
||||
|
||||
M: insn visit-insn 2drop ;
|
||||
|
||||
: merge-components ( cfg components -- )
|
||||
'[
|
||||
instructions>> [
|
||||
_ visit-insn
|
||||
] each
|
||||
] each-basic-block ;
|
||||
|
||||
: compute-components ( cfg -- )
|
||||
<disjoint-set>
|
||||
[ init-components ]
|
||||
[ merge-components ]
|
||||
[ components set drop ] 2tri ;
|
||||
|
||||
: vreg>scc ( vreg -- scc )
|
||||
components get representative ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! For every vreg, compute possible representations.
|
||||
SYMBOL: possibilities
|
||||
|
||||
: possible ( vreg -- reps ) possibilities get at ;
|
||||
|
||||
: compute-possibilities ( cfg -- )
|
||||
H{ } clone [ '[ swap _ conjoin-at ] with-vreg-reps ] keep
|
||||
[ keys ] assoc-map possibilities set ;
|
||||
|
||||
! Compute vregs which must remain tagged for their lifetime.
|
||||
SYMBOL: always-boxed
|
||||
|
||||
:: (compute-always-boxed) ( vreg rep assoc -- )
|
||||
rep int-rep eq? [
|
||||
int-rep vreg assoc set-at
|
||||
] when ;
|
||||
|
||||
: compute-always-boxed ( cfg -- assoc )
|
||||
H{ } clone [
|
||||
'[
|
||||
[
|
||||
dup [ ##load-reference? ] [ ##load-constant? ] bi or
|
||||
[ drop ] [ [ _ (compute-always-boxed) ] each-def-rep ] if
|
||||
] each-non-phi
|
||||
] each-basic-block
|
||||
] keep ;
|
||||
|
||||
! For every vreg, compute the cost of keeping it in every possible
|
||||
! representation.
|
||||
|
||||
! Cost map maps vreg to representation to cost.
|
||||
SYMBOL: costs
|
||||
|
||||
: init-costs ( -- )
|
||||
possibilities get [ [ 0 ] H{ } map>assoc ] assoc-map costs set ;
|
||||
|
||||
: increase-cost ( rep vreg -- )
|
||||
! Increase cost of keeping vreg in rep, making a choice of rep less
|
||||
! likely.
|
||||
[ basic-block get loop-nesting-at ] 2dip costs get at at+ ;
|
||||
|
||||
: maybe-increase-cost ( possible vreg preferred -- )
|
||||
pick eq? [ 2drop ] [ increase-cost ] if ;
|
||||
|
||||
: representation-cost ( vreg preferred -- )
|
||||
! 'preferred' is a representation that the instruction can accept with no cost.
|
||||
! So, for each representation that's not preferred, increase the cost of keeping
|
||||
! the vreg in that representation.
|
||||
[ drop possible ]
|
||||
[ '[ _ _ maybe-increase-cost ] ]
|
||||
2bi each ;
|
||||
|
||||
: compute-costs ( cfg -- costs )
|
||||
init-costs [ representation-cost ] with-vreg-reps costs get ;
|
||||
|
||||
! For every vreg, compute preferred representation, that minimizes costs.
|
||||
: minimize-costs ( costs -- representations )
|
||||
[ >alist alist-min first ] assoc-map ;
|
||||
|
||||
: compute-representations ( cfg -- )
|
||||
[ compute-costs minimize-costs ]
|
||||
[ compute-always-boxed ]
|
||||
bi assoc-union
|
||||
representations set ;
|
||||
|
||||
! Insert conversions. This introduces new temporaries, so we need
|
||||
! to rename opearands too.
|
||||
|
||||
! Mapping from vreg,rep pairs to vregs
|
||||
SYMBOL: alternatives
|
||||
|
||||
:: emit-def-conversion ( dst preferred required -- new-dst' )
|
||||
! If an instruction defines a register with representation 'required',
|
||||
! but the register has preferred representation 'preferred', then
|
||||
! we rename the instruction's definition to a new register, which
|
||||
! becomes the input of a conversion instruction.
|
||||
dst required next-vreg-rep [ preferred required emit-conversion ] keep ;
|
||||
|
||||
:: emit-use-conversion ( src preferred required -- new-src' )
|
||||
! If an instruction uses a register with representation 'required',
|
||||
! but the register has preferred representation 'preferred', then
|
||||
! we rename the instruction's input to a new register, which
|
||||
! becomes the output of a conversion instruction.
|
||||
preferred required eq? [ src ] [
|
||||
src required alternatives get [
|
||||
required next-vreg-rep :> new-src
|
||||
[ new-src ] 2dip preferred emit-conversion
|
||||
new-src
|
||||
] 2cache
|
||||
] if ;
|
||||
|
||||
SYMBOLS: renaming-set needs-renaming? ;
|
||||
|
||||
: init-renaming-set ( -- )
|
||||
needs-renaming? off
|
||||
V{ } clone renaming-set set ;
|
||||
|
||||
: no-renaming ( vreg -- )
|
||||
dup 2array renaming-set get push ;
|
||||
|
||||
: record-renaming ( from to -- )
|
||||
2array renaming-set get push needs-renaming? on ;
|
||||
|
||||
:: (compute-renaming-set) ( ..a vreg required quot: ( ..a vreg preferred required -- ..b ) -- ..b )
|
||||
vreg rep-of :> preferred
|
||||
preferred required eq?
|
||||
[ vreg no-renaming ]
|
||||
[ vreg vreg preferred required quot call record-renaming ] if ; inline
|
||||
|
||||
: compute-renaming-set ( insn -- )
|
||||
! temp vregs don't need conversions since they're always in their
|
||||
! preferred representation
|
||||
init-renaming-set
|
||||
[ [ [ emit-use-conversion ] (compute-renaming-set) ] each-use-rep ]
|
||||
[ , ]
|
||||
[ [ [ emit-def-conversion ] (compute-renaming-set) ] each-def-rep ]
|
||||
tri ;
|
||||
|
||||
: converted-value ( vreg -- vreg' )
|
||||
renaming-set get pop first2 [ assert= ] dip ;
|
||||
|
||||
RENAMING: convert [ converted-value ] [ converted-value ] [ ]
|
||||
|
||||
: perform-renaming ( insn -- )
|
||||
needs-renaming? get [
|
||||
renaming-set get reverse! drop
|
||||
[ convert-insn-uses ] [ convert-insn-defs ] bi
|
||||
renaming-set get length 0 assert=
|
||||
] [ drop ] if ;
|
||||
|
||||
GENERIC: conversions-for-insn ( insn -- )
|
||||
|
||||
SYMBOL: phi-mappings
|
||||
|
||||
! compiler.cfg.cssa inserts conversions which convert phi inputs into
|
||||
! the representation of the output. However, we still have to do some
|
||||
! processing here, because if the only node that uses the output of
|
||||
! the phi instruction is another phi instruction then this phi node's
|
||||
! output won't have a representation assigned.
|
||||
M: ##phi conversions-for-insn
|
||||
[ , ] [ [ inputs>> values ] [ dst>> ] bi phi-mappings get set-at ] bi ;
|
||||
|
||||
! When a literal zeroes/ones vector is unboxed, we replace the ##load-reference
|
||||
! with a ##zero-vector or ##fill-vector instruction since this is more efficient.
|
||||
: convert-to-zero-vector? ( insn -- ? )
|
||||
{
|
||||
[ dst>> rep-of vector-rep? ]
|
||||
[ obj>> B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } = ]
|
||||
} 1&& ;
|
||||
: convert-to-fill-vector? ( insn -- ? )
|
||||
{
|
||||
[ dst>> rep-of vector-rep? ]
|
||||
[ obj>> B{ 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 } = ]
|
||||
} 1&& ;
|
||||
|
||||
: (convert-to-zero/fill-vector) ( insn -- dst rep )
|
||||
dst>> dup rep-of ; inline
|
||||
|
||||
: conversions-for-load-insn ( insn -- ?insn )
|
||||
{
|
||||
{
|
||||
[ dup convert-to-zero-vector? ]
|
||||
[ (convert-to-zero/fill-vector) ##zero-vector f ]
|
||||
}
|
||||
{
|
||||
[ dup convert-to-fill-vector? ]
|
||||
[ (convert-to-zero/fill-vector) ##fill-vector f ]
|
||||
}
|
||||
[ ]
|
||||
} cond ;
|
||||
|
||||
M: ##load-reference conversions-for-insn
|
||||
conversions-for-load-insn [ call-next-method ] when* ;
|
||||
|
||||
M: ##load-constant conversions-for-insn
|
||||
conversions-for-load-insn [ call-next-method ] when* ;
|
||||
|
||||
M: vreg-insn conversions-for-insn
|
||||
[ compute-renaming-set ] [ perform-renaming ] bi ;
|
||||
|
||||
M: insn conversions-for-insn , ;
|
||||
|
||||
: conversions-for-block ( bb -- )
|
||||
dup kill-block? [ drop ] [
|
||||
[
|
||||
[
|
||||
H{ } clone alternatives set
|
||||
[ conversions-for-insn ] each
|
||||
] V{ } make
|
||||
] change-instructions drop
|
||||
] if ;
|
||||
|
||||
! If the output of a phi instruction is only used as the input to another
|
||||
! phi instruction, then we want to use the same representation for both
|
||||
! if possible.
|
||||
SYMBOL: work-list
|
||||
|
||||
: add-to-work-list ( vregs -- )
|
||||
work-list get push-all-front ;
|
||||
|
||||
: rep-assigned ( vregs -- vregs' )
|
||||
representations get '[ _ key? ] filter ;
|
||||
|
||||
: rep-not-assigned ( vregs -- vregs' )
|
||||
representations get '[ _ key? not ] filter ;
|
||||
|
||||
: add-ready-phis ( -- )
|
||||
phi-mappings get keys rep-assigned add-to-work-list ;
|
||||
|
||||
: process-phi-mapping ( dst -- )
|
||||
! If dst = phi(src1,src2,...) and dst's representation has been
|
||||
! determined, assign that representation to each one of src1,...
|
||||
! that does not have a representation yet, and process those, too.
|
||||
dup phi-mappings get at* [
|
||||
[ rep-of ] [ rep-not-assigned ] bi*
|
||||
[ [ set-rep-of ] with each ] [ add-to-work-list ] bi
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: remaining-phi-mappings ( -- )
|
||||
phi-mappings get keys rep-not-assigned
|
||||
[ [ int-rep ] dip set-rep-of ] each ;
|
||||
|
||||
: process-phi-mappings ( -- )
|
||||
<hashed-dlist> work-list set
|
||||
add-ready-phis
|
||||
work-list get [ process-phi-mapping ] slurp-deque
|
||||
remaining-phi-mappings ;
|
||||
|
||||
: insert-conversions ( cfg -- )
|
||||
H{ } clone phi-mappings set
|
||||
[ conversions-for-block ] each-basic-block
|
||||
process-phi-mappings ;
|
||||
|
||||
PRIVATE>
|
||||
! 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 ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,150 @@
|
|||
! Copyright (C) 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs byte-arrays combinators
|
||||
disjoint-sets fry kernel locals math namespaces sequences sets
|
||||
compiler.cfg
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.loop-detection
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.representations.preferred
|
||||
compiler.cfg.representations.coalescing
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.utilities
|
||||
compiler.utilities
|
||||
cpu.architecture ;
|
||||
FROM: namespaces => set ;
|
||||
IN: compiler.cfg.representations.selection
|
||||
|
||||
! vregs which must be tagged at the definition site because
|
||||
! there is at least one usage that is not int-rep. If all usages
|
||||
! are int-rep it is safe to untag at the definition site.
|
||||
SYMBOL: tagged-vregs
|
||||
|
||||
SYMBOL: vreg-reps
|
||||
|
||||
: handle-def ( vreg rep -- )
|
||||
swap vreg>scc vreg-reps get
|
||||
[ [ intersect ] when* ] change-at ;
|
||||
|
||||
: handle-use ( vreg rep -- )
|
||||
int-rep eq? [ drop ] [ vreg>scc tagged-vregs get adjoin ] if ;
|
||||
|
||||
GENERIC: (collect-vreg-reps) ( insn -- )
|
||||
|
||||
M: ##load-reference (collect-vreg-reps)
|
||||
[ dst>> ] [ obj>> ] bi {
|
||||
{ [ dup float? ] [ drop { float-rep double-rep } ] }
|
||||
{ [ dup byte-array? ] [ drop vector-reps ] }
|
||||
[ drop { } ]
|
||||
} cond handle-def ;
|
||||
|
||||
M: vreg-insn (collect-vreg-reps)
|
||||
[ [ handle-use ] each-use-rep ]
|
||||
[ [ 1array handle-def ] each-def-rep ]
|
||||
[ [ 1array handle-def ] each-temp-rep ]
|
||||
tri ;
|
||||
|
||||
M: insn (collect-vreg-reps) drop ;
|
||||
|
||||
: collect-vreg-reps ( cfg -- )
|
||||
H{ } clone vreg-reps set
|
||||
HS{ } clone tagged-vregs set
|
||||
[ [ (collect-vreg-reps) ] each-non-phi ] each-basic-block ;
|
||||
|
||||
SYMBOL: possibilities
|
||||
|
||||
: possible-reps ( vreg reps -- vreg reps )
|
||||
{ tagged-rep } union
|
||||
2dup [ tagged-vregs get in? not ] [ { tagged-rep } = ] bi* and
|
||||
[ drop { tagged-rep int-rep } ] [ ] if ;
|
||||
|
||||
: compute-possibilities ( cfg -- )
|
||||
collect-vreg-reps
|
||||
vreg-reps get [ possible-reps ] assoc-map possibilities set ;
|
||||
|
||||
! For every vreg, compute the cost of keeping it in every possible
|
||||
! representation.
|
||||
|
||||
! Cost map maps vreg to representation to cost.
|
||||
SYMBOL: costs
|
||||
|
||||
: init-costs ( -- )
|
||||
! Initialize cost as 0 for each possibility.
|
||||
possibilities get [ [ 0 ] H{ } map>assoc ] assoc-map costs set ;
|
||||
|
||||
: 10^ ( n -- x ) 10 <repetition> product ;
|
||||
|
||||
: increase-cost ( rep scc factor -- )
|
||||
! Increase cost of keeping vreg in rep, making a choice of rep less
|
||||
! likely. If the rep is not in the cost alist, it means this
|
||||
! representation is prohibited.
|
||||
[ costs get at 2dup key? ] dip
|
||||
'[ [ current-loop-nesting 10^ _ * + ] change-at ] [ 2drop ] if ;
|
||||
|
||||
:: increase-costs ( vreg preferred factor -- )
|
||||
vreg vreg>scc :> scc
|
||||
scc possibilities get at [
|
||||
dup preferred eq? [ drop ] [ scc factor increase-cost ] if
|
||||
] each ; inline
|
||||
|
||||
UNION: inert-tag-untag-insn
|
||||
##add
|
||||
##sub
|
||||
##and
|
||||
##or
|
||||
##xor
|
||||
##min
|
||||
##max ;
|
||||
|
||||
UNION: inert-arithmetic-tag-untag-insn
|
||||
##add-imm
|
||||
##sub-imm ;
|
||||
|
||||
UNION: inert-bitwise-tag-untag-insn
|
||||
##and-imm
|
||||
##or-imm
|
||||
##xor-imm ;
|
||||
|
||||
GENERIC: has-peephole-opts? ( insn -- ? )
|
||||
|
||||
M: insn has-peephole-opts? drop f ;
|
||||
M: ##load-integer has-peephole-opts? drop t ;
|
||||
M: ##load-reference has-peephole-opts? drop t ;
|
||||
M: ##neg has-peephole-opts? drop t ;
|
||||
M: ##not has-peephole-opts? drop t ;
|
||||
M: inert-tag-untag-insn has-peephole-opts? drop t ;
|
||||
M: inert-arithmetic-tag-untag-insn has-peephole-opts? drop t ;
|
||||
M: inert-bitwise-tag-untag-insn has-peephole-opts? drop t ;
|
||||
M: ##mul-imm has-peephole-opts? drop t ;
|
||||
M: ##shl-imm has-peephole-opts? drop t ;
|
||||
M: ##shr-imm has-peephole-opts? drop t ;
|
||||
M: ##sar-imm has-peephole-opts? drop t ;
|
||||
M: ##compare-integer-imm has-peephole-opts? drop t ;
|
||||
M: ##compare-integer has-peephole-opts? drop t ;
|
||||
M: ##compare-integer-imm-branch has-peephole-opts? drop t ;
|
||||
M: ##compare-integer-branch has-peephole-opts? drop t ;
|
||||
|
||||
GENERIC: compute-insn-costs ( insn -- )
|
||||
|
||||
M: insn compute-insn-costs drop ;
|
||||
|
||||
M: vreg-insn compute-insn-costs
|
||||
dup has-peephole-opts? 2 5 ? '[ _ increase-costs ] each-rep ;
|
||||
|
||||
: compute-costs ( cfg -- )
|
||||
init-costs
|
||||
[
|
||||
[ basic-block set ]
|
||||
[ [ compute-insn-costs ] each-non-phi ] bi
|
||||
] each-basic-block ;
|
||||
|
||||
! For every vreg, compute preferred representation, that minimizes costs.
|
||||
: minimize-costs ( costs -- representations )
|
||||
[ nip assoc-empty? not ] assoc-filter
|
||||
[ >alist alist-min first ] assoc-map ;
|
||||
|
||||
: compute-representations ( cfg -- )
|
||||
compute-costs costs get minimize-costs
|
||||
[ components get [ disjoint-set-members ] keep ] dip
|
||||
'[ dup _ representative _ at ] H{ } map>assoc
|
||||
representations set ;
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! Copyright (C) 2009, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs fry kernel namespaces
|
||||
sequences sequences.deep
|
||||
sets vectors
|
||||
cpu.architecture
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.def-use
|
||||
compiler.cfg.renaming
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.dominance
|
||||
compiler.cfg.instructions
|
||||
|
|
@ -18,7 +18,20 @@ compiler.utilities ;
|
|||
FROM: namespaces => set ;
|
||||
IN: compiler.cfg.ssa.destruction
|
||||
|
||||
! Maps vregs to leaders.
|
||||
! Because of the design of the register allocator, this pass
|
||||
! has three peculiar properties.
|
||||
!
|
||||
! 1) Instead of renaming vreg usages in the CFG, a map from
|
||||
! vregs to canonical representatives is computed. This allows
|
||||
! the register allocator to use the original SSA names to get
|
||||
! reaching definitions.
|
||||
! 2) Useless ##copy instructions, and all ##phi instructions,
|
||||
! are eliminated, so the register allocator does not have to
|
||||
! remove any redundant operations.
|
||||
! 3) A side effect of running this pass is that SSA liveness
|
||||
! information is computed, so the register allocator does not
|
||||
! need to compute it again.
|
||||
|
||||
SYMBOL: leader-map
|
||||
|
||||
: leader ( vreg -- vreg' ) leader-map get compress-path ;
|
||||
|
|
@ -28,12 +41,15 @@ SYMBOL: class-element-map
|
|||
|
||||
: class-elements ( vreg -- elts ) class-element-map get at ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! Sequence of vreg pairs
|
||||
SYMBOL: copies
|
||||
|
||||
: init-coalescing ( -- )
|
||||
H{ } clone leader-map set
|
||||
H{ } clone class-element-map set
|
||||
defs get keys
|
||||
[ [ dup ] H{ } map>assoc leader-map set ]
|
||||
[ [ dup 1vector ] H{ } map>assoc class-element-map set ] bi
|
||||
V{ } clone copies set ;
|
||||
|
||||
: classes-interfere? ( vreg1 vreg2 -- ? )
|
||||
|
|
@ -56,25 +72,27 @@ SYMBOL: copies
|
|||
2bi
|
||||
] if ;
|
||||
|
||||
: introduce-vreg ( vreg -- )
|
||||
[ leader-map get conjoin ]
|
||||
[ [ 1vector ] keep class-element-map get set-at ] bi ;
|
||||
|
||||
GENERIC: prepare-insn ( insn -- )
|
||||
|
||||
: try-to-coalesce ( dst src -- ) 2array copies get push ;
|
||||
|
||||
M: insn prepare-insn
|
||||
[ 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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -1,130 +0,0 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences assocs accessors
|
||||
namespaces fry math sets combinators locals
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.dominance
|
||||
compiler.cfg.def-use
|
||||
compiler.cfg.instructions ;
|
||||
FROM: namespaces => set ;
|
||||
IN: compiler.cfg.ssa.liveness
|
||||
|
||||
! Liveness checking on SSA IR, as described in
|
||||
! "Fast Liveness Checking for SSA-Form Programs", Sebastian Hack et al.
|
||||
! http://hal.archives-ouvertes.fr/docs/00/19/22/19/PDF/fast_liveness.pdf
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! The sets T_q and R_q are described there
|
||||
SYMBOL: T_q-sets
|
||||
SYMBOL: R_q-sets
|
||||
|
||||
! Targets of back edges
|
||||
SYMBOL: back-edge-targets
|
||||
|
||||
: T_q ( q -- T_q )
|
||||
T_q-sets get at ;
|
||||
|
||||
: R_q ( q -- R_q )
|
||||
R_q-sets get at ;
|
||||
|
||||
: back-edge-target? ( block -- ? )
|
||||
back-edge-targets get key? ;
|
||||
|
||||
: next-R_q ( q -- R_q )
|
||||
[ ] [ successors>> ] [ number>> ] tri
|
||||
'[ number>> _ >= ] filter
|
||||
[ R_q ] map assoc-combine
|
||||
[ conjoin ] keep ;
|
||||
|
||||
: set-R_q ( q -- )
|
||||
[ next-R_q ] keep R_q-sets get set-at ;
|
||||
|
||||
: set-back-edges ( q -- )
|
||||
[ successors>> ] [ number>> ] bi '[
|
||||
dup number>> _ <
|
||||
[ back-edge-targets get conjoin ] [ drop ] if
|
||||
] each ;
|
||||
|
||||
: init-R_q ( -- )
|
||||
H{ } clone R_q-sets set
|
||||
H{ } clone back-edge-targets set ;
|
||||
|
||||
: compute-R_q ( cfg -- )
|
||||
init-R_q
|
||||
post-order [
|
||||
[ set-R_q ] [ set-back-edges ] bi
|
||||
] each ;
|
||||
|
||||
! This algorithm for computing T_q uses equation (1)
|
||||
! but not the faster algorithm described in the paper
|
||||
|
||||
: back-edges-from ( q -- edges )
|
||||
R_q keys [
|
||||
[ successors>> ] [ number>> ] bi
|
||||
'[ number>> _ < ] filter
|
||||
] gather ;
|
||||
|
||||
: T^_q ( q -- T^_q )
|
||||
[ back-edges-from ] [ R_q ] bi
|
||||
'[ _ key? not ] filter ;
|
||||
|
||||
: next-T_q ( q -- T_q )
|
||||
dup dup T^_q [ next-T_q keys ] map
|
||||
concat unique [ conjoin ] keep
|
||||
[ swap T_q-sets get set-at ] keep ;
|
||||
|
||||
: compute-T_q ( cfg -- )
|
||||
H{ } T_q-sets set
|
||||
[ next-T_q drop ] each-basic-block ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: precompute-liveness ( cfg -- )
|
||||
[ compute-R_q ] [ compute-T_q ] bi ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! This doesn't take advantage of ordering T_q,a so you
|
||||
! only have to check one if the CFG is reducible.
|
||||
! It should be changed to be more efficient.
|
||||
|
||||
: only? ( seq obj -- ? )
|
||||
'[ _ eq? ] all? ;
|
||||
|
||||
: strictly-dominates? ( bb1 bb2 -- ? )
|
||||
[ dominates? ] [ eq? not ] 2bi and ;
|
||||
|
||||
: T_q,a ( a q -- T_q,a )
|
||||
! This could take advantage of the structure of dominance,
|
||||
! but probably I'll replace it with the algorithm that works
|
||||
! on reducible CFGs anyway
|
||||
T_q keys swap def-of
|
||||
[ '[ _ swap strictly-dominates? ] filter ] when* ;
|
||||
|
||||
: live? ( vreg node quot -- ? )
|
||||
[ [ T_q,a ] [ drop uses-of ] 2bi ] dip
|
||||
'[ [ R_q keys _ ] keep @ intersects? ] any? ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: live-in? ( vreg node -- ? )
|
||||
[ drop ] live? ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (live-out?) ( vreg node -- ? )
|
||||
dup dup dup '[
|
||||
_ = _ back-edge-target? not and
|
||||
[ _ swap remove ] when
|
||||
] live? ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
:: live-out? ( vreg node -- ? )
|
||||
vreg def-of :> def
|
||||
{
|
||||
{ [ node def eq? ] [ vreg uses-of def only? not ] }
|
||||
{ [ def node strictly-dominates? ] [ vreg node (live-out?) ] }
|
||||
[ f ]
|
||||
} cond ;
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue