diff --git a/Factor.app/Contents/Resources/English.lproj/Factor.nib/info.nib b/Factor.app/Contents/Resources/English.lproj/Factor.nib/info.nib index 1096a1224a..1d9f641c11 100644 --- a/Factor.app/Contents/Resources/English.lproj/Factor.nib/info.nib +++ b/Factor.app/Contents/Resources/English.lproj/Factor.nib/info.nib @@ -3,15 +3,13 @@ IBFramework Version - 629 + 677 IBOldestOS 5 IBOpenObjects - - 305 - + IBSystem Version - 9G55 + 9J61 targetFramework IBCocoaFramework diff --git a/Factor.app/Contents/Resources/English.lproj/Factor.nib/keyedobjects.nib b/Factor.app/Contents/Resources/English.lproj/Factor.nib/keyedobjects.nib index c30c9e4bfd..1659393f2e 100644 Binary files a/Factor.app/Contents/Resources/English.lproj/Factor.nib/keyedobjects.nib and b/Factor.app/Contents/Resources/English.lproj/Factor.nib/keyedobjects.nib differ diff --git a/Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/classes.nib b/Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/classes.nib index bf3d2a6560..34be3452ee 100644 --- a/Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/classes.nib +++ b/Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/classes.nib @@ -1,17 +1,32 @@ -{ - IBClasses = ( - { - ACTIONS = { - newFactorWorkspace = id; - runFactorFile = id; - saveFactorImage = id; - saveFactorImageAs = id; - showFactorHelp = id; - }; - CLASS = FirstResponder; - LANGUAGE = ObjC; - SUPERCLASS = NSObject; - } - ); - IBVersion = 1; -} \ No newline at end of file + + + + + IBClasses + + + ACTIONS + + newFactorWorkspace + id + runFactorFile + id + saveFactorImage + id + saveFactorImageAs + id + showFactorHelp + id + + CLASS + FirstResponder + LANGUAGE + ObjC + SUPERCLASS + NSObject + + + IBVersion + 1 + + diff --git a/Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/info.nib b/Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/info.nib index 3a18202826..86277eb8a8 100644 --- a/Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/info.nib +++ b/Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/info.nib @@ -1,21 +1,18 @@ - + - IBDocumentLocation - 1266 155 525 491 0 0 2560 1578 - IBEditorPositions - - 29 - 326 905 270 44 0 0 2560 1578 - IBFramework Version - 439.0 + 677 + IBOldestOS + 5 IBOpenObjects - 29 + 293 IBSystem Version - 8R218 + 9J61 + targetFramework + IBCocoaFramework diff --git a/Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/keyedobjects.nib b/Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/keyedobjects.nib index 34abd139a6..9929114395 100644 Binary files a/Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/keyedobjects.nib and b/Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/keyedobjects.nib differ diff --git a/README.txt b/README.txt index a33a85b218..016d60e68c 100755 --- a/README.txt +++ b/README.txt @@ -55,10 +55,13 @@ For X11 support, you need recent development libraries for libc, Pango, X11, and OpenGL. On a Debian-derived Linux distribution (like Ubuntu), you can use the following line to grab everything: - sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev + sudo apt-get install libc6-dev libpango1.0-dev libx11-dev libgl1-mesa-dev + +Note that if you are using a proprietary OpenGL driver, you should +probably leave out the last package in the list. If your DISPLAY environment variable is set, the UI will start -automatically: +automatically when you run Factor: ./factor diff --git a/basis/alarms/alarms-tests.factor b/basis/alarms/alarms-tests.factor index 7c64680a83..2379e3e80d 100644 --- a/basis/alarms/alarms-tests.factor +++ b/basis/alarms/alarms-tests.factor @@ -1,6 +1,6 @@ -IN: alarms.tests USING: alarms alarms.private kernel calendar sequences tools.test threads concurrency.count-downs ; +IN: alarms.tests [ ] [ 1 diff --git a/basis/alarms/alarms.factor b/basis/alarms/alarms.factor index f9fdce806f..9943d39ad1 100644 --- a/basis/alarms/alarms.factor +++ b/basis/alarms/alarms.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays calendar combinators generic init -kernel math namespaces sequences heaps boxes threads -quotations assocs math.order ; +USING: accessors assocs boxes calendar +combinators.short-circuit fry heaps init kernel math.order +namespaces quotations threads ; IN: alarms TUPLE: alarm @@ -21,21 +21,21 @@ SYMBOL: alarm-thread ERROR: bad-alarm-frequency frequency ; : check-alarm ( frequency/f -- frequency/f ) - dup [ duration? ] [ not ] bi or [ bad-alarm-frequency ] unless ; + dup { [ duration? ] [ not ] } 1|| [ bad-alarm-frequency ] unless ; : ( quot time frequency -- alarm ) check-alarm alarm boa ; : register-alarm ( alarm -- ) - dup dup time>> alarms get-global heap-push* - swap entry>> >box + [ dup time>> alarms get-global heap-push* ] + [ entry>> >box ] bi notify-alarm-thread ; : alarm-expired? ( alarm now -- ? ) [ time>> ] dip before=? ; : reschedule-alarm ( alarm -- ) - dup [ swap interval>> time+ now max ] change-time register-alarm ; + dup '[ _ interval>> time+ now max ] change-time register-alarm ; : call-alarm ( alarm -- ) [ entry>> box> drop ] diff --git a/basis/alien/arrays/arrays-docs.factor b/basis/alien/arrays/arrays-docs.factor old mode 100644 new mode 100755 index c5efe1e030..db4a7bf595 --- a/basis/alien/arrays/arrays-docs.factor +++ b/basis/alien/arrays/arrays-docs.factor @@ -4,4 +4,9 @@ USING: help.syntax help.markup byte-arrays alien.c-types ; ARTICLE: "c-arrays" "C arrays" "C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "." $nl -"C type specifiers for array types are documented in " { $link "c-types-specs" } "." ; +"C type specifiers for array types are documented in " { $link "c-types-specs" } "." +$nl +"Specialized sequences are provided for accessing memory as an array of primitive type values. These sequences are implemented in the " { $vocab-link "specialized-arrays" } " vocabulary set. They can also be loaded and constructed through their primitive C types:" +{ $subsection require-c-array } +{ $subsection } +{ $subsection } ; diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index e4a0e4dcf0..64827ec139 100755 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.strings alien.c-types alien.accessors alien.structs arrays words sequences math kernel namespaces fry libc cpu.architecture -io.encodings.utf8 ; +io.encodings.utf8 accessors ; IN: alien.arrays UNION: value-type array struct-type ; @@ -11,7 +11,12 @@ M: array c-type ; M: array c-type-class drop object ; -M: array heap-size unclip [ product ] [ heap-size ] bi* * ; +M: array c-type-boxed-class drop object ; + +: array-length ( seq -- n ) + [ dup word? [ def>> call( -- object ) ] when ] [ * ] map-reduce ; + +M: array heap-size unclip [ array-length ] [ heap-size ] bi* * ; M: array c-type-align first c-type-align ; @@ -27,11 +32,15 @@ M: array box-return drop "void*" box-return ; M: array stack-size drop "void*" stack-size ; -M: array c-type-boxer-quot drop [ ] ; +M: array c-type-boxer-quot + unclip + [ array-length ] + [ [ require-c-array ] keep ] bi* + [ ] 2curry ; M: array c-type-unboxer-quot drop [ >c-ptr ] ; -M: value-type c-type-reg-class drop int-regs ; +M: value-type c-type-rep drop int-rep ; M: value-type c-type-getter drop [ swap ] ; @@ -45,8 +54,9 @@ PREDICATE: string-type < pair M: string-type c-type ; -M: string-type c-type-class - drop object ; +M: string-type c-type-class drop object ; + +M: string-type c-type-boxed-class drop object ; M: string-type heap-size drop "void*" heap-size ; @@ -72,8 +82,8 @@ M: string-type box-return M: string-type stack-size drop "void*" stack-size ; -M: string-type c-type-reg-class - drop int-regs ; +M: string-type c-type-rep + drop int-rep ; M: string-type c-type-boxer drop "void*" c-type-boxer ; diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor old mode 100644 new mode 100755 index c9c1ecd0e5..3a7c3a7405 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -1,7 +1,7 @@ IN: alien.c-types USING: alien help.syntax help.markup libc kernel.private byte-arrays math strings hashtables alien.syntax alien.strings sequences -io.encodings.string debugger destructors ; +io.encodings.string debugger destructors vocabs.loader ; HELP: { $values { "type" hashtable } } @@ -49,11 +49,10 @@ HELP: c-setter { $errors "Throws an error if the type does not exist." } ; HELP: -{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" byte-array } } +{ $values { "len" "a non-negative integer" } { "c-type" "a C type" } { "array" byte-array } } { $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." } -{ $errors "Throws an error if the type does not exist or the requested size is negative." } ; - -{ malloc-array } related-words +{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." } +{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ; HELP: { $values { "type" "a C type" } { "array" byte-array } } @@ -73,9 +72,10 @@ HELP: byte-array>memory HELP: malloc-array { $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } } -{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type." } +{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link } "." } +{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." } { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } -{ $errors "Throws an error if the type does not exist, if the requested size is negative, or if memory allocation fails." } ; +{ $errors "Throws an error if the type does not exist, if the requested size is negative, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ; HELP: malloc-object { $values { "type" "a C type" } { "alien" alien } } @@ -89,6 +89,8 @@ HELP: malloc-byte-array { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } { $errors "Throws an error if memory allocation fails." } ; +{ malloc-array } related-words + HELP: box-parameter { $values { "n" integer } { "ctype" string } } { $description "Generates code for converting a C value stored at offset " { $snippet "n" } " from the top of the stack into a Factor object to be pushed on the data stack." } @@ -128,6 +130,16 @@ HELP: malloc-string } } ; +HELP: require-c-array +{ $values { "c-type" "a C type" } } +{ $description { $link require } "s any unloaded vocabularies needed to construct a specialized array of " { $snippet "c-type" } " using the " { $link } " or " { $link } " vocabularies." } +{ $notes "This word must be called inside a compilation unit. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence types loaded." } ; + +HELP: +{ $values { "alien" c-ptr } { "len" integer } { "c-type" "a C type" } { "array" "a specialized direct array" } } +{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } " over the range of memory referenced by " { $snippet "alien" } "." } +{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." } ; + ARTICLE: "c-strings" "C strings" "C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors." $nl diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor index ea9e881fd4..bfeff5f1de 100644 --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -1,10 +1,10 @@ -IN: alien.c-types.tests USING: alien alien.syntax alien.c-types kernel tools.test sequences system libc alien.strings io.encodings.utf8 ; +IN: alien.c-types.tests CONSTANT: xyz 123 -[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test +[ 492 ] [ { "int" xyz } heap-size ] unit-test [ -1 ] [ -1 *char ] unit-test [ -1 ] [ -1 *short ] unit-test diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 6e398667ec..86e695831c 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -5,7 +5,7 @@ namespaces make parser sequences strings words splitting math.parser cpu.architecture alien alien.accessors alien.strings quotations layouts system compiler.units io io.files io.encodings.binary io.streams.memory accessors combinators effects continuations fry -classes ; +classes vocabs vocabs.loader ; IN: alien.c-types DEFER: @@ -13,17 +13,24 @@ DEFER: *char : little-endian? ( -- ? ) 1 *char 1 = ; foldable -TUPLE: c-type +TUPLE: abstract-c-type { class class initial: object } -boxer +{ boxed-class class initial: object } { boxer-quot callable } -unboxer { unboxer-quot callable } { getter callable } { setter callable } -{ reg-class initial: int-regs } size align +array-class +array-constructor +(array)-constructor +direct-array-constructor ; + +TUPLE: c-type < abstract-c-type +boxer +unboxer +{ rep initial: int-rep } stack-align? ; : ( -- type ) @@ -68,12 +75,88 @@ M: string c-type ( name -- type ) ] ?if ] if ; +: ?require-word ( word/pair -- ) + dup word? [ drop ] [ first require ] ?if ; + +! These words being foldable means that words need to be +! recompiled if a C type is redefined. Even so, folding the +! size facilitates some optimizations. +GENERIC: heap-size ( type -- size ) foldable + +M: string heap-size c-type heap-size ; + +M: abstract-c-type heap-size size>> ; + +GENERIC: require-c-array ( c-type -- ) + +M: object require-c-array + drop ; + +M: c-type require-c-array + array-class>> ?require-word ; + +M: string require-c-array + c-type require-c-array ; + +M: array require-c-array + first c-type require-c-array ; + +ERROR: specialized-array-vocab-not-loaded vocab word ; + +: c-array-constructor ( c-type -- word ) + array-constructor>> dup array? + [ first2 specialized-array-vocab-not-loaded ] when ; foldable + +: c-(array)-constructor ( c-type -- word ) + (array)-constructor>> dup array? + [ first2 specialized-array-vocab-not-loaded ] when ; foldable + +: c-direct-array-constructor ( c-type -- word ) + direct-array-constructor>> dup array? + [ first2 specialized-array-vocab-not-loaded ] when ; foldable + +GENERIC: ( len c-type -- array ) +M: object + c-array-constructor execute( len -- array ) ; inline +M: string + c-type ; inline +M: array + first c-type ; inline + +GENERIC: (c-array) ( len c-type -- array ) +M: object (c-array) + c-(array)-constructor execute( len -- array ) ; inline +M: string (c-array) + c-type (c-array) ; inline +M: array (c-array) + first c-type (c-array) ; inline + +GENERIC: ( alien len c-type -- array ) +M: object + c-direct-array-constructor execute( alien len -- array ) ; inline +M: string + c-type ; inline +M: array + first c-type ; inline + +: malloc-array ( n type -- alien ) + [ heap-size calloc ] [ ] 2bi ; inline + +: (malloc-array) ( n type -- alien ) + [ heap-size * malloc ] [ ] 2bi ; inline + GENERIC: c-type-class ( name -- class ) -M: c-type c-type-class class>> ; +M: abstract-c-type c-type-class class>> ; M: string c-type-class c-type c-type-class ; +GENERIC: c-type-boxed-class ( name -- class ) + +M: abstract-c-type c-type-boxed-class boxed-class>> ; + +M: string c-type-boxed-class c-type c-type-boxed-class ; + GENERIC: c-type-boxer ( name -- boxer ) M: c-type c-type-boxer boxer>> ; @@ -82,7 +165,7 @@ M: string c-type-boxer c-type c-type-boxer ; GENERIC: c-type-boxer-quot ( name -- quot ) -M: c-type c-type-boxer-quot boxer-quot>> ; +M: abstract-c-type c-type-boxer-quot boxer-quot>> ; M: string c-type-boxer-quot c-type c-type-boxer-quot ; @@ -94,15 +177,15 @@ M: string c-type-unboxer c-type c-type-unboxer ; GENERIC: c-type-unboxer-quot ( name -- quot ) -M: c-type c-type-unboxer-quot unboxer-quot>> ; +M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ; M: string c-type-unboxer-quot c-type c-type-unboxer-quot ; -GENERIC: c-type-reg-class ( name -- reg-class ) +GENERIC: c-type-rep ( name -- rep ) -M: c-type c-type-reg-class reg-class>> ; +M: c-type c-type-rep rep>> ; -M: string c-type-reg-class c-type c-type-reg-class ; +M: string c-type-rep c-type c-type-rep ; GENERIC: c-type-getter ( name -- quot ) @@ -118,7 +201,7 @@ M: string c-type-setter c-type c-type-setter ; GENERIC: c-type-align ( name -- n ) -M: c-type c-type-align align>> ; +M: abstract-c-type c-type-align align>> ; M: string c-type-align c-type c-type-align ; @@ -129,13 +212,11 @@ M: c-type c-type-stack-align? stack-align?>> ; M: string c-type-stack-align? c-type c-type-stack-align? ; : c-type-box ( n type -- ) - dup c-type-reg-class - swap c-type-boxer [ "No boxer" throw ] unless* + [ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi %box ; : c-type-unbox ( n ctype -- ) - dup c-type-reg-class - swap c-type-unboxer [ "No unboxer" throw ] unless* + [ c-type-rep ] [ c-type-unboxer [ "No unboxer" throw ] unless* ] bi %unbox ; GENERIC: box-parameter ( n ctype -- ) @@ -162,15 +243,6 @@ M: c-type unbox-return f swap c-type-unbox ; M: string unbox-return c-type unbox-return ; -! These words being foldable means that words need to be -! recompiled if a C type is redefined. Even so, folding the -! size facilitates some optimizations. -GENERIC: heap-size ( type -- size ) foldable - -M: string heap-size c-type heap-size ; - -M: c-type heap-size size>> ; - GENERIC: stack-size ( type -- size ) foldable M: string stack-size c-type stack-size ; @@ -179,9 +251,9 @@ M: c-type stack-size size>> cell align ; GENERIC: byte-length ( seq -- n ) flushable -M: byte-array byte-length length ; +M: byte-array byte-length length ; inline -M: f byte-length drop 0 ; +M: f byte-length drop 0 ; inline : c-getter ( name -- quot ) c-type-getter [ @@ -196,17 +268,17 @@ M: f byte-length drop 0 ; [ "Cannot write struct fields with this type" throw ] ] unless* ; -: ( n type -- array ) - heap-size * ; inline - : ( type -- array ) - 1 swap ; inline + heap-size ; inline -: malloc-array ( n type -- alien ) - heap-size calloc ; inline +: (c-object) ( type -- array ) + heap-size (byte-array) ; inline : malloc-object ( type -- alien ) - 1 swap malloc-array ; inline + 1 swap heap-size calloc ; inline + +: (malloc-object) ( type -- alien ) + heap-size malloc ; inline : malloc-byte-array ( byte-array -- alien ) dup byte-length [ nip malloc dup ] 2keep memcpy ; @@ -224,7 +296,7 @@ M: memory-stream stream-read ] [ [ + ] change-index drop ] 2bi ; : byte-array>memory ( byte-array base -- ) - swap dup byte-length memcpy ; + swap dup byte-length memcpy ; inline : array-accessor ( type quot -- def ) [ @@ -269,23 +341,38 @@ M: long-long-type box-return ( type -- ) [ define-out ] tri ; -: expand-constants ( c-type -- c-type' ) - dup array? [ - unclip [ - [ - dup word? [ - def>> call( -- object ) - ] when - ] map - ] dip prefix - ] when ; - : malloc-file-contents ( path -- alien len ) binary file-contents [ malloc-byte-array ] [ length ] bi ; : if-void ( type true false -- ) pick "void" = [ drop nip call ] [ nip call ] if ; inline +: ?lookup ( vocab word -- word/pair ) + over vocab [ swap lookup ] [ 2array ] if ; + +: set-array-class* ( c-type vocab-stem type-stem -- c-type ) + { + [ + [ "specialized-arrays." prepend ] + [ "-array" append ] bi* ?lookup >>array-class + ] + [ + [ "specialized-arrays." prepend ] + [ "<" "-array>" surround ] bi* ?lookup >>array-constructor + ] + [ + [ "specialized-arrays." prepend ] + [ "(" "-array)" surround ] bi* ?lookup >>(array)-constructor + ] + [ + [ "specialized-arrays." prepend ] + [ "" surround ] bi* ?lookup >>direct-array-constructor + ] + } 2cleave ; + +: set-array-class ( c-type stem -- c-type ) + dup set-array-class* ; + CONSTANT: primitive-types { "char" "uchar" @@ -300,6 +387,7 @@ CONSTANT: primitive-types [ c-ptr >>class + c-ptr >>boxed-class [ alien-cell ] >>getter [ [ >c-ptr ] 2dip set-alien-cell ] >>setter bootstrap-cell >>size @@ -307,106 +395,127 @@ CONSTANT: primitive-types [ >c-ptr ] >>unboxer-quot "box_alien" >>boxer "alien_offset" >>unboxer + "alien" "void*" set-array-class* "void*" define-primitive-type integer >>class + integer >>boxed-class [ alien-signed-8 ] >>getter [ set-alien-signed-8 ] >>setter 8 >>size 8 >>align "box_signed_8" >>boxer "to_signed_8" >>unboxer + "longlong" set-array-class "longlong" define-primitive-type integer >>class + integer >>boxed-class [ alien-unsigned-8 ] >>getter [ set-alien-unsigned-8 ] >>setter 8 >>size 8 >>align "box_unsigned_8" >>boxer "to_unsigned_8" >>unboxer + "ulonglong" set-array-class "ulonglong" define-primitive-type integer >>class + integer >>boxed-class [ alien-signed-cell ] >>getter [ set-alien-signed-cell ] >>setter bootstrap-cell >>size bootstrap-cell >>align "box_signed_cell" >>boxer "to_fixnum" >>unboxer + "long" set-array-class "long" define-primitive-type integer >>class + integer >>boxed-class [ alien-unsigned-cell ] >>getter [ set-alien-unsigned-cell ] >>setter bootstrap-cell >>size bootstrap-cell >>align "box_unsigned_cell" >>boxer "to_cell" >>unboxer + "ulong" set-array-class "ulong" define-primitive-type integer >>class + integer >>boxed-class [ alien-signed-4 ] >>getter [ set-alien-signed-4 ] >>setter 4 >>size 4 >>align "box_signed_4" >>boxer "to_fixnum" >>unboxer + "int" set-array-class "int" define-primitive-type integer >>class + integer >>boxed-class [ alien-unsigned-4 ] >>getter [ set-alien-unsigned-4 ] >>setter 4 >>size 4 >>align "box_unsigned_4" >>boxer "to_cell" >>unboxer + "uint" set-array-class "uint" define-primitive-type fixnum >>class + fixnum >>boxed-class [ alien-signed-2 ] >>getter [ set-alien-signed-2 ] >>setter 2 >>size 2 >>align "box_signed_2" >>boxer "to_fixnum" >>unboxer + "short" set-array-class "short" define-primitive-type fixnum >>class + fixnum >>boxed-class [ alien-unsigned-2 ] >>getter [ set-alien-unsigned-2 ] >>setter 2 >>size 2 >>align "box_unsigned_2" >>boxer "to_cell" >>unboxer + "ushort" set-array-class "ushort" define-primitive-type fixnum >>class + fixnum >>boxed-class [ alien-signed-1 ] >>getter [ set-alien-signed-1 ] >>setter 1 >>size 1 >>align "box_signed_1" >>boxer "to_fixnum" >>unboxer + "char" set-array-class "char" define-primitive-type fixnum >>class + fixnum >>boxed-class [ alien-unsigned-1 ] >>getter [ set-alien-unsigned-1 ] >>setter 1 >>size 1 >>align "box_unsigned_1" >>boxer "to_cell" >>unboxer + "uchar" set-array-class "uchar" define-primitive-type @@ -416,33 +525,39 @@ CONSTANT: primitive-types 1 >>align "box_boolean" >>boxer "to_boolean" >>unboxer + "bool" set-array-class "bool" define-primitive-type float >>class + float >>boxed-class [ alien-float ] >>getter [ [ >float ] 2dip set-alien-float ] >>setter 4 >>size 4 >>align "box_float" >>boxer "to_float" >>unboxer - single-float-regs >>reg-class + single-float-rep >>rep [ >float ] >>unboxer-quot + "float" set-array-class "float" define-primitive-type float >>class + float >>boxed-class [ alien-double ] >>getter [ [ >float ] 2dip set-alien-double ] >>setter 8 >>size 8 >>align "box_double" >>boxer "to_double" >>unboxer - double-float-regs >>reg-class + double-float-rep >>rep [ >float ] >>unboxer-quot + "double" set-array-class "double" define-primitive-type "long" "ptrdiff_t" typedef "long" "intptr_t" typedef "ulong" "size_t" typedef ] with-compilation-unit + diff --git a/basis/alien/complex/complex-tests.factor b/basis/alien/complex/complex-tests.factor index 0bff73b898..7bf826d87e 100644 --- a/basis/alien/complex/complex-tests.factor +++ b/basis/alien/complex/complex-tests.factor @@ -1,18 +1,21 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test alien.complex kernel alien.c-types alien.syntax -namespaces ; +USING: accessors tools.test alien.complex classes.struct kernel +alien.c-types alien.syntax namespaces math ; IN: alien.complex.tests -C-STRUCT: complex-holder - { "complex-float" "z" } ; +STRUCT: complex-holder + { z complex-float } ; : ( z -- alien ) - "complex-holder" - [ set-complex-holder-z ] keep ; + complex-holder ; [ ] [ C{ 1.0 2.0 } "h" set ] unit-test -[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test +[ C{ 1.0 2.0 } ] [ "h" get z>> ] unit-test + +[ number ] [ "complex-float" c-type-boxed-class ] unit-test + +[ number ] [ "complex-double" c-type-boxed-class ] unit-test diff --git a/basis/alien/complex/complex.factor b/basis/alien/complex/complex.factor index c80ead73f0..b0229358d1 100644 --- a/basis/alien/complex/complex.factor +++ b/basis/alien/complex/complex.factor @@ -10,4 +10,4 @@ IN: alien.complex ! This overrides the fact that small structures are never returned ! in registers on NetBSD, Linux and Solaris running on 32-bit x86. "complex-float" c-type t >>return-in-registers? drop - >> +>> diff --git a/basis/alien/complex/functor/functor-tests.factor b/basis/alien/complex/functor/functor-tests.factor deleted file mode 100644 index c2df22be1d..0000000000 --- a/basis/alien/complex/functor/functor-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test alien.complex.functor ; -IN: alien.complex.functor.tests diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor index fc9e594be5..b05059e9cb 100644 --- a/basis/alien/complex/functor/functor.factor +++ b/basis/alien/complex/functor/functor.factor @@ -1,35 +1,32 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.structs alien.c-types math math.functions sequences -arrays kernel functors vocabs.parser namespaces accessors -quotations ; +USING: accessors alien alien.structs alien.c-types classes.struct math +math.functions sequences arrays kernel functors vocabs.parser +namespaces quotations ; IN: alien.complex.functor FUNCTOR: define-complex-type ( N T -- ) -T-real DEFINES ${T}-real -T-imaginary DEFINES ${T}-imaginary -set-T-real DEFINES set-${T}-real -set-T-imaginary DEFINES set-${T}-imaginary +T-class DEFINES-CLASS ${T} DEFINES <${T}> *T DEFINES *${T} WHERE +STRUCT: T-class { real N } { imaginary N } ; + : ( z -- alien ) - >rect T [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline + >rect T-class >c-ptr ; : *T ( alien -- z ) - [ T-real ] [ T-imaginary ] bi rect> ; inline + T-class memory>struct [ real>> ] [ imaginary>> ] bi rect> ; inline -T current-vocab -{ { N "real" } { N "imaginary" } } -define-struct - -T c-type +T-class c-type 1quotation >>unboxer-quot *T 1quotation >>boxer-quot +number >>boxed-class +T set-array-class drop ;FUNCTOR diff --git a/basis/alien/destructors/destructors-tests.factor b/basis/alien/destructors/destructors-tests.factor deleted file mode 100644 index 4f434452d4..0000000000 --- a/basis/alien/destructors/destructors-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test alien.destructors ; -IN: alien.destructors.tests diff --git a/basis/alien/destructors/destructors.factor b/basis/alien/destructors/destructors.factor index 374d6425c4..7fd991b9af 100755 --- a/basis/alien/destructors/destructors.factor +++ b/basis/alien/destructors/destructors.factor @@ -4,7 +4,7 @@ USING: functors destructors accessors kernel parser words effects generalizations sequences ; IN: alien.destructors -SLOT: alien +TUPLE: alien-destructor alien ; FUNCTOR: define-destructor ( F -- ) @@ -16,11 +16,12 @@ N [ F stack-effect out>> length ] WHERE -TUPLE: F-destructor alien disposed ; +TUPLE: F-destructor < alien-destructor ; -: ( alien -- destructor ) f F-destructor boa ; inline +: ( alien -- destructor ) + F-destructor boa ; inline -M: F-destructor dispose* alien>> F N ndrop ; +M: F-destructor dispose alien>> F N ndrop ; : &F ( alien -- alien ) dup &dispose drop ; inline diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 54b799f675..013c4d6f6a 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -357,15 +357,15 @@ M: character-type () : (shuffle-map) ( return parameters -- ret par ) [ - fortran-ret-type>c-type length swap "void" = [ 1+ ] unless + fortran-ret-type>c-type length swap "void" = [ 1 + ] unless letters swap head [ "ret" swap suffix ] map ] [ - [ fortran-arg-type>c-type nip length 1+ ] map letters swap zip + [ fortran-arg-type>c-type nip length 1 + ] map letters swap zip [ first2 letters swap head [ "" 2sequence ] with map ] map concat ] bi* ; : (fortran-in-shuffle) ( ret par -- seq ) - [ [ second ] bi@ <=> ] sort append ; + [ second ] sort-with append ; : (fortran-out-shuffle) ( ret par -- seq ) append ; diff --git a/basis/alien/libraries/libraries-docs.factor b/basis/alien/libraries/libraries-docs.factor index eac7655c38..a23a00b502 100755 --- a/basis/alien/libraries/libraries-docs.factor +++ b/basis/alien/libraries/libraries-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.syntax assocs help.markup -help.syntax io.backend kernel namespaces ; +help.syntax io.backend kernel namespaces strings ; IN: alien.libraries HELP: @@ -15,7 +15,7 @@ HELP: libraries { $description "A global hashtable that keeps a list of open libraries. Use the " { $link add-library } " word to construct a library and add it with a single call." } ; HELP: library -{ $values { "name" "a string" } { "library" assoc } } +{ $values { "name" string } { "library" assoc } } { $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:" { $list { { $snippet "name" } " - the full path of the C library binary" } @@ -40,11 +40,11 @@ HELP: dlclose ( dll -- ) { $description "Closes a DLL handle created by " { $link dlopen } ". This word might not be implemented on all platforms." } ; HELP: load-library -{ $values { "name" "a string" } { "dll" "a DLL handle" } } +{ $values { "name" string } { "dll" "a DLL handle" } } { $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." } ; HELP: add-library -{ $values { "name" "a string" } { "path" "a string" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } } +{ $values { "name" string } { "path" string } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } } { $description "Defines a new logical library named " { $snippet "name" } " located in the file system at " { $snippet "path" } "and the specified ABI." } { $notes "Because the entire source file is parsed before top-level forms are executed, " { $link add-library } " cannot be used in the same file as " { $link POSTPONE: FUNCTION: } " definitions from that library. The " { $link add-library } " call will happen too late, after compilation, and the alien calls will not work." $nl @@ -59,9 +59,14 @@ $nl } "Note the parse time evaluation with " { $link POSTPONE: << } "." } ; +HELP: remove-library +{ $values { "name" string } } +{ $description "Unloads a library and removes it from the internal list of libraries. The " { $snippet "name" } " parameter should be a name that was previously passed to " { $link add-library } ". If no library with that name exists, this word does nothing." } ; + ARTICLE: "loading-libs" "Loading native libraries" "Before calling a C library, you must associate its path name on disk with a logical name which Factor uses to identify the library:" { $subsection add-library } +{ $subsection remove-library } "Once a library has been defined, you can try loading it to see if the path name is correct:" { $subsection load-library } "If the compiler cannot load a library, or cannot resolve a symbol in a library, a linkage error is reported using the compiler error mechanism (see " { $link "compiler-errors" } "). Once you install the right library, reload the source file containing the " { $link add-library } " form to force the compiler to try loading the library again." ; diff --git a/basis/alien/libraries/libraries-tests.factor b/basis/alien/libraries/libraries-tests.factor new file mode 100644 index 0000000000..f1dc228d83 --- /dev/null +++ b/basis/alien/libraries/libraries-tests.factor @@ -0,0 +1,10 @@ +USING: alien.libraries alien.syntax tools.test kernel ; +IN: alien.libraries.tests + +[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test + +[ f ] [ "does not exist" DLL" fadsfasfdsaf" dlsym ] unit-test + +[ ] [ "doesnotexist" dlopen dlclose ] unit-test + +[ "fdasfsf" dll-valid? drop ] must-fail diff --git a/basis/alien/libraries/libraries.factor b/basis/alien/libraries/libraries.factor index 0b39bedadd..0d255b8d07 100755 --- a/basis/alien/libraries/libraries.factor +++ b/basis/alien/libraries/libraries.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.strings assocs io.backend kernel namespaces ; +USING: accessors alien alien.strings assocs io.backend +kernel namespaces destructors ; IN: alien.libraries : dlopen ( path -- dll ) native-string>alien (dlopen) ; @@ -21,5 +22,13 @@ TUPLE: library path abi dll ; : load-library ( name -- dll ) library dup [ dll>> ] when ; +M: dll dispose dlclose ; + +M: library dispose dll>> [ dispose ] when* ; + +: remove-library ( name -- ) + libraries get delete-at* [ dispose ] [ drop ] if ; + : add-library ( name path abi -- ) - swap libraries get set-at ; \ No newline at end of file + [ 2drop remove-library ] + [ swap libraries get set-at ] 3bi ; \ No newline at end of file diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index df1dd15bfb..19ab08c03c 100644 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -1,18 +1,30 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays assocs effects grouping kernel -parser sequences splitting words fry locals lexer namespaces ; +parser sequences splitting words fry locals lexer namespaces +summary math ; IN: alien.parser +: normalize-c-arg ( type name -- type' name' ) + [ length ] + [ + [ CHAR: * = ] trim-head + [ length - CHAR: * append ] keep + ] bi ; + : parse-arglist ( parameters return -- types effect ) - [ 2 group unzip [ "," ?tail drop ] map ] + [ + 2 group [ first2 normalize-c-arg 2array ] map + unzip [ "," ?tail drop ] map + ] [ [ { } ] [ 1array ] if-void ] bi* ; : function-quot ( return library function types -- quot ) '[ _ _ _ _ alien-invoke ] ; -:: make-function ( return library function parameters -- word quot effect ) +:: make-function ( return! library function! parameters -- word quot effect ) + return function normalize-c-arg function! return! function create-in dup reset-generic return library function parameters return parse-arglist [ function-quot ] dip ; diff --git a/basis/alien/structs/fields/fields.factor b/basis/alien/structs/fields/fields.factor index 7e2d4615b5..1fa2fe0b0c 100644 --- a/basis/alien/structs/fields/fields.factor +++ b/basis/alien/structs/fields/fields.factor @@ -7,16 +7,16 @@ IN: alien.structs.fields TUPLE: field-spec name offset type reader writer ; : reader-word ( class name vocab -- word ) - [ "-" glue ] dip create ; + [ "-" glue ] dip create dup make-deprecated ; : writer-word ( class name vocab -- word ) - [ [ swap "set-" % % "-" % % ] "" make ] dip create ; + [ [ swap "set-" % % "-" % % ] "" make ] dip create dup make-deprecated ; : ( struct-name vocab type field-name -- spec ) field-spec new 0 >>offset swap >>name - swap expand-constants >>type + swap >>type 3dup name>> swap reader-word >>reader 3dup name>> swap writer-word >>writer 2nip ; diff --git a/basis/alien/structs/structs-docs.factor b/basis/alien/structs/structs-docs.factor index 2f7a7eadc8..c2a7d43387 100644 --- a/basis/alien/structs/structs-docs.factor +++ b/basis/alien/structs/structs-docs.factor @@ -23,11 +23,11 @@ $nl } "C structure objects can be allocated by calling " { $link } " or " { $link malloc-object } "." $nl -"Arrays of C structures can be created by calling " { $link } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-STRUCT: } "." ; +"Arrays of C structures can be created with the " { $vocab-link "struct-arrays" } " vocabulary." ; ARTICLE: "c-unions" "C unions" "A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values." { $subsection POSTPONE: C-UNION: } "C union objects can be allocated by calling " { $link } " or " { $link malloc-object } "." $nl -"Arrays of C unions can be created by calling " { $link } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-UNION: } "." ; +"Arrays of C unions can be created with the " { $vocab-link "struct-arrays" } " vocabulary." ; diff --git a/basis/alien/structs/structs-tests.factor b/basis/alien/structs/structs-tests.factor index 231f1bd428..3f84377d5c 100755 --- a/basis/alien/structs/structs-tests.factor +++ b/basis/alien/structs/structs-tests.factor @@ -1,6 +1,6 @@ -IN: alien.structs.tests USING: alien alien.syntax alien.c-types kernel tools.test sequences system libc words vocabs namespaces layouts ; +IN: alien.structs.tests C-STRUCT: bar { "int" "x" } diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index b618e7974b..05558040e8 100755 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -6,30 +6,12 @@ alien.c-types alien.structs.fields cpu.architecture math.order quotations byte-arrays ; IN: alien.structs -TUPLE: struct-type -size -align -fields -{ boxer-quot callable } -{ unboxer-quot callable } -{ getter callable } -{ setter callable } -return-in-registers? ; +TUPLE: struct-type < abstract-c-type fields return-in-registers? ; M: struct-type c-type ; -M: struct-type heap-size size>> ; - -M: struct-type c-type-class drop byte-array ; - -M: struct-type c-type-align align>> ; - M: struct-type c-type-stack-align? drop f ; -M: struct-type c-type-boxer-quot boxer-quot>> ; - -M: struct-type c-type-unboxer-quot unboxer-quot>> ; - : if-value-struct ( ctype true false -- ) [ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline @@ -53,9 +35,10 @@ M: struct-type stack-size : c-struct? ( type -- ? ) (c-type) struct-type? ; -: (define-struct) ( name size align fields -- ) - [ [ align ] keep ] dip - struct-type new +: (define-struct) ( name size align fields class -- ) + [ [ align ] keep ] 2dip new + byte-array >>class + byte-array >>boxed-class swap >>fields swap >>align swap >>size @@ -71,14 +54,16 @@ M: struct-type stack-size [ 2drop ] [ make-fields ] 3bi [ struct-offsets ] keep [ [ type>> ] map compute-struct-align ] keep - [ (define-struct) ] keep - [ define-field ] each ; + [ struct-type (define-struct) ] keep + [ define-field ] each ; deprecated : define-union ( name members -- ) - [ expand-constants ] map [ [ heap-size ] [ max ] map-reduce ] keep - compute-struct-align f (define-struct) ; + compute-struct-align f struct-type (define-struct) ; deprecated : offset-of ( field struct -- offset ) c-types get at fields>> [ name>> = ] with find nip offset>> ; + +USE: vocabs.loader +"struct-arrays" require diff --git a/basis/alien/syntax/syntax-docs.factor b/basis/alien/syntax/syntax-docs.factor index a3215cd8c6..c9e03724f5 100644 --- a/basis/alien/syntax/syntax-docs.factor +++ b/basis/alien/syntax/syntax-docs.factor @@ -1,6 +1,6 @@ IN: alien.syntax USING: alien alien.c-types alien.parser alien.structs -help.markup help.syntax ; +classes.struct help.markup help.syntax ; HELP: DLL" { $syntax "DLL\" path\"" } @@ -55,12 +55,14 @@ HELP: TYPEDEF: { $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ; HELP: C-STRUCT: +{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: STRUCT: } " word." } { $syntax "C-STRUCT: name pairs... ;" } { $values { "name" "a new C type name" } { "pairs" "C type / field name string pairs" } } { $description "Defines a C struct layout and accessor words." } { $notes "C type names are documented in " { $link "c-types-specs" } "." } ; HELP: C-UNION: +{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: UNION-STRUCT: } " word." } { $syntax "C-UNION: name members... ;" } { $values { "name" "a new C type name" } { "members" "a sequence of C types" } } { $description "Defines a new C type sized to fit its largest member." } diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index d479e6d498..2b0270d5f5 100644 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -22,17 +22,19 @@ SYNTAX: TYPEDEF: scan scan typedef ; SYNTAX: C-STRUCT: - scan current-vocab parse-definition define-struct ; + scan current-vocab parse-definition define-struct ; deprecated SYNTAX: C-UNION: - scan parse-definition define-union ; + scan parse-definition define-union ; deprecated SYNTAX: C-ENUM: ";" parse-tokens [ [ create-in ] dip define-constant ] each-index ; +ERROR: no-such-symbol name library ; + : address-of ( name library -- value ) - load-library dlsym [ "No such symbol" throw ] unless* ; + 2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ; SYNTAX: &: scan "c-library" get '[ _ _ address-of ] over push-all ; diff --git a/basis/ascii/ascii-tests.factor b/basis/ascii/ascii-tests.factor index 6f39b32a01..8551ba53ef 100644 --- a/basis/ascii/ascii-tests.factor +++ b/basis/ascii/ascii-tests.factor @@ -10,7 +10,7 @@ IN: ascii.tests [ 4 ] [ 0 "There are Four Upper Case characters" - [ LETTER? [ 1+ ] when ] each + [ LETTER? [ 1 + ] when ] each ] unit-test [ t f ] [ CHAR: \s ascii? 400 ascii? ] unit-test diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor index 47147fa306..eb2c9193a3 100644 --- a/basis/base64/base64.factor +++ b/basis/base64/base64.factor @@ -34,7 +34,7 @@ SYMBOL: column : write1-lines ( ch -- ) write1 column get [ - 1+ [ 76 = [ crlf ] when ] + 1 + [ 76 = [ crlf ] when ] [ 76 mod column set ] bi ] when* ; @@ -48,7 +48,7 @@ SYMBOL: column : encode-pad ( seq n -- ) [ 3 0 pad-tail binary [ encode3 ] with-byte-writer ] - [ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline + [ 1 + ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline : decode4 ( seq -- ) [ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ] diff --git a/basis/biassocs/biassocs-tests.factor b/basis/biassocs/biassocs-tests.factor index f408cc82a8..af10eb18e4 100644 --- a/basis/biassocs/biassocs-tests.factor +++ b/basis/biassocs/biassocs-tests.factor @@ -1,5 +1,5 @@ +USING: biassocs assocs namespaces tools.test hashtables kernel ; IN: biassocs.tests -USING: biassocs assocs namespaces tools.test ; "h" set @@ -29,4 +29,14 @@ H{ { "a" "A" } { "b" "B" } } "a" set [ "A" ] [ "a" "b" get at ] unit-test -[ "a" ] [ "A" "b" get value-at ] unit-test \ No newline at end of file +[ "a" ] [ "A" "b" get value-at ] unit-test + +[ ] [ H{ { 1 2 } } >biassoc "h" set ] unit-test + +[ ] [ "h" get clone "g" set ] unit-test + +[ ] [ 3 4 "g" get set-at ] unit-test + +[ H{ { 1 2 } } ] [ "h" get >hashtable ] unit-test + +[ H{ { 1 2 } { 4 3 } } ] [ "g" get >hashtable ] unit-test diff --git a/basis/biassocs/biassocs.factor b/basis/biassocs/biassocs.factor index 5956589ba5..7daa478f54 100644 --- a/basis/biassocs/biassocs.factor +++ b/basis/biassocs/biassocs.factor @@ -43,4 +43,7 @@ M: biassoc new-assoc INSTANCE: biassoc assoc : >biassoc ( assoc -- biassoc ) - T{ biassoc } assoc-clone-like ; \ No newline at end of file + T{ biassoc } assoc-clone-like ; + +M: biassoc clone + [ from>> ] [ to>> ] bi [ clone ] bi@ biassoc boa ; diff --git a/basis/binary-search/binary-search-tests.factor b/basis/binary-search/binary-search-tests.factor index 63d2697418..f2ea7503f4 100644 --- a/basis/binary-search/binary-search-tests.factor +++ b/basis/binary-search/binary-search-tests.factor @@ -1,5 +1,5 @@ -IN: binary-search.tests USING: binary-search math.order vectors kernel tools.test ; +IN: binary-search.tests [ f ] [ 3 { } [ <=> ] with search drop ] unit-test [ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test @@ -9,7 +9,7 @@ USING: binary-search math.order vectors kernel tools.test ; [ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test [ 10 ] [ 10 20 >vector [ <=> ] with search drop ] unit-test -[ t ] [ "hello" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test -[ 3 ] [ "hey" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test -[ f ] [ "hello" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test -[ f ] [ "zebra" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test +[ t ] [ "hello" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test +[ 3 ] [ "hey" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test +[ f ] [ "hello" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test +[ f ] [ "zebra" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index be8c434e36..0f87cf4cb6 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -27,46 +27,63 @@ TUPLE: bit-array [ [ length bits>cells ] keep ] dip swap underlying>> '[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each ; inline +: clean-up ( bit-array -- ) + ! Zero bits after the end. + dup underlying>> empty? [ drop ] [ + [ + [ underlying>> length 8 * ] [ length ] bi - + 8 swap - -1 swap shift bitnot + ] + [ underlying>> last bitand ] + [ underlying>> set-last ] + tri + ] if ; inline + PRIVATE> : ( n -- bit-array ) dup bits>bytes bit-array boa ; inline -M: bit-array length length>> ; +M: bit-array length length>> ; inline M: bit-array nth-unsafe - [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; + [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; inline M: bit-array set-nth-unsafe [ >fixnum ] [ underlying>> ] bi* [ byte/bit set-bit ] 2keep - swap n>byte set-alien-unsigned-1 ; + swap n>byte set-alien-unsigned-1 ; inline -: clear-bits ( bit-array -- ) 0 (set-bits) ; +GENERIC: clear-bits ( bit-array -- ) -: set-bits ( bit-array -- ) -1 (set-bits) ; +M: bit-array clear-bits 0 (set-bits) ; inline + +GENERIC: set-bits ( bit-array -- ) + +M: bit-array set-bits -1 (set-bits) ; inline M: bit-array clone - [ length>> ] [ underlying>> clone ] bi bit-array boa ; + [ length>> ] [ underlying>> clone ] bi bit-array boa ; inline : >bit-array ( seq -- bit-array ) T{ bit-array f 0 B{ } } clone-like ; inline -M: bit-array like drop dup bit-array? [ >bit-array ] unless ; +M: bit-array like drop dup bit-array? [ >bit-array ] unless ; inline -M: bit-array new-sequence drop ; +M: bit-array new-sequence drop ; inline M: bit-array equal? - over bit-array? [ sequence= ] [ 2drop f ] if ; + over bit-array? [ [ underlying>> ] bi@ sequence= ] [ 2drop f ] if ; M: bit-array resize [ drop ] [ [ bits>bytes ] [ underlying>> ] bi* resize-byte-array ] 2bi - bit-array boa ; + bit-array boa + dup clean-up ; inline -M: bit-array byte-length length 7 + -3 shift ; +M: bit-array byte-length length 7 + -3 shift ; inline SYNTAX: ?{ \ } [ >bit-array ] parse-literal ; @@ -74,10 +91,10 @@ SYNTAX: ?{ \ } [ >bit-array ] parse-literal ; dup 0 = [ ] [ - [ log2 1+ 0 ] keep + [ log2 1 + 0 ] keep [ dup 0 = ] [ [ pick underlying>> pick set-alien-unsigned-1 ] keep - [ 1+ ] [ -8 shift ] bi* + [ 1 + ] [ -8 shift ] bi* ] until 2drop ] if ; diff --git a/unmaintained/multi-methods/authors.txt b/basis/bit-sets/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from unmaintained/multi-methods/authors.txt rename to basis/bit-sets/authors.txt diff --git a/basis/bit-sets/bit-sets-tests.factor b/basis/bit-sets/bit-sets-tests.factor new file mode 100644 index 0000000000..6a1366a1ea --- /dev/null +++ b/basis/bit-sets/bit-sets-tests.factor @@ -0,0 +1,17 @@ +USING: bit-sets tools.test bit-arrays ; +IN: bit-sets.tests + +[ ?{ t f t f t f } ] [ + ?{ t f f f t f } + ?{ f f t f t f } bit-set-union +] unit-test + +[ ?{ f f f f t f } ] [ + ?{ t f f f t f } + ?{ f f t f t f } bit-set-intersect +] unit-test + +[ ?{ t f t f f f } ] [ + ?{ t t t f f f } + ?{ f t f f t t } bit-set-diff +] unit-test diff --git a/basis/bit-sets/bit-sets.factor b/basis/bit-sets/bit-sets.factor new file mode 100644 index 0000000000..34b7f13dc2 --- /dev/null +++ b/basis/bit-sets/bit-sets.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors sequences byte-arrays bit-arrays math hints ; +IN: bit-sets + +> ] + [ + [ + [ [ length ] bi@ assert= ] + [ [ underlying>> ] bi@ ] 2bi + ] dip 2map + ] 3bi bit-array boa ; inline + +PRIVATE> + +: bit-set-union ( seq1 seq2 -- seq ) [ bitor ] bit-set-map ; + +HINTS: bit-set-union bit-array bit-array ; + +: bit-set-intersect ( seq1 seq2 -- seq ) [ bitand ] bit-set-map ; + +HINTS: bit-set-intersect bit-array bit-array ; + +: bit-set-diff ( seq1 seq2 -- seq ) [ bitnot bitand ] bit-set-map ; + +HINTS: bit-set-diff bit-array bit-array ; + +: bit-set-subset? ( seq1 seq2 -- ? ) dupd bit-set-intersect = ; \ No newline at end of file diff --git a/basis/bit-sets/summary.txt b/basis/bit-sets/summary.txt new file mode 100644 index 0000000000..d27503b202 --- /dev/null +++ b/basis/bit-sets/summary.txt @@ -0,0 +1 @@ +Efficient bitwise operations on bit arrays diff --git a/basis/bit-vectors/bit-vectors-docs.factor b/basis/bit-vectors/bit-vectors-docs.factor index f0e4e47586..66d3d603fe 100644 --- a/basis/bit-vectors/bit-vectors-docs.factor +++ b/basis/bit-vectors/bit-vectors-docs.factor @@ -22,11 +22,11 @@ HELP: bit-vector { $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ; HELP: -{ $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } } +{ $values { "capacity" "a positive integer specifying initial capacity" } { "vector" bit-vector } } { $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ; HELP: >bit-vector -{ $values { "seq" "a sequence" } { "bit-vector" bit-vector } } +{ $values { "seq" "a sequence" } { "vector" bit-vector } } { $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ; HELP: ?V{ diff --git a/basis/bit-vectors/bit-vectors-tests.factor b/basis/bit-vectors/bit-vectors-tests.factor index 41efdbd0d2..5af44b59f7 100644 --- a/basis/bit-vectors/bit-vectors-tests.factor +++ b/basis/bit-vectors/bit-vectors-tests.factor @@ -1,5 +1,5 @@ -IN: bit-vectors.tests USING: tools.test bit-vectors vectors sequences kernel math ; +IN: bit-vectors.tests [ 0 ] [ 123 length ] unit-test diff --git a/basis/bit-vectors/bit-vectors.factor b/basis/bit-vectors/bit-vectors.factor index a238f61244..7febe6fc1b 100644 --- a/basis/bit-vectors/bit-vectors.factor +++ b/basis/bit-vectors/bit-vectors.factor @@ -1,38 +1,15 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private math sequences sequences.private growable bit-arrays prettyprint.custom -parser accessors ; +parser accessors vectors.functor classes.parser ; IN: bit-vectors -TUPLE: bit-vector -{ underlying bit-array initial: ?{ } } -{ length array-capacity } ; - -: ( n -- bit-vector ) - 0 bit-vector boa ; inline - -: >bit-vector ( seq -- bit-vector ) - T{ bit-vector f ?{ } 0 } clone-like ; - -M: bit-vector like - drop dup bit-vector? [ - dup bit-array? - [ dup length bit-vector boa ] [ >bit-vector ] if - ] unless ; - -M: bit-vector new-sequence - drop [ ] [ >fixnum ] bi bit-vector boa ; - -M: bit-vector equal? - over bit-vector? [ sequence= ] [ 2drop f ] if ; - -M: bit-array new-resizable drop ; - -INSTANCE: bit-vector growable +<< "bit-vector" create-class-in \ bit-array \ define-vector >> SYNTAX: ?V{ \ } [ >bit-vector ] parse-literal ; +M: bit-vector contract 2drop ; M: bit-vector >pprint-sequence ; M: bit-vector pprint-delims drop \ ?V{ \ } ; M: bit-vector pprint* pprint-object ; diff --git a/basis/bitstreams/bitstreams-tests.factor b/basis/bitstreams/bitstreams-tests.factor index a5b1b43acd..794faa6055 100644 --- a/basis/bitstreams/bitstreams-tests.factor +++ b/basis/bitstreams/bitstreams-tests.factor @@ -5,7 +5,6 @@ grouping compression.lzw multiline byte-arrays io.encodings.binary io.streams.byte-array ; IN: bitstreams.tests - [ BIN: 1111111111 ] [ B{ HEX: 0f HEX: ff HEX: ff HEX: ff } diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index 4718f137e4..0eef54dc66 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.accessors assocs byte-arrays combinators -constructors destructors fry io io.binary io.encodings.binary -io.streams.byte-array kernel locals macros math math.ranges -multiline sequences sequences.private vectors byte-vectors -combinators.short-circuit math.bitwise ; +destructors fry io io.binary io.encodings.binary io.streams.byte-array +kernel locals macros math math.ranges multiline sequences +sequences.private vectors byte-vectors combinators.short-circuit +math.bitwise ; IN: bitstreams TUPLE: widthed { bits integer read-only } { #bits integer read-only } ; @@ -36,8 +36,12 @@ TUPLE: bit-writer TUPLE: msb0-bit-reader < bit-reader ; TUPLE: lsb0-bit-reader < bit-reader ; -CONSTRUCTOR: msb0-bit-reader ( bytes -- bs ) ; -CONSTRUCTOR: lsb0-bit-reader ( bytes -- bs ) ; + +: ( bytes -- bs ) + msb0-bit-reader new swap >>bytes ; inline + +: ( bytes -- bs ) + lsb0-bit-reader new swap >>bytes ; inline TUPLE: msb0-bit-writer < bit-writer ; TUPLE: lsb0-bit-writer < bit-writer ; @@ -56,13 +60,20 @@ TUPLE: lsb0-bit-writer < bit-writer ; GENERIC: peek ( n bitstream -- value ) GENERIC: poke ( value n bitstream -- ) +: get-abp ( bitstream -- abp ) + [ byte-pos>> 8 * ] [ bit-pos>> + ] bi ; inline + +: set-abp ( abp bitstream -- ) + [ 8 /mod ] dip [ (>>bit-pos) ] [ (>>byte-pos) ] bi ; inline + : seek ( n bitstream -- ) - { - [ byte-pos>> 8 * ] - [ bit-pos>> + + 8 /mod ] - [ (>>bit-pos) ] - [ (>>byte-pos) ] - } cleave ; inline + [ get-abp + ] [ set-abp ] bi ; inline + +: (align) ( n m -- n' ) + [ /mod 0 > [ 1 + ] when ] [ * ] bi ; inline + +: align ( n bitstream -- ) + [ get-abp swap (align) ] [ set-abp ] bi ; inline : read ( n bitstream -- value ) [ peek ] [ seek ] 2bi ; inline diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index 0505dcb184..e9187cc3b1 100755 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -6,11 +6,14 @@ classes.private arrays hashtables vectors classes.tuple sbufs hashtables.private sequences.private math classes.tuple.private growable namespaces.private assocs words command-line vocabs io io.encodings.string libc splitting math.parser memory compiler.units -math.order compiler.tree.builder compiler.tree.optimizer -compiler.cfg.optimizer ; -FROM: compiler => enable-optimizer compile-word ; +math.order quotations quotations.private assocs.private ; +FROM: compiler => enable-optimizer ; IN: bootstrap.compiler +"profile-compiler" get [ + "bootstrap.compiler.timing" require +] when + ! Don't bring this in when deploying, since it will store a ! reference to 'eval' in a global variable "deploy-vocab" get "staging" get or [ @@ -32,90 +35,87 @@ gc : compile-unoptimized ( words -- ) [ optimized? not ] filter compile ; -nl -"Compiling..." write flush +"debug-compiler" get [ + + nl + "Compiling..." write flush -! Compile a set of words ahead of the full compile. -! This set of words was determined semi-empirically -! using the profiler. It improves bootstrap time -! significantly, because frequenly called words -! which are also quick to compile are replaced by -! compiled definitions as soon as possible. -{ - not + ! Compile a set of words ahead of the full compile. + ! This set of words was determined semi-empirically + ! using the profiler. It improves bootstrap time + ! significantly, because frequenly called words + ! which are also quick to compile are replaced by + ! compiled definitions as soon as possible. + { + not ? - array? hashtable? vector? - tuple? sbuf? tombstone? + 2over roll -roll - array-nth set-array-nth + array? hashtable? vector? + tuple? sbuf? tombstone? + curry? compose? callable? + quotation? - wrap probe + curry compose uncurry - namestack* -} compile-unoptimized + array-nth set-array-nth length>> -"." write flush + wrap probe -{ - bitand bitor bitxor bitnot -} compile-unoptimized + namestack* -"." write flush + layout-of + } compile-unoptimized -{ - + 1+ 1- 2/ < <= > >= shift -} compile-unoptimized + "." write flush -"." write flush + { + bitand bitor bitxor bitnot + } compile-unoptimized -{ - new-sequence nth push pop last flip -} compile-unoptimized + "." write flush -"." write flush + { + + 2/ < <= > >= shift + } compile-unoptimized -{ - hashcode* = get set -} compile-unoptimized + "." write flush -"." write flush + { + new-sequence nth push pop last flip + } compile-unoptimized -{ - memq? split harvest sift cut cut-slice start index clone - set-at reverse push-all class number>string string>number -} compile-unoptimized + "." write flush -"." write flush + { + hashcode* = equal? assoc-stack (assoc-stack) get set + } compile-unoptimized -{ - lines prefix suffix unclip new-assoc update - word-prop set-word-prop 1array 2array 3array ?nth -} compile-unoptimized + "." write flush -"." write flush + { + memq? split harvest sift cut cut-slice start index clone + set-at reverse push-all class number>string string>number + like clone-like + } compile-unoptimized -{ - malloc calloc free memcpy -} compile-unoptimized + "." write flush -"." write flush + { + lines prefix suffix unclip new-assoc update + word-prop set-word-prop 1array 2array 3array ?nth + } compile-unoptimized -{ build-tree } compile-unoptimized + "." write flush -"." write flush + { + malloc calloc free memcpy + } compile-unoptimized -{ optimize-tree } compile-unoptimized + "." write flush -"." write flush + vocabs [ words compile-unoptimized "." write flush ] each -{ optimize-cfg } compile-unoptimized + " done" print flush -"." write flush - -{ compile-word } compile-unoptimized - -"." write flush - -vocabs [ words compile-unoptimized "." write flush ] each - -" done" print flush +] unless \ No newline at end of file diff --git a/basis/bootstrap/compiler/timing/timing.factor b/basis/bootstrap/compiler/timing/timing.factor new file mode 100644 index 0000000000..04c75c549d --- /dev/null +++ b/basis/bootstrap/compiler/timing/timing.factor @@ -0,0 +1,42 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel make sequences tools.annotations tools.crossref ; +QUALIFIED: compiler.cfg.builder +QUALIFIED: compiler.cfg.linear-scan +QUALIFIED: compiler.cfg.mr +QUALIFIED: compiler.cfg.optimizer +QUALIFIED: compiler.cfg.stacks.finalize +QUALIFIED: compiler.cfg.stacks.global +QUALIFIED: compiler.codegen +QUALIFIED: compiler.tree.builder +QUALIFIED: compiler.tree.optimizer +IN: bootstrap.compiler.timing + +: passes ( word -- seq ) + def>> uses [ vocabulary>> "compiler." head? ] filter ; + +: high-level-passes ( -- seq ) \ compiler.tree.optimizer:optimize-tree passes ; + +: low-level-passes ( -- seq ) \ compiler.cfg.optimizer:optimize-cfg passes ; + +: machine-passes ( -- seq ) \ compiler.cfg.mr:build-mr passes ; + +: linear-scan-passes ( -- seq ) \ compiler.cfg.linear-scan:(linear-scan) passes ; + +: all-passes ( -- seq ) + [ + \ compiler.tree.builder:build-tree , + \ compiler.tree.optimizer:optimize-tree , + high-level-passes % + \ compiler.cfg.builder:build-cfg , + \ compiler.cfg.stacks.global:compute-global-sets , + \ compiler.cfg.stacks.finalize:finalize-stack-shuffling , + \ compiler.cfg.optimizer:optimize-cfg , + low-level-passes % + \ compiler.cfg.mr:build-mr , + machine-passes % + linear-scan-passes % + \ compiler.codegen:generate , + ] { } make ; + +all-passes [ [ reset ] [ add-timing ] bi ] each \ No newline at end of file diff --git a/basis/bootstrap/image/image-tests.factor b/basis/bootstrap/image/image-tests.factor index e7070d3cf2..c5c6460041 100644 --- a/basis/bootstrap/image/image-tests.factor +++ b/basis/bootstrap/image/image-tests.factor @@ -1,6 +1,6 @@ -IN: bootstrap.image.tests USING: bootstrap.image bootstrap.image.private tools.test kernel math ; +IN: bootstrap.image.tests [ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index d76588e4e4..ee081a14ca 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -38,11 +38,11 @@ IN: bootstrap.image ! Object cache; we only consider numbers equal if they have the ! same type -TUPLE: id obj ; +TUPLE: eql-wrapper obj ; -C: id +C: eql-wrapper -M: id hashcode* obj>> hashcode* ; +M: eql-wrapper hashcode* obj>> hashcode* ; GENERIC: (eql?) ( obj1 obj2 -- ? ) @@ -62,19 +62,27 @@ M: sequence (eql?) M: object (eql?) = ; -M: id equal? - over id? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ; +M: eql-wrapper equal? + over eql-wrapper? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ; + +TUPLE: eq-wrapper obj ; + +C: eq-wrapper + +M: eq-wrapper equal? + over eq-wrapper? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ; SYMBOL: objects -: (objects) ( obj -- id assoc ) objects get ; inline +: cache-eql-object ( obj quot -- value ) + [ objects get ] dip '[ obj>> @ ] cache ; inline -: lookup-object ( obj -- n/f ) (objects) at ; +: cache-eq-object ( obj quot -- value ) + [ objects get ] dip '[ obj>> @ ] cache ; inline -: put-object ( n obj -- ) (objects) set-at ; +: lookup-object ( obj -- n/f ) objects get at ; -: cache-object ( obj quot -- value ) - [ (objects) ] dip '[ obj>> @ ] cache ; inline +: put-object ( n obj -- ) objects get set-at ; ! Constants @@ -234,7 +242,7 @@ GENERIC: ' ( obj -- ptr ) : bignum-bits ( -- n ) bootstrap-cell-bits 2 - ; -: bignum-radix ( -- n ) bignum-bits 2^ 1- ; +: bignum-radix ( -- n ) bignum-bits 2^ 1 - ; : bignum>seq ( n -- seq ) #! n is positive or zero. @@ -244,7 +252,7 @@ GENERIC: ' ( obj -- ptr ) : emit-bignum ( n -- ) dup dup 0 < [ neg ] when bignum>seq - [ nip length 1+ emit-fixnum ] + [ nip length 1 + emit-fixnum ] [ drop 0 < 1 0 ? emit ] [ nip emit-seq ] 2tri ; @@ -252,7 +260,7 @@ GENERIC: ' ( obj -- ptr ) M: bignum ' [ bignum [ emit-bignum ] emit-object - ] cache-object ; + ] cache-eql-object ; ! Fixnums @@ -277,7 +285,7 @@ M: float ' float [ align-here double>bits emit-64 ] emit-object - ] cache-object ; + ] cache-eql-object ; ! Special objects @@ -340,7 +348,7 @@ M: word ' ; ! Wrappers M: wrapper ' - wrapped>> ' wrapper [ emit ] emit-object ; + [ wrapped>> ' wrapper [ emit ] emit-object ] cache-eql-object ; ! Strings : native> ( object -- object ) @@ -379,7 +387,7 @@ M: wrapper ' M: string ' #! We pool strings so that each string is only written once #! to the image - [ emit-string ] cache-object ; + [ emit-string ] cache-eql-object ; : assert-empty ( seq -- ) length 0 assert= ; @@ -390,10 +398,12 @@ M: string ' ] bi* ; M: byte-array ' - byte-array [ - dup length emit-fixnum - pad-bytes emit-bytes - ] emit-object ; + [ + byte-array [ + dup length emit-fixnum + pad-bytes emit-bytes + ] emit-object + ] cache-eq-object ; ! Tuples ERROR: tuple-removed class ; @@ -408,20 +418,22 @@ ERROR: tuple-removed class ; : emit-tuple ( tuple -- pointer ) dup class name>> "tombstone" = - [ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ; + [ [ (emit-tuple) ] cache-eql-object ] + [ [ (emit-tuple) ] cache-eq-object ] + if ; M: tuple ' emit-tuple ; M: tombstone ' state>> "((tombstone))" "((empty))" ? "hashtables.private" lookup def>> first - [ emit-tuple ] cache-object ; + [ emit-tuple ] cache-eql-object ; ! Arrays : emit-array ( array -- offset ) [ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ; -M: array ' emit-array ; +M: array ' [ emit-array ] cache-eq-object ; ! This is a hack. We need to detect arrays which are tuple ! layout arrays so that they can be internalized, but making @@ -438,7 +450,7 @@ M: tuple-layout-array ' [ [ dup integer? [ ] when ] map emit-array - ] cache-object ; + ] cache-eql-object ; ! Quotations @@ -452,7 +464,7 @@ M: quotation ' 0 emit ! xt 0 emit ! code ] emit-object - ] cache-object ; + ] cache-eql-object ; ! End of the image diff --git a/basis/bootstrap/image/upload/upload.factor b/basis/bootstrap/image/upload/upload.factor index d70a253e5f..7f25ce9c01 100644 --- a/basis/bootstrap/image/upload/upload.factor +++ b/basis/bootstrap/image/upload/upload.factor @@ -9,9 +9,9 @@ IN: bootstrap.image.upload SYMBOL: upload-images-destination : destination ( -- dest ) - upload-images-destination get - "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/" - or ; + upload-images-destination get + "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/" + or ; : checksums ( -- temp ) "checksums.txt" temp-file ; diff --git a/basis/bootstrap/math/math.factor b/basis/bootstrap/math/math.factor index 27b2f6b181..3bab31daeb 100644 --- a/basis/bootstrap/math/math.factor +++ b/basis/bootstrap/math/math.factor @@ -2,4 +2,4 @@ USING: vocabs vocabs.loader kernel ; "math.ratios" require "math.floats" require -"math.complex" require \ No newline at end of file +"math.complex" require diff --git a/basis/bootstrap/tools/tools.factor b/basis/bootstrap/tools/tools.factor index 6017469925..6bdfd6241c 100644 --- a/basis/bootstrap/tools/tools.factor +++ b/basis/bootstrap/tools/tools.factor @@ -8,12 +8,14 @@ IN: bootstrap.tools "tools.crossref" "tools.errors" "tools.deploy" + "tools.destructors" "tools.disassembler" "tools.memory" "tools.profiler" "tools.test" "tools.time" "tools.threads" + "tools.deprecation" "vocabs.hierarchy" "vocabs.refresh" "vocabs.refresh.monitor" diff --git a/basis/boxes/boxes-tests.factor b/basis/boxes/boxes-tests.factor index 71fc1c9a7b..3bcb735217 100644 --- a/basis/boxes/boxes-tests.factor +++ b/basis/boxes/boxes-tests.factor @@ -1,5 +1,5 @@ -IN: boxes.tests USING: boxes namespaces tools.test accessors ; +IN: boxes.tests [ ] [ "b" set ] unit-test diff --git a/basis/byte-arrays/hex/authors.txt b/basis/byte-arrays/hex/authors.txt new file mode 100644 index 0000000000..8f20b8c31e --- /dev/null +++ b/basis/byte-arrays/hex/authors.txt @@ -0,0 +1,2 @@ +Maxim Savchenko +Slava Pestov diff --git a/basis/byte-arrays/hex/hex-docs.factor b/basis/byte-arrays/hex/hex-docs.factor new file mode 100644 index 0000000000..8a2b842fc9 --- /dev/null +++ b/basis/byte-arrays/hex/hex-docs.factor @@ -0,0 +1,8 @@ +! Copyright (C) 2009 Maxim Savchenko, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: byte-arrays.hex +USING: byte-arrays help.markup help.syntax ; + +HELP: HEX{ +{ $syntax "HEX{ 0123 45 67 89abcdef }" } +{ $description "Constructs a " { $link byte-array } " from data specified in hexadecimal format. Whitespace between the curly braces is ignored." } ; diff --git a/basis/byte-arrays/hex/hex.factor b/basis/byte-arrays/hex/hex.factor new file mode 100644 index 0000000000..5c381b7db0 --- /dev/null +++ b/basis/byte-arrays/hex/hex.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2009 Maxim Savchenko, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: grouping lexer ascii parser sequences kernel math.parser ; +IN: byte-arrays.hex + +SYNTAX: HEX{ + "}" parse-tokens "" join + [ blank? not ] filter + 2 group [ hex> ] B{ } map-as + parsed ; diff --git a/basis/cache/cache-tests.factor b/basis/cache/cache-tests.factor deleted file mode 100644 index cbf4f64e22..0000000000 --- a/basis/cache/cache-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test cache ; -IN: cache.tests diff --git a/basis/cache/cache.factor b/basis/cache/cache.factor index f16461bf45..a226500c63 100644 --- a/basis/cache/cache.factor +++ b/basis/cache/cache.factor @@ -3,10 +3,10 @@ USING: kernel assocs math accessors destructors fry sequences ; IN: cache -TUPLE: cache-assoc assoc max-age disposed ; +TUPLE: cache-assoc < disposable assoc max-age ; : ( -- cache ) - H{ } clone 10 f cache-assoc boa ; + cache-assoc new-disposable H{ } clone >>assoc 10 >>max-age ; : purge-cache ( cache -- ) dup max-age>> '[ - [ nip [ 1+ ] change-age age>> _ >= ] assoc-partition + [ nip [ 1 + ] change-age age>> _ >= ] assoc-partition [ values dispose-each ] dip - ] change-assoc drop ; \ No newline at end of file + ] change-assoc drop ; diff --git a/basis/cairo/cairo-tests.factor b/basis/cairo/cairo-tests.factor index bf7c468774..cb19259984 100644 --- a/basis/cairo/cairo-tests.factor +++ b/basis/cairo/cairo-tests.factor @@ -1,8 +1,8 @@ -IN: cairo.tests USING: cairo tools.test math.rectangles accessors ; +IN: cairo.tests [ { 10 20 } ] [ { 10 20 } [ { 0 1 } { 3 4 } fill-rect ] make-bitmap-image dim>> -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/cairo/cairo.factor b/basis/cairo/cairo.factor index 3a41f0bcf9..074798a1b2 100755 --- a/basis/cairo/cairo.factor +++ b/basis/cairo/cairo.factor @@ -31,7 +31,8 @@ ERROR: cairo-error message ; &cairo_destroy @ ] make-memory-bitmap - BGRA >>component-order ; inline + BGRA >>component-order + ubyte-components >>component-type ; inline : dummy-cairo ( -- cr ) #! Sometimes we want a dummy context; eg with Pango, we want diff --git a/basis/cairo/ffi/ffi.factor b/basis/cairo/ffi/ffi.factor index 2930843ad7..ce5f0cc233 100644 --- a/basis/cairo/ffi/ffi.factor +++ b/basis/cairo/ffi/ffi.factor @@ -896,7 +896,7 @@ FUNCTION: cairo_status_t cairo_pattern_get_rgba ( cairo_pattern_t* pattern, double* red, double* green, double* blue, double* alpha ) ; FUNCTION: cairo_status_t -cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t* *surface ) ; +cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t** surface ) ; FUNCTION: cairo_status_t cairo_pattern_get_color_stop_rgba ( cairo_pattern_t* pattern, int index, double* offset, double* red, double* green, double* blue, double* alpha ) ; diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index 3aae10f6a7..71e052bb6c 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -20,14 +20,14 @@ HELP: { $values { "year" integer } { "month" integer } { "day" integer } { "timestamp" timestamp } } { $description "Returns a timestamp object representing the start of the specified day in your current timezone." } { $examples - { $example "USING: calendar prettyprint ;" - "2010 12 25 >gmt midnight ." + { $example "USING: accessors calendar prettyprint ;" + "2010 12 25 instant >>gmt-offset ." "T{ timestamp { year 2010 } { month 12 } { day 25 } }" } } ; HELP: month-names -{ $values { "array" array } } +{ $values { "value" object } } { $description "Returns an array with the English names of all the months." } { $warning "Do not use this array for looking up a month name directly. Use month-name instead." } ; diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 4b58b1b496..a8bb60cbf3 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -34,25 +34,25 @@ C: timestamp : ( year month day -- timestamp ) 0 0 0 gmt-offset-duration ; -ERROR: not-a-month n ; +ERROR: not-a-month ; M: not-a-month summary drop "Months are indexed starting at 1" ; -: month-names ( -- array ) +CONSTANT: month-names { "January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December" - } ; + } : month-name ( n -- string ) - check-month 1- month-names nth ; + check-month 1 - month-names nth ; CONSTANT: month-abbreviations { @@ -61,7 +61,7 @@ CONSTANT: month-abbreviations } : month-abbreviation ( n -- string ) - check-month 1- month-abbreviations nth ; + check-month 1 - month-abbreviations nth ; CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } @@ -113,7 +113,7 @@ CONSTANT: day-abbreviations3 100 b * d + 4800 - m 10 /i + m 3 + 12 m 10 /i * - - e 153 m * 2 + 5 /i - 1+ ; + e 153 m * 2 + 5 /i - 1 + ; GENERIC: easter ( obj -- obj' ) @@ -186,9 +186,6 @@ GENERIC: +second ( timestamp x -- timestamp ) { [ day>> 29 = ] [ month>> 2 = ] [ leap-year? not ] } 1&& [ 3 >>month 1 >>day ] when ; -: unless-zero ( n quot -- ) - [ dup zero? [ drop ] ] dip if ; inline - M: integer +year ( timestamp n -- timestamp ) [ [ + ] curry change-year adjust-leap-year ] unless-zero ; @@ -196,7 +193,7 @@ M: real +year ( timestamp n -- timestamp ) [ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ; : months/years ( n -- months years ) - 12 /rem dup zero? [ drop 1- 12 ] when swap ; inline + 12 /rem [ 1 - 12 ] when-zero swap ; inline M: integer +month ( timestamp n -- timestamp ) [ over month>> + months/years [ >>month ] dip +year ] unless-zero ; @@ -371,10 +368,10 @@ M: duration time- #! http://web.textfiles.com/computers/formulas.txt #! good for any date since October 15, 1582 [ - dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when + dup 2 <= [ [ 1 - ] [ 12 + ] bi* ] when [ dup [ 4 /i + ] [ 100 /i - ] [ 400 /i + ] tri ] dip - [ 1+ 3 * 5 /i + ] keep 2 * + - ] dip 1+ + 7 mod ; + [ 1 + 3 * 5 /i + ] keep 2 * + + ] dip 1 + + 7 mod ; GENERIC: days-in-year ( obj -- n ) @@ -395,7 +392,7 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ; year leap-year? [ year month day year 3 1 - after=? [ 1+ ] when + after=? [ 1 + ] when ] when ; : day-of-year ( timestamp -- n ) diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index ad43cc2f1d..6aa4126ff9 100644 --- a/basis/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -68,8 +68,8 @@ M: array month. ( pair -- ) [ (days-in-month) day-abbreviations2 " " join print ] 2tri over " " concat write [ - [ 1+ day. ] keep - 1+ + 7 mod zero? [ nl ] [ bl ] if + [ 1 + day. ] keep + 1 + + 7 mod zero? [ nl ] [ bl ] if ] with each nl ; M: timestamp month. ( timestamp -- ) @@ -78,7 +78,7 @@ M: timestamp month. ( timestamp -- ) GENERIC: year. ( obj -- ) M: integer year. ( n -- ) - 12 [ 1+ 2array month. nl ] with each ; + 12 [ 1 + 2array month. nl ] with each ; M: timestamp year. ( timestamp -- ) year>> year. ; @@ -162,7 +162,7 @@ M: timestamp year. ( timestamp -- ) : read-rfc3339-seconds ( s -- s' ch ) "+-Z" read-until [ - [ string>number ] [ length 10 swap ^ ] bi / + + [ string>number ] [ length 10^ ] bi / + ] dip ; : (rfc3339>timestamp) ( -- timestamp ) @@ -201,7 +201,7 @@ ERROR: invalid-timestamp-format ; "," read-token day-abbreviations3 member? check-timestamp drop read1 CHAR: \s assert= read-sp checked-number >>day - read-sp month-abbreviations index 1+ check-timestamp >>month + read-sp month-abbreviations index 1 + check-timestamp >>month read-sp checked-number >>year ":" read-token checked-number >>hour ":" read-token checked-number >>minute @@ -220,7 +220,7 @@ ERROR: invalid-timestamp-format ; "," read-token check-day-name read1 CHAR: \s assert= "-" read-token checked-number >>day - "-" read-token month-abbreviations index 1+ check-timestamp >>month + "-" read-token month-abbreviations index 1 + check-timestamp >>month read-sp checked-number >>year ":" read-token checked-number >>hour ":" read-token checked-number >>minute @@ -233,7 +233,7 @@ ERROR: invalid-timestamp-format ; : (cookie-string>timestamp-2) ( -- timestamp ) timestamp new read-sp check-day-name - read-sp month-abbreviations index 1+ check-timestamp >>month + read-sp month-abbreviations index 1 + check-timestamp >>month read-sp checked-number >>day ":" read-token checked-number >>hour ":" read-token checked-number >>minute diff --git a/basis/calendar/unix/unix.factor b/basis/calendar/unix/unix.factor index 9848d0c164..28e54b89fb 100644 --- a/basis/calendar/unix/unix.factor +++ b/basis/calendar/unix/unix.factor @@ -1,28 +1,27 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax arrays calendar -kernel math unix unix.time namespaces system ; +kernel math unix unix.time unix.types namespaces system +accessors classes.struct ; IN: calendar.unix : timeval>seconds ( timeval -- seconds ) - [ timeval-sec seconds ] [ timeval-usec microseconds ] bi - time+ ; + [ sec>> seconds ] [ usec>> microseconds ] bi time+ ; : timeval>unix-time ( timeval -- timestamp ) timeval>seconds since-1970 ; : timespec>seconds ( timespec -- seconds ) - [ timespec-sec seconds ] [ timespec-nsec nanoseconds ] bi - time+ ; + [ sec>> seconds ] [ nsec>> nanoseconds ] bi time+ ; : timespec>unix-time ( timespec -- timestamp ) timespec>seconds since-1970 ; : get-time ( -- alien ) - f time localtime ; + f time localtime tm memory>struct ; : timezone-name ( -- string ) - get-time tm-zone ; + get-time zone>> ; M: unix gmt-offset ( -- hours minutes seconds ) - get-time tm-gmtoff 3600 /mod 60 /mod ; + get-time gmtoff>> 3600 /mod 60 /mod ; diff --git a/basis/calendar/windows/windows.factor b/basis/calendar/windows/windows.factor index caab530a23..265a58507c 100644 --- a/basis/calendar/windows/windows.factor +++ b/basis/calendar/windows/windows.factor @@ -1,15 +1,13 @@ USING: calendar namespaces alien.c-types system -windows.kernel32 kernel math combinators windows.errors ; +windows.kernel32 kernel math combinators windows.errors +accessors classes.struct ; IN: calendar.windows M: windows gmt-offset ( -- hours minutes seconds ) - "TIME_ZONE_INFORMATION" + TIME_ZONE_INFORMATION dup GetTimeZoneInformation { { TIME_ZONE_ID_INVALID [ win32-error-string throw ] } - { TIME_ZONE_ID_UNKNOWN [ TIME_ZONE_INFORMATION-Bias ] } - { TIME_ZONE_ID_STANDARD [ TIME_ZONE_INFORMATION-Bias ] } - { TIME_ZONE_ID_DAYLIGHT [ - [ TIME_ZONE_INFORMATION-Bias ] - [ TIME_ZONE_INFORMATION-DaylightBias ] bi + - ] } + { TIME_ZONE_ID_UNKNOWN [ Bias>> ] } + { TIME_ZONE_ID_STANDARD [ Bias>> ] } + { TIME_ZONE_ID_DAYLIGHT [ [ Bias>> ] [ DaylightBias>> ] bi + ] } } case neg 60 /mod 0 ; diff --git a/basis/channels/examples/examples.factor b/basis/channels/examples/examples.factor index 1e51fb06d8..99fa41cd40 100644 --- a/basis/channels/examples/examples.factor +++ b/basis/channels/examples/examples.factor @@ -7,7 +7,7 @@ locals sequences ; IN: channels.examples : (counter) ( channel n -- ) - [ swap to ] 2keep 1+ (counter) ; + [ swap to ] 2keep 1 + (counter) ; : counter ( channel -- ) 2 (counter) ; diff --git a/basis/checksums/fnv1/authors.txt b/basis/checksums/fnv1/authors.txt new file mode 100644 index 0000000000..c64bb4e735 --- /dev/null +++ b/basis/checksums/fnv1/authors.txt @@ -0,0 +1 @@ +Alaric Snell-Pym \ No newline at end of file diff --git a/basis/checksums/fnv1/fnv1-docs.factor b/basis/checksums/fnv1/fnv1-docs.factor new file mode 100644 index 0000000000..4fbecd2b75 --- /dev/null +++ b/basis/checksums/fnv1/fnv1-docs.factor @@ -0,0 +1,67 @@ +USING: help.markup help.syntax ; +IN: checksums.fnv1 + +HELP: fnv1-32 +{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 32-bit." } ; + +HELP: fnv1a-32 +{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 32-bit." } ; + + +HELP: fnv1-64 +{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 64-bit." } ; + +HELP: fnv1a-64 +{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 64-bit." } ; + + +HELP: fnv1-128 +{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 128-bit." } ; + +HELP: fnv1a-128 +{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 128-bit." } ; + + +HELP: fnv1-256 +{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 256-bit." } ; + +HELP: fnv1a-256 +{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 256-bit." } ; + + +HELP: fnv1-512 +{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 512-bit." } ; + +HELP: fnv1a-512 +{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 512-bit." } ; + + +HELP: fnv1-1024 +{ $class-description "Fowler-Noll-Vo checksum algorithm, v1, 1024-bit." } ; + +HELP: fnv1a-1024 +{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 1024-bit." } ; + +ARTICLE: "checksums.fnv1" "Fowler-Noll-Vo checksum" + "The Fowler-Noll-Vo checksum algorithm is another simple and fast checksum. It comes in 32, 64, 128, 256, 512 and 1024-bit versions, each in 1 and 1a variants. The 1a variants tend to produce a slightly better result. See http://en.wikipedia.org/wiki/Fowler_Noll_Vo_hash for more details." + + { $subsection fnv1-32 } + { $subsection fnv1a-32 } + + { $subsection fnv1-64 } + { $subsection fnv1a-64 } + + { $subsection fnv1-128 } + { $subsection fnv1a-128 } + + { $subsection fnv1-256 } + { $subsection fnv1a-256 } + + { $subsection fnv1-512 } + { $subsection fnv1a-512 } + + { $subsection fnv1-1024 } + { $subsection fnv1a-1024 } + ; + +ABOUT: "checksums.fnv1" diff --git a/basis/checksums/fnv1/fnv1-tests.factor b/basis/checksums/fnv1/fnv1-tests.factor new file mode 100644 index 0000000000..de665a1547 --- /dev/null +++ b/basis/checksums/fnv1/fnv1-tests.factor @@ -0,0 +1,41 @@ +USING: checksums.fnv1 checksums strings tools.test ; +IN: checksums.fnv1.tests + +! A few test vectors taken from http://www.isthe.com/chongo/src/fnv/test_fnv.c + +[ HEX: 811c9dc5 ] [ "" fnv1-32 checksum-bytes ] unit-test +[ HEX: 811c9dc5 ] [ "" fnv1a-32 checksum-bytes ] unit-test +[ HEX: cbf29ce484222325 ] [ "" fnv1-64 checksum-bytes ] unit-test +[ HEX: cbf29ce484222325 ] [ "" fnv1a-64 checksum-bytes ] unit-test + +[ HEX: 050c5d7e ] [ "a" fnv1-32 checksum-bytes ] unit-test +[ HEX: e40c292c ] [ "a" fnv1a-32 checksum-bytes ] unit-test +[ HEX: af63bd4c8601b7be ] [ "a" fnv1-64 checksum-bytes ] unit-test +[ HEX: af63dc4c8601ec8c ] [ "a" fnv1a-64 checksum-bytes ] unit-test + +[ HEX: 050c5d7d ] [ "b" fnv1-32 checksum-bytes ] unit-test +[ HEX: e70c2de5 ] [ "b" fnv1a-32 checksum-bytes ] unit-test +[ HEX: af63bd4c8601b7bd ] [ "b" fnv1-64 checksum-bytes ] unit-test +[ HEX: af63df4c8601f1a5 ] [ "b" fnv1a-64 checksum-bytes ] unit-test + +[ HEX: 31f0b262 ] [ "foobar" fnv1-32 checksum-bytes ] unit-test +[ HEX: bf9cf968 ] [ "foobar" fnv1a-32 checksum-bytes ] unit-test +[ HEX: 340d8765a4dda9c2 ] [ "foobar" fnv1-64 checksum-bytes ] unit-test +[ HEX: 85944171f73967e8 ] [ "foobar" fnv1a-64 checksum-bytes ] unit-test + +! I couldn't find any test vectors for 128, 256, 512, or 1024 versions of FNV1 hashes. +! So, just to check that your maths works the same as my maths, here's a few samples computed on my laptop. +! So they may be right or wrong, but either way, them failing is cause for concern somewhere... + +[ 3897470310 ] [ "Hello, world!" fnv1-32 checksum-bytes ] unit-test +[ 3985698964 ] [ "Hello, world!" fnv1a-32 checksum-bytes ] unit-test +[ 7285062107457560934 ] [ "Hello, world!" fnv1-64 checksum-bytes ] unit-test +[ 4094109891673226228 ] [ "Hello, world!" fnv1a-64 checksum-bytes ] unit-test +[ 281580511747867177735318995358496831158 ] [ "Hello, world!" fnv1-128 checksum-bytes ] unit-test +[ 303126633380056630368940439484674414572 ] [ "Hello, world!" fnv1a-128 checksum-bytes ] unit-test +[ 104295939182568077644846978685759236849634734810631820736486253421270219742822 ] [ "Hello, world!" fnv1-256 checksum-bytes ] unit-test +[ 9495445728692795332446740615588417456874414534608540692485745371050033741380 ] [ "Hello, world!" fnv1a-256 checksum-bytes ] unit-test +[ 3577308325596719252093726711895047340166329831006673109476042102918876665433235513101496175651226507162015890004121912850661561110326527625579463564626958 ] [ "Hello, world!" fnv1-512 checksum-bytes ] unit-test +[ 3577308325596719162840652138474318309664256091923081930027929425092517582111473988451078821416039944023089883981242376700859598441397004715365740906054208 ] [ "Hello, world!" fnv1a-512 checksum-bytes ] unit-test +[ 52692754922840008511959888105094366091401994235075816792707658326855733053286986999719949898492311786648795846192078757217437117165934438286601534984230194601365788544275827382423366672856972872132009691615382991251544423521887009322211754219117294019951276080952271766377222613325328591830596794468813260226 ] [ "Hello, world!" fnv1-1024 checksum-bytes ] unit-test +[ 52692754922840008511959888105094366091401994235075816792707658326855804920671100511873485674717442819607149127986090276849364757610838433887624184145636764448608707614141109841761957788887305179569455221243999538336208648824673027111352338809582124430199044921035232455717748500524777795242051756321605065326 ] [ "Hello, world!" fnv1a-1024 checksum-bytes ] unit-test diff --git a/basis/checksums/fnv1/fnv1.factor b/basis/checksums/fnv1/fnv1.factor new file mode 100644 index 0000000000..5cc6b02425 --- /dev/null +++ b/basis/checksums/fnv1/fnv1.factor @@ -0,0 +1,104 @@ +! Copyright (C) 2009 Alaric Snell-Pym +! See http://factorcode.org/license.txt for BSD license. +USING: checksums classes.singleton kernel math math.ranges +math.vectors sequences ; +IN: checksums.fnv1 + +SINGLETON: fnv1-32 +SINGLETON: fnv1a-32 +SINGLETON: fnv1-64 +SINGLETON: fnv1a-64 +SINGLETON: fnv1-128 +SINGLETON: fnv1a-128 +SINGLETON: fnv1-256 +SINGLETON: fnv1a-256 +SINGLETON: fnv1-512 +SINGLETON: fnv1a-512 +SINGLETON: fnv1-1024 +SINGLETON: fnv1a-1024 + +CONSTANT: fnv1-32-prime 16777619 +CONSTANT: fnv1-64-prime 1099511628211 +CONSTANT: fnv1-128-prime 309485009821345068724781371 +CONSTANT: fnv1-256-prime 374144419156711147060143317175368453031918731002211 +CONSTANT: fnv1-512-prime 35835915874844867368919076489095108449946327955754392558399825615420669938882575126094039892345713852759 +CONSTANT: fnv1-1024-prime 5016456510113118655434598811035278955030765345404790744303017523831112055108147451509157692220295382716162651878526895249385292291816524375083746691371804094271873160484737966720260389217684476157468082573 + +CONSTANT: fnv1-32-mod HEX: ffffffff +CONSTANT: fnv1-64-mod HEX: ffffffffffffffff +CONSTANT: fnv1-128-mod HEX: ffffffffffffffffffffffffffffffff +CONSTANT: fnv1-256-mod HEX: ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +CONSTANT: fnv1-512-mod HEX: ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +CONSTANT: fnv1-1024-mod HEX: ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +CONSTANT: fnv1-32-basis HEX: 811c9dc5 +CONSTANT: fnv1-64-basis HEX: cbf29ce484222325 +CONSTANT: fnv1-128-basis HEX: 6c62272e07bb014262b821756295c58d +CONSTANT: fnv1-256-basis HEX: dd268dbcaac550362d98c384c4e576ccc8b1536847b6bbb31023b4c8caee0535 +CONSTANT: fnv1-512-basis HEX: b86db0b1171f4416dca1e50f309990acac87d059c90000000000000000000d21e948f68a34c192f62ea79bc942dbe7ce182036415f56e34bac982aac4afe9fd9 +CONSTANT: fnv1-1024-basis HEX: 5f7a76758ecc4d32e56d5a591028b74b29fc4223fdada16c3bf34eda3674da9a21d9000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004c6d7eb6e73802734510a555f256cc005ae556bde8cc9c6a93b21aff4b16c71ee90b3 + +M: fnv1-32 checksum-bytes ( bytes checksum -- value ) + drop + fnv1-32-basis swap + [ swap fnv1-32-prime * bitxor fnv1-32-mod bitand ] each ; + +M: fnv1a-32 checksum-bytes ( bytes checksum -- value ) + drop + fnv1-32-basis swap + [ bitxor fnv1-32-prime * fnv1-32-mod bitand ] each ; + + +M: fnv1-64 checksum-bytes ( bytes checksum -- value ) + drop + fnv1-64-basis swap + [ swap fnv1-64-prime * bitxor fnv1-64-mod bitand ] each ; + +M: fnv1a-64 checksum-bytes ( bytes checksum -- value ) + drop + fnv1-64-basis swap + [ bitxor fnv1-64-prime * fnv1-64-mod bitand ] each ; + + +M: fnv1-128 checksum-bytes ( bytes checksum -- value ) + drop + fnv1-128-basis swap + [ swap fnv1-128-prime * bitxor fnv1-128-mod bitand ] each ; + +M: fnv1a-128 checksum-bytes ( bytes checksum -- value ) + drop + fnv1-128-basis swap + [ bitxor fnv1-128-prime * fnv1-128-mod bitand ] each ; + + +M: fnv1-256 checksum-bytes ( bytes checksum -- value ) + drop + fnv1-256-basis swap + [ swap fnv1-256-prime * bitxor fnv1-256-mod bitand ] each ; + +M: fnv1a-256 checksum-bytes ( bytes checksum -- value ) + drop + fnv1-256-basis swap + [ bitxor fnv1-256-prime * fnv1-256-mod bitand ] each ; + + +M: fnv1-512 checksum-bytes ( bytes checksum -- value ) + drop + fnv1-512-basis swap + [ swap fnv1-512-prime * bitxor fnv1-512-mod bitand ] each ; + +M: fnv1a-512 checksum-bytes ( bytes checksum -- value ) + drop + fnv1-512-basis swap + [ bitxor fnv1-512-prime * fnv1-512-mod bitand ] each ; + + +M: fnv1-1024 checksum-bytes ( bytes checksum -- value ) + drop + fnv1-1024-basis swap + [ swap fnv1-1024-prime * bitxor fnv1-1024-mod bitand ] each ; + +M: fnv1a-1024 checksum-bytes ( bytes checksum -- value ) + drop + fnv1-1024-basis swap + [ bitxor fnv1-1024-prime * fnv1-1024-mod bitand ] each ; diff --git a/basis/checksums/fnv1/summary.txt b/basis/checksums/fnv1/summary.txt new file mode 100644 index 0000000000..2c74cda8cd --- /dev/null +++ b/basis/checksums/fnv1/summary.txt @@ -0,0 +1 @@ +Fowler-Noll-Vo checksum algorithm diff --git a/basis/checksums/md5/md5-tests.factor b/basis/checksums/md5/md5-tests.factor index b7f388c002..730c0b8516 100644 --- a/basis/checksums/md5/md5-tests.factor +++ b/basis/checksums/md5/md5-tests.factor @@ -1,6 +1,8 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: byte-arrays checksums checksums.md5 io.encodings.binary io.streams.byte-array kernel math namespaces tools.test ; - +IN: checksums.md5.tests [ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test [ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array md5 checksum-bytes hex-string ] unit-test diff --git a/basis/checksums/openssl/openssl.factor b/basis/checksums/openssl/openssl.factor index 58748b7c29..6f21d96e86 100644 --- a/basis/checksums/openssl/openssl.factor +++ b/basis/checksums/openssl/openssl.factor @@ -19,13 +19,13 @@ C: openssl-checksum ( -- ctx ) - "EVP_MD_CTX" - dup EVP_MD_CTX_init evp-md-context boa ; + evp-md-context new-disposable + "EVP_MD_CTX" dup EVP_MD_CTX_init >>handle ; -M: evp-md-context dispose +M: evp-md-context dispose* handle>> EVP_MD_CTX_cleanup drop ; : with-evp-md-context ( quot -- ) diff --git a/basis/checksums/sha/sha.factor b/basis/checksums/sha/sha.factor index 287c39b2a1..35262bb0b0 100644 --- a/basis/checksums/sha/sha.factor +++ b/basis/checksums/sha/sha.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel splitting grouping math sequences namespaces make -io.binary math.bitwise checksums checksums.common -sbufs strings combinators.smart math.ranges fry combinators -accessors locals checksums.stream multiline literals -generalizations ; +USING: accessors checksums checksums.common checksums.stream +combinators combinators.smart fry generalizations grouping +io.binary kernel literals locals make math math.bitwise +math.ranges multiline namespaces sbufs sequences +sequences.private splitting strings ; IN: checksums.sha SINGLETON: sha1 @@ -230,21 +230,21 @@ M: sha-256 initialize-checksum-state drop ; : prepare-M-256 ( n seq -- ) { - [ [ 16 - ] dip nth ] - [ [ 15 - ] dip nth s0-256 ] - [ [ 7 - ] dip nth ] - [ [ 2 - ] dip nth s1-256 w+ w+ w+ ] + [ [ 16 - ] dip nth-unsafe ] + [ [ 15 - ] dip nth-unsafe s0-256 ] + [ [ 7 - ] dip nth-unsafe ] + [ [ 2 - ] dip nth-unsafe s1-256 w+ w+ w+ ] [ ] - } 2cleave set-nth ; inline + } 2cleave set-nth-unsafe ; inline : prepare-M-512 ( n seq -- ) { - [ [ 16 - ] dip nth ] - [ [ 15 - ] dip nth s0-512 ] - [ [ 7 - ] dip nth ] - [ [ 2 - ] dip nth s1-512 w+ w+ w+ ] + [ [ 16 - ] dip nth-unsafe ] + [ [ 15 - ] dip nth-unsafe s0-512 ] + [ [ 7 - ] dip nth-unsafe ] + [ [ 2 - ] dip nth-unsafe s1-512 w+ w+ w+ ] [ ] - } 2cleave set-nth ; inline + } 2cleave set-nth-unsafe ; inline : ch ( x y z -- x' ) [ bitxor bitand ] keep bitxor ; inline @@ -258,36 +258,36 @@ M: sha-256 initialize-checksum-state drop ; GENERIC: pad-initial-bytes ( string sha2 -- padded-string ) :: T1-256 ( n M H sha2 -- T1 ) - n M nth - n sha2 K>> nth + + n M nth-unsafe + n sha2 K>> nth-unsafe + e H slice3 ch w+ - e H nth S1-256 w+ - h H nth w+ ; inline + e H nth-unsafe S1-256 w+ + h H nth-unsafe w+ ; inline : T2-256 ( H -- T2 ) - [ a swap nth S0-256 ] + [ a swap nth-unsafe S0-256 ] [ a swap slice3 maj w+ ] bi ; inline :: T1-512 ( n M H sha2 -- T1 ) - n M nth - n sha2 K>> nth + + n M nth-unsafe + n sha2 K>> nth-unsafe + e H slice3 ch w+ - e H nth S1-512 w+ - h H nth w+ ; inline + e H nth-unsafe S1-512 w+ + h H nth-unsafe w+ ; inline : T2-512 ( H -- T2 ) - [ a swap nth S0-512 ] + [ a swap nth-unsafe S0-512 ] [ a swap slice3 maj w+ ] bi ; inline : update-H ( T1 T2 H -- ) - h g pick exchange - g f pick exchange - f e pick exchange - pick d pick nth w+ e pick set-nth - d c pick exchange - c b pick exchange - b a pick exchange - [ w+ a ] dip set-nth ; inline + h g pick exchange-unsafe + g f pick exchange-unsafe + f e pick exchange-unsafe + pick d pick nth-unsafe w+ e pick set-nth-unsafe + d c pick exchange-unsafe + c b pick exchange-unsafe + b a pick exchange-unsafe + [ w+ a ] dip set-nth-unsafe ; inline : prepare-message-schedule ( seq sha2 -- w-seq ) [ word-size>> [ be> ] map ] @@ -309,7 +309,7 @@ M: sha2-short checksum-block [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ; : seq>byte-array ( seq n -- string ) - '[ _ >be ] map B{ } join ; + '[ _ >be ] map B{ } concat-as ; : sha1>checksum ( sha2 -- bytes ) H>> 4 seq>byte-array ; @@ -342,16 +342,14 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array ) drop [ ] dip add-checksum-stream get-checksum ; - - : sha1-W ( t seq -- ) { - [ [ 3 - ] dip nth ] - [ [ 8 - ] dip nth bitxor ] - [ [ 14 - ] dip nth bitxor ] - [ [ 16 - ] dip nth bitxor 1 bitroll-32 ] + [ [ 3 - ] dip nth-unsafe ] + [ [ 8 - ] dip nth-unsafe bitxor ] + [ [ 14 - ] dip nth-unsafe bitxor ] + [ [ 16 - ] dip nth-unsafe bitxor 1 bitroll-32 ] [ ] - } 2cleave set-nth ; + } 2cleave set-nth-unsafe ; : prepare-sha1-message-schedule ( seq -- w-seq ) 4 [ be> ] map @@ -368,11 +366,11 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array ) } case ; :: inner-loop ( n H W K -- temp ) - a H nth :> A - b H nth :> B - c H nth :> C - d H nth :> D - e H nth :> E + a H nth-unsafe :> A + b H nth-unsafe :> B + c H nth-unsafe :> C + d H nth-unsafe :> D + e H nth-unsafe :> E [ A 5 bitroll-32 @@ -380,19 +378,19 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array ) E - n K nth + n K nth-unsafe - n W nth + n W nth-unsafe ] sum-outputs 32 bits ; :: process-sha1-chunk ( bytes H W K state -- ) 80 [ H W K inner-loop - d H nth e H set-nth - c H nth d H set-nth - b H nth 30 bitroll-32 c H set-nth - a H nth b H set-nth - a H set-nth + d H nth-unsafe e H set-nth-unsafe + c H nth-unsafe d H set-nth-unsafe + b H nth-unsafe 30 bitroll-32 c H set-nth-unsafe + a H nth-unsafe b H set-nth-unsafe + a H set-nth-unsafe ] each state [ H [ w+ ] 2map ] change-H drop ; inline diff --git a/basis/circular/circular-tests.factor b/basis/circular/circular-tests.factor index b4a9d547f2..c3c4860f95 100644 --- a/basis/circular/circular-tests.factor +++ b/basis/circular/circular-tests.factor @@ -2,6 +2,7 @@ ! See http;//factorcode.org/license.txt for BSD license USING: arrays kernel tools.test sequences sequences.private circular strings ; +IN: circular.tests [ 0 ] [ { 0 1 2 3 4 } 0 swap virtual@ drop ] unit-test [ 2 ] [ { 0 1 2 3 4 } 2 swap virtual@ drop ] unit-test diff --git a/basis/circular/circular.factor b/basis/circular/circular.factor index d47b954ecf..b3be4651cd 100644 --- a/basis/circular/circular.factor +++ b/basis/circular/circular.factor @@ -43,16 +43,15 @@ TUPLE: growing-circular < circular length ; M: growing-circular length length>> ; > length ] bi = ; -: set-last ( elt seq -- ) - [ length 1- ] keep set-nth ; PRIVATE> : push-growing-circular ( elt circular -- ) dup full? [ push-circular ] - [ [ 1+ ] change-length set-last ] if ; + [ [ 1 + ] change-length set-last ] if ; : ( capacity -- growing-circular ) { } new-sequence 0 0 growing-circular boa ; diff --git a/basis/classes/struct/prettyprint/prettyprint.factor b/basis/classes/struct/prettyprint/prettyprint.factor new file mode 100644 index 0000000000..58c923e6d0 --- /dev/null +++ b/basis/classes/struct/prettyprint/prettyprint.factor @@ -0,0 +1,120 @@ +! (c)Joe Groff bsd license +USING: accessors alien alien.c-types arrays assocs classes +classes.struct combinators combinators.short-circuit continuations +fry kernel libc make math math.parser mirrors prettyprint.backend +prettyprint.custom prettyprint.sections see.private sequences +slots strings summary words ; +IN: classes.struct.prettyprint + += + [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ] + [ drop \ STRUCT: ] if ; + +: struct>assoc ( struct -- assoc ) + [ class struct-slots ] [ struct-slot-values ] bi zip ; + +: pprint-struct-slot ( slot -- ) + > text ] + [ c-type>> dup string? [ text ] [ pprint* ] if ] + [ read-only>> [ \ read-only pprint-word ] when ] + [ initial>> [ \ initial: pprint-word pprint* ] when* ] + } cleave + \ } pprint-word block> ; + +: pprint-struct ( struct -- ) + [ + [ \ S{ ] dip + [ class ] + [ struct>assoc [ [ name>> ] dip ] assoc-map ] bi + \ } (pprint-tuple) + ] ?pprint-tuple ; + +: pprint-struct-pointer ( struct -- ) + \ S@ [ [ class pprint-word ] [ >c-ptr pprint* ] bi ] pprint-prefix ; + +PRIVATE> + +M: struct-class see-class* + pprint-; block> ; + +M: struct pprint-delims + drop \ S{ \ } ; + +M: struct >pprint-sequence + [ class ] [ struct-slot-values ] bi class-slot-sequence ; + +M: struct pprint* + [ pprint-struct ] + [ pprint-struct-pointer ] pprint-c-object ; + +M: struct summary + [ + dup class name>> % + " struct of " % + byte-length # + " bytes " % + ] "" make ; + +TUPLE: struct-mirror { object read-only } ; +C: struct-mirror + +: get-struct-slot ( struct slot -- value present? ) + over class struct-slots slot-named + [ name>> reader-word execute( struct -- value ) t ] + [ drop f f ] if* ; +: set-struct-slot ( value struct slot -- ) + over class struct-slots slot-named + [ name>> writer-word execute( value struct -- ) ] + [ 2drop ] if* ; +: reset-struct-slot ( struct slot -- ) + over class struct-slots slot-named + [ [ initial>> swap ] [ name>> writer-word ] bi execute( value struct -- ) ] + [ drop ] if* ; +: reset-struct-slots ( struct -- ) + dup class struct-prototype + dup byte-length memcpy ; + +M: struct-mirror at* + object>> { + { [ over "underlying" = ] [ nip >c-ptr t ] } + { [ over { [ array? ] [ length 1 >= ] } 1&& ] [ swap first get-struct-slot ] } + [ 2drop f f ] + } cond ; + +M: struct-mirror set-at + object>> { + { [ over "underlying" = ] [ 3drop ] } + { [ over array? ] [ swap first set-struct-slot ] } + [ 3drop ] + } cond ; + +M: struct-mirror delete-at + object>> { + { [ over "underlying" = ] [ 2drop ] } + { [ over array? ] [ swap first reset-struct-slot ] } + [ 2drop ] + } cond ; + +M: struct-mirror clear-assoc + object>> reset-struct-slots ; + +M: struct-mirror >alist ( mirror -- alist ) + object>> [ + [ drop "underlying" ] [ >c-ptr ] bi 2array 1array + ] [ + '[ + _ struct>assoc + [ [ [ name>> ] [ c-type>> ] bi 2array ] dip ] assoc-map + ] [ drop { } ] recover + ] bi append ; + +M: struct make-mirror ; + +INSTANCE: struct-mirror assoc diff --git a/basis/classes/struct/struct-docs.factor b/basis/classes/struct/struct-docs.factor new file mode 100644 index 0000000000..8a67f00354 --- /dev/null +++ b/basis/classes/struct/struct-docs.factor @@ -0,0 +1,115 @@ +! (c)Joe Groff bsd license +USING: alien classes help.markup help.syntax kernel libc +quotations slots ; +IN: classes.struct + +HELP: +{ $values + { "class" class } +} +{ $description "This macro implements " { $link boa } " for " { $link struct } " classes. A struct of the given class is constructed, and its slots are initialized using values off the top of the datastack." } ; + +HELP: (struct) +{ $values + { "class" class } + { "struct" struct } +} +{ $description "Allocates garbage-collected heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized; in most cases, the " { $link } " word, which initializes the struct's slots with their initial values, should be used instead." } ; + +{ (struct) (malloc-struct) } related-words + +HELP: +{ $values + { "class" class } + { "struct" struct } +} +{ $description "Allocates garbage-collected heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are initialized with the initial values specified in the struct definition." } ; + +{ malloc-struct memory>struct } related-words + +HELP: STRUCT: +{ $syntax "STRUCT: class { slot type } { slot type } ... ;" } +{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } } +{ $description "Defines a new " { $link struct } " type. The syntax is nearly identical to " { $link POSTPONE: TUPLE: } "; however, there are some additional restrictions on struct types:" +{ $list +{ "Struct classes cannot have a superclass defined." } +{ "The slots of a struct must all have a type declared. The type must be a C type." } +{ { $link read-only } " slots on structs are not enforced, though they may be declared." } +} } ; + +HELP: S{ +{ $syntax "S{ class slots... }" } +{ $values { "class" "a " { $link struct } " class word" } { "slots" "slot values" } } +{ $description "Marks the beginning of a literal struct. The syntax is identical to tuple literal syntax with " { $link POSTPONE: T{ } { $snippet " }" } "; either the assoc syntax (that is, " { $snippet "S{ class { slot value } { slot value } ... }" } ") or the simple syntax (" { $snippet "S{ class f value value ... }" } ") can be used." } ; + +HELP: S@ +{ $syntax "S@ class alien" } +{ $values { "class" "a " { $link struct } " class word" } { "alien" "a literal alien" } } +{ $description "Marks the beginning of a literal struct at a specific C address. The prettyprinter uses this syntax when the memory backing a struct object is invalid. This syntax should not generally be used in source code." } ; + +{ POSTPONE: S{ POSTPONE: S@ } related-words + +HELP: UNION-STRUCT: +{ $syntax "UNION-STRUCT: class { slot type } { slot type } ... ;" } +{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } } +{ $description "Defines a new " { $link struct } " type where all of the slots share the same storage. See " { $link POSTPONE: STRUCT: } " for details on the syntax." } ; + +HELP: define-struct-class +{ $values + { "class" class } { "slots" "a sequence of " { $link struct-slot-spec } "s" } +} +{ $description "Defines a new " { $link struct } " class. This is the runtime equivalent of the " { $link POSTPONE: STRUCT: } " syntax." } ; + +HELP: define-union-struct-class +{ $values + { "class" class } { "slots" "a sequence of " { $link struct-slot-spec } "s" } +} +{ $description "Defines a new " { $link struct } " class where all of the slots share the same storage. This is the runtime equivalent of the " { $link POSTPONE: UNION-STRUCT: } " syntax." } ; + +HELP: malloc-struct +{ $values + { "class" class } + { "struct" struct } +} +{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are initialized to their initial values. The struct should be " { $link free } "d when it is no longer needed." } ; + +HELP: (malloc-struct) +{ $values + { "class" class } + { "struct" struct } +} +{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized; to initialize the allocated memory with the slots' initial values, use " { $link malloc-struct } ". The struct should be " { $link free } "d when it is no longer needed." } ; + +HELP: memory>struct +{ $values + { "ptr" c-ptr } { "class" class } + { "struct" struct } +} +{ $description "Constructs a new " { $link struct } " of the specified " { $snippet "class" } " at the memory location referenced by " { $snippet "ptr" } ". The referenced memory is unchanged." } ; + +HELP: struct +{ $class-description "The parent class of all struct types." } ; + +{ struct POSTPONE: STRUCT: POSTPONE: UNION-STRUCT: } related-words + +HELP: struct-class +{ $class-description "The metaclass of all " { $link struct } " classes." } ; + +ARTICLE: "classes.struct" "Struct classes" +{ $link struct } " classes are similar to " { $link tuple } "s, but their slots exhibit value semantics, and they are backed by a contiguous structured block of memory. Structs can be used for structured access to C memory or Factor byte arrays and for passing struct values in and out of the FFI. Struct types are defined using a syntax similar to tuple syntax:" +{ $subsection POSTPONE: STRUCT: } +"Structs can be allocated with " { $link new } "- and " { $link boa } "-like constructor words. Additional words are provided for building structs from C memory and from existing buffers:" +{ $subsection } +{ $subsection } +{ $subsection malloc-struct } +{ $subsection memory>struct } +"When the contents of a struct will be immediately reset, faster primitive words are available that will create a struct without initializing its contents:" +{ $subsection (struct) } +{ $subsection (malloc-struct) } +"Structs have literal syntax like tuples:" +{ $subsection POSTPONE: S{ } +"Union structs are also supported, which behave like structs but share the same memory for all the type's slots." +{ $subsection POSTPONE: UNION-STRUCT: } +; + +ABOUT: "classes.struct" diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor new file mode 100755 index 0000000000..d76013e138 --- /dev/null +++ b/basis/classes/struct/struct-tests.factor @@ -0,0 +1,348 @@ +! (c)Joe Groff bsd license +USING: accessors alien alien.c-types alien.libraries +alien.structs.fields alien.syntax ascii assocs byte-arrays +classes.struct classes.tuple.private combinators +compiler.tree.debugger compiler.units destructors +io.encodings.utf8 io.pathnames io.streams.string kernel libc +literals math mirrors multiline namespaces prettyprint +prettyprint.config see sequences specialized-arrays.char +specialized-arrays.int specialized-arrays.ushort +struct-arrays system tools.test ; +IN: classes.struct.tests + +<< +: libfactor-ffi-tests-path ( -- string ) + "resource:" (normalize-path) + { + { [ os winnt? ] [ "libfactor-ffi-test.dll" ] } + { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] } + { [ os unix? ] [ "libfactor-ffi-test.so" ] } + } cond append-path ; + +"f-cdecl" libfactor-ffi-tests-path "cdecl" add-library + +"f-stdcall" libfactor-ffi-tests-path "stdcall" add-library +>> + +SYMBOL: struct-test-empty + +[ [ struct-test-empty { } define-struct-class ] with-compilation-unit ] +[ struct-must-have-slots? ] must-fail-with + +STRUCT: struct-test-foo + { x char } + { y int initial: 123 } + { z bool } ; + +STRUCT: struct-test-bar + { w ushort initial: HEX: ffff } + { foo struct-test-foo } ; + +[ 12 ] [ struct-test-foo heap-size ] unit-test +[ 12 ] [ struct-test-foo byte-length ] unit-test +[ 16 ] [ struct-test-bar heap-size ] unit-test +[ 123 ] [ struct-test-foo y>> ] unit-test +[ 123 ] [ struct-test-bar foo>> y>> ] unit-test + +[ 1 2 3 t ] [ + 1 2 3 t struct-test-foo struct-test-bar + { + [ w>> ] + [ foo>> x>> ] + [ foo>> y>> ] + [ foo>> z>> ] + } cleave +] unit-test + +[ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test +[ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test + +[ { + { "underlying" B{ 98 0 0 98 127 0 0 127 0 0 0 0 } } + { { "x" "char" } 98 } + { { "y" "int" } HEX: 7F00007F } + { { "z" "bool" } f } +} ] [ + B{ 98 0 0 98 127 0 0 127 0 0 0 0 } struct-test-foo memory>struct + make-mirror >alist +] unit-test + +[ { { "underlying" f } } ] [ + f struct-test-foo memory>struct + make-mirror >alist +] unit-test + +[ 55 t ] [ S{ struct-test-foo { x 55 } } make-mirror { "x" "char" } swap at* ] unit-test +[ 55 t ] [ S{ struct-test-foo { y 55 } } make-mirror { "y" "int" } swap at* ] unit-test +[ t t ] [ S{ struct-test-foo { z t } } make-mirror { "z" "bool" } swap at* ] unit-test +[ f t ] [ S{ struct-test-foo { z f } } make-mirror { "z" "bool" } swap at* ] unit-test +[ f f ] [ S{ struct-test-foo } make-mirror { "nonexist" "bool" } swap at* ] unit-test +[ f f ] [ S{ struct-test-foo } make-mirror "nonexist" swap at* ] unit-test +[ f t ] [ f struct-test-foo memory>struct make-mirror "underlying" swap at* ] unit-test + +[ S{ struct-test-foo { x 3 } { y 2 } { z f } } ] [ + S{ struct-test-foo { x 1 } { y 2 } { z f } } + [ make-mirror [ 3 { "x" "char" } ] dip set-at ] keep +] unit-test + +[ S{ struct-test-foo { x 1 } { y 5 } { z f } } ] [ + S{ struct-test-foo { x 1 } { y 2 } { z f } } + [ make-mirror [ 5 { "y" "int" } ] dip set-at ] keep +] unit-test + +[ S{ struct-test-foo { x 1 } { y 2 } { z t } } ] [ + S{ struct-test-foo { x 1 } { y 2 } { z f } } + [ make-mirror [ t { "z" "bool" } ] dip set-at ] keep +] unit-test + +[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [ + S{ struct-test-foo { x 1 } { y 2 } { z f } } + [ make-mirror [ "nonsense" "underlying" ] dip set-at ] keep +] unit-test + +[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [ + S{ struct-test-foo { x 1 } { y 2 } { z f } } + [ make-mirror [ "nonsense" "nonexist" ] dip set-at ] keep +] unit-test + +[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [ + S{ struct-test-foo { x 1 } { y 2 } { z f } } + [ make-mirror [ "nonsense" { "nonexist" "int" } ] dip set-at ] keep +] unit-test + +[ S{ struct-test-foo { x 1 } { y 123 } { z f } } ] [ + S{ struct-test-foo { x 1 } { y 2 } { z f } } + [ make-mirror { "y" "int" } swap delete-at ] keep +] unit-test + +[ S{ struct-test-foo { x 0 } { y 2 } { z f } } ] [ + S{ struct-test-foo { x 1 } { y 2 } { z f } } + [ make-mirror { "x" "char" } swap delete-at ] keep +] unit-test + +[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [ + S{ struct-test-foo { x 1 } { y 2 } { z f } } + [ make-mirror { "nonexist" "char" } swap delete-at ] keep +] unit-test + +[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [ + S{ struct-test-foo { x 1 } { y 2 } { z f } } + [ make-mirror "underlying" swap delete-at ] keep +] unit-test + +[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [ + S{ struct-test-foo { x 1 } { y 2 } { z f } } + [ make-mirror "nonsense" swap delete-at ] keep +] unit-test + +[ S{ struct-test-foo { x 0 } { y 123 } { z f } } ] [ + S{ struct-test-foo { x 1 } { y 2 } { z t } } + [ make-mirror clear-assoc ] keep +] unit-test + +UNION-STRUCT: struct-test-float-and-bits + { f float } + { bits uint } ; + +[ 1.0 ] [ struct-test-float-and-bits 1.0 float>bits >>bits f>> ] unit-test +[ 4 ] [ struct-test-float-and-bits heap-size ] unit-test + +[ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test + +STRUCT: struct-test-string-ptr + { x char* } ; + +[ "hello world" ] [ + [ + struct-test-string-ptr + "hello world" utf8 malloc-string &free >>x + x>> + ] with-destructors +] unit-test + +[ "S{ struct-test-foo { x 0 } { y 7654 } { z f } }" ] +[ + [ + boa-tuples? off + c-object-pointers? off + struct-test-foo 7654 >>y [ pprint ] with-string-writer + ] with-scope +] unit-test + +[ "S@ struct-test-foo B{ 0 0 0 0 0 0 0 0 0 0 0 0 }" ] +[ + [ + c-object-pointers? on + 12 struct-test-foo memory>struct [ pprint ] with-string-writer + ] with-scope +] unit-test + +[ "S{ struct-test-foo f 0 7654 f }" ] +[ + [ + boa-tuples? on + c-object-pointers? off + struct-test-foo 7654 >>y [ pprint ] with-string-writer + ] with-scope +] unit-test + +[ "S@ struct-test-foo f" ] +[ + [ + c-object-pointers? off + f struct-test-foo memory>struct [ pprint ] with-string-writer + ] with-scope +] unit-test + +[ <" USING: classes.struct ; +IN: classes.struct.tests +STRUCT: struct-test-foo + { x char initial: 0 } { y int initial: 123 } { z bool } ; +"> ] +[ [ struct-test-foo see ] with-string-writer ] unit-test + +[ <" USING: classes.struct ; +IN: classes.struct.tests +UNION-STRUCT: struct-test-float-and-bits + { f float initial: 0.0 } { bits uint initial: 0 } ; +"> ] +[ [ struct-test-float-and-bits see ] with-string-writer ] unit-test + +[ { + T{ field-spec + { name "x" } + { offset 0 } + { type "char" } + { reader x>> } + { writer (>>x) } + } + T{ field-spec + { name "y" } + { offset 4 } + { type "int" } + { reader y>> } + { writer (>>y) } + } + T{ field-spec + { name "z" } + { offset 8 } + { type "bool" } + { reader z>> } + { writer (>>z) } + } +} ] [ "struct-test-foo" c-type fields>> ] unit-test + +[ { + T{ field-spec + { name "f" } + { offset 0 } + { type "float" } + { reader f>> } + { writer (>>f) } + } + T{ field-spec + { name "bits" } + { offset 0 } + { type "uint" } + { reader bits>> } + { writer (>>bits) } + } +} ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test + +STRUCT: struct-test-equality-1 + { x int } ; +STRUCT: struct-test-equality-2 + { y int } ; + +[ t ] [ + [ + struct-test-equality-1 5 >>x + struct-test-equality-1 malloc-struct &free 5 >>x = + ] with-destructors +] unit-test + +[ f ] [ + [ + struct-test-equality-1 5 >>x + struct-test-equality-2 malloc-struct &free 5 >>y = + ] with-destructors +] unit-test + +[ t ] [ + [ + struct-test-equality-1 5 >>x + struct-test-equality-1 malloc-struct &free 5 >>x + [ hashcode ] bi@ = + ] with-destructors +] unit-test + +STRUCT: struct-test-ffi-foo + { x int } + { y int } ; + +LIBRARY: f-cdecl +FUNCTION: int ffi_test_11 ( int a, struct-test-ffi-foo b, int c ) ; + +[ 14 ] [ 1 2 3 struct-test-ffi-foo 4 ffi_test_11 ] unit-test + +STRUCT: struct-test-array-slots + { x int } + { y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } } + { z int } ; + +[ 11 ] [ struct-test-array-slots y>> 4 swap nth ] unit-test + +[ t ] [ + struct-test-array-slots + [ y>> [ 8 3 ] dip set-nth ] + [ y>> ushort-array{ 2 3 5 8 11 13 } sequence= ] bi +] unit-test + +STRUCT: struct-test-optimization + { x { "int" 3 } } { y int } ; + +[ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test +[ t ] [ + [ 3 struct-test-optimization third y>> ] + { memory>struct y>> } inlined? +] unit-test + +[ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test + +[ t ] [ + [ struct-test-optimization memory>struct x>> second ] + { memory>struct x>> } inlined? +] unit-test + +[ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test + +[ t ] [ + [ struct-test-optimization struct-test-optimization [ x>> ] bi@ ] + { x>> } inlined? +] unit-test + +! Test cloning structs +STRUCT: clone-test-struct { x int } { y char[3] } ; + +[ 1 char-array{ 9 1 1 } ] [ + clone-test-struct + 1 >>x char-array{ 9 1 1 } >>y + clone + [ x>> ] [ y>> >char-array ] bi +] unit-test + +[ t 1 char-array{ 9 1 1 } ] [ + [ + clone-test-struct malloc-struct &free + 1 >>x char-array{ 9 1 1 } >>y + clone + [ >c-ptr byte-array? ] [ x>> ] [ y>> >char-array ] tri + ] with-destructors +] unit-test + +STRUCT: struct-that's-a-word { x int } ; + +: struct-that's-a-word ( -- ) "OOPS" throw ; + +[ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test + diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor new file mode 100755 index 0000000000..dc7fa965db --- /dev/null +++ b/basis/classes/struct/struct.factor @@ -0,0 +1,323 @@ +! (c)Joe Groff bsd license +USING: accessors alien alien.c-types alien.structs +alien.structs.fields arrays byte-arrays classes classes.parser +classes.tuple classes.tuple.parser classes.tuple.private +combinators combinators.short-circuit combinators.smart +definitions functors.backend fry generalizations generic.parser +kernel kernel.private lexer libc locals macros make math math.order +parser quotations sequences slots slots.private struct-arrays vectors +words compiler.tree.propagation.transforms specialized-arrays.uchar ; +FROM: slots => reader-word writer-word ; +IN: classes.struct + +! struct class + +ERROR: struct-must-have-slots ; + +TUPLE: struct + { (underlying) c-ptr read-only } ; + +TUPLE: struct-slot-spec < slot-spec + c-type ; + +PREDICATE: struct-class < tuple-class \ struct subclass-of? ; + +: struct-slots ( struct-class -- slots ) + "struct-slots" word-prop ; + +! struct allocation + +M: struct >c-ptr + 2 slot { c-ptr } declare ; inline + +M: struct equal? + { + [ [ class ] bi@ = ] + [ [ >c-ptr ] [ [ >c-ptr ] [ byte-length ] bi ] bi* memory= ] + } 2&& ; inline + +M: struct hashcode* + [ >c-ptr ] [ byte-length ] bi hashcode* ; inline + +: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable + +: memory>struct ( ptr class -- struct ) + ! This is sub-optimal if the class is not literal, but gets + ! optimized down to efficient code if it is. + '[ _ boa ] call( ptr -- struct ) ; inline + +struct ; inline +PRIVATE> + +: (malloc-struct) ( class -- struct ) + [ heap-size malloc ] keep memory>struct ; inline + +: malloc-struct ( class -- struct ) + [ >c-ptr malloc-byte-array ] [ 1 swap heap-size calloc ] (init-struct) ; inline + +: (struct) ( class -- struct ) + [ heap-size (byte-array) ] keep memory>struct ; inline + +: ( class -- struct ) + [ >c-ptr clone ] [ heap-size ] (init-struct) ; inline + +MACRO: ( class -- quot: ( ... -- struct ) ) + [ + [ \ (struct) [ ] 2sequence ] + [ + struct-slots + [ length \ ndip ] + [ [ name>> setter-word 1quotation ] map \ spread ] bi + ] bi + ] [ ] output>sequence ; + +> ] map over length tail append ] keep ; + +: (reader-quot) ( slot -- quot ) + [ c-type>> c-type-getter-boxer ] + [ offset>> [ >c-ptr ] swap suffix ] bi prepend ; + +: (writer-quot) ( slot -- quot ) + [ c-type>> c-setter ] + [ offset>> [ >c-ptr ] swap suffix ] bi prepend ; + +: (boxer-quot) ( class -- quot ) + '[ _ memory>struct ] ; + +: (unboxer-quot) ( class -- quot ) + drop [ >c-ptr ] ; +PRIVATE> + +M: struct-class boa>object + swap pad-struct-slots + [ ] [ struct-slots ] bi + [ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ; + +! Struct slot accessors + +GENERIC: struct-slot-values ( struct -- sequence ) + +M: struct-class reader-quot + nip (reader-quot) ; + +M: struct-class writer-quot + nip (writer-quot) ; + +! c-types + +> reader-word 1quotation ] map + \ cleave [ ] 2sequence + \ output>array [ ] 2sequence ; + +: define-inline-method ( class generic quot -- ) + [ create-method-in ] dip [ define ] [ drop make-inline ] 2bi ; + +: (define-struct-slot-values-method) ( class -- ) + [ \ struct-slot-values ] [ struct-slot-values-quot ] bi + define-inline-method ; + +: clone-underlying ( struct -- byte-array ) + [ >c-ptr ] [ byte-length ] bi memory>byte-array ; inline + +: (define-clone-method) ( class -- ) + [ \ clone ] + [ \ clone-underlying swap literalize \ memory>struct [ ] 3sequence ] bi + define-inline-method ; + +: slot>field ( slot -- field ) + field-spec new swap { + [ name>> >>name ] + [ offset>> >>offset ] + [ c-type>> >>type ] + [ name>> reader-word >>reader ] + [ name>> writer-word >>writer ] + } cleave ; + +: define-struct-for-class ( class -- ) + [ + { + [ name>> ] + [ "struct-size" word-prop ] + [ "struct-align" word-prop ] + [ struct-slots [ slot>field ] map ] + } cleave + struct-type (define-struct) + ] [ + { + [ name>> c-type ] + [ (unboxer-quot) >>unboxer-quot ] + [ (boxer-quot) >>boxer-quot ] + [ >>boxed-class ] + } cleave drop + ] bi ; + +: align-offset ( offset class -- offset' ) + c-type-align align ; + +: struct-offsets ( slots -- size ) + 0 [ + [ c-type>> align-offset ] keep + [ (>>offset) ] [ c-type>> heap-size + ] 2bi + ] reduce ; + +: union-struct-offsets ( slots -- size ) + [ 0 >>offset c-type>> heap-size ] [ max ] map-reduce ; + +: struct-align ( slots -- align ) + [ c-type>> c-type-align ] [ max ] map-reduce ; +PRIVATE> + +M: struct-class c-type + name>> c-type ; + +M: struct-class c-type-align + "struct-align" word-prop ; + +M: struct-class c-type-getter + drop [ swap ] ; + +M: struct-class c-type-setter + [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri + '[ @ swap @ _ memcpy ] ; + +M: struct-class c-type-boxer-quot + (boxer-quot) ; + +M: struct-class c-type-unboxer-quot + (unboxer-quot) ; + +M: struct-class heap-size + "struct-size" word-prop ; + +M: struct byte-length + class "struct-size" word-prop ; foldable + +! class definition + + ] + [ memory>struct ] + [ struct-slots ] tri + [ + [ initial>> ] + [ (writer-quot) ] bi + over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if + ] each ; + +: (struct-methods) ( class -- ) + [ (define-struct-slot-values-method) ] + [ (define-clone-method) ] + bi ; + +: (struct-word-props) ( class slots size align -- ) + [ + [ "struct-slots" set-word-prop ] + [ define-accessors ] 2bi + ] + [ "struct-size" set-word-prop ] + [ "struct-align" set-word-prop ] tri-curry* + [ tri ] 3curry + [ dup make-struct-prototype "prototype" set-word-prop ] + [ (struct-methods) ] tri ; + +: check-struct-slots ( slots -- ) + [ c-type>> c-type drop ] each ; + +: redefine-struct-tuple-class ( class -- ) + [ dup class? [ forget-class ] [ drop ] if ] [ struct f define-tuple-class ] bi ; + +: (define-struct-class) ( class slots offsets-quot -- ) + [ + [ struct-must-have-slots ] + [ drop redefine-struct-tuple-class ] if-empty + ] + swap '[ + make-slots dup + [ check-struct-slots ] _ [ struct-align [ align ] keep ] tri + (struct-word-props) + ] + [ drop define-struct-for-class ] 2tri ; inline +PRIVATE> + +: define-struct-class ( class slots -- ) + [ struct-offsets ] (define-struct-class) ; + +: define-union-struct-class ( class slots -- ) + [ union-struct-offsets ] (define-struct-class) ; + +ERROR: invalid-struct-slot token ; + +: struct-slot-class ( c-type -- class' ) + c-type c-type-boxed-class + dup \ byte-array = [ drop \ c-ptr ] when ; + +: ( name c-type attributes -- slot-spec ) + [ struct-slot-spec new ] 3dip + [ >>name ] + [ [ >>c-type ] [ struct-slot-class >>class ] bi ] + [ [ dup empty? ] [ peel-off-attributes ] until drop ] tri* ; + +array ] when ; + +: parse-struct-slot ( -- slot ) + scan scan-c-type \ } parse-until ; + +: parse-struct-slots ( slots -- slots' more? ) + scan { + { ";" [ f ] } + { "{" [ parse-struct-slot over push t ] } + [ invalid-struct-slot ] + } case ; + +: parse-struct-definition ( -- class slots ) + CREATE-CLASS 8 [ parse-struct-slots ] [ ] while >array ; +PRIVATE> + +SYNTAX: STRUCT: + parse-struct-definition define-struct-class ; +SYNTAX: UNION-STRUCT: + parse-struct-definition define-union-struct-class ; + +SYNTAX: S{ + scan-word dup struct-slots parse-tuple-literal-slots parsed ; + +SYNTAX: S@ + scan-word scan-object swap memory>struct parsed ; + +! functor support + +array ] [ >string-param ] if ; + +: parse-struct-slot` ( accum -- accum ) + scan-string-param scan-c-type` \ } parse-until + [ over push ] 3curry over push-all ; + +: parse-struct-slots` ( accum -- accum more? ) + scan { + { ";" [ f ] } + { "{" [ parse-struct-slot` t ] } + [ invalid-struct-slot ] + } case ; +PRIVATE> + +FUNCTOR-SYNTAX: STRUCT: + scan-param parsed + [ 8 ] over push-all + [ parse-struct-slots` ] [ ] while + [ >array define-struct-class ] over push-all ; + +USING: vocabs vocabs.loader ; + +"prettyprint" vocab [ "classes.struct.prettyprint" require ] when diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor index 66093645c1..cbf8636a75 100644 --- a/basis/cocoa/application/application.factor +++ b/basis/cocoa/application/application.factor @@ -18,7 +18,7 @@ NSApplicationDelegateReplyFailure ; : NSApp ( -- app ) NSApplication -> sharedApplication ; -: NSAnyEventMask ( -- mask ) HEX: ffffffff ; inline +CONSTANT: NSAnyEventMask HEX: ffffffff FUNCTION: void NSBeep ( ) ; diff --git a/basis/cocoa/callbacks/callbacks.factor b/basis/cocoa/callbacks/callbacks.factor index 4ed9d7de67..a798eb15ba 100644 --- a/basis/cocoa/callbacks/callbacks.factor +++ b/basis/cocoa/callbacks/callbacks.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2006 Kevin Reid. ! See http://factorcode.org/license.txt for BSD license. -IN: cocoa.callbacks USING: assocs kernel namespaces cocoa cocoa.classes cocoa.subclassing debugger ; +IN: cocoa.callbacks SYMBOL: callbacks diff --git a/basis/cocoa/cocoa-tests.factor b/basis/cocoa/cocoa-tests.factor index 4b5af2e39d..c657a5e6e8 100644 --- a/basis/cocoa/cocoa-tests.factor +++ b/basis/cocoa/cocoa-tests.factor @@ -1,7 +1,7 @@ -IN: cocoa.tests USING: cocoa cocoa.messages cocoa.subclassing cocoa.types compiler kernel namespaces cocoa.classes tools.test memory compiler.units math core-graphics.types ; +IN: cocoa.tests CLASS: { { +superclass+ "NSObject" } diff --git a/basis/cocoa/cocoa.factor b/basis/cocoa/cocoa.factor index b78bb020d0..ec5db31940 100644 --- a/basis/cocoa/cocoa.factor +++ b/basis/cocoa/cocoa.factor @@ -60,6 +60,7 @@ SYNTAX: IMPORT: scan [ ] import-objc-class ; "NSOpenGLPixelFormat" "NSOpenGLView" "NSOpenPanel" + "NSPanel" "NSPasteboard" "NSPropertyListSerialization" "NSResponder" diff --git a/basis/cocoa/enumeration/enumeration.factor b/basis/cocoa/enumeration/enumeration.factor old mode 100644 new mode 100755 index 1f9430e443..caa83331ab --- a/basis/cocoa/enumeration/enumeration.factor +++ b/basis/cocoa/enumeration/enumeration.factor @@ -1,27 +1,28 @@ ! Copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel cocoa cocoa.types alien.c-types locals math -sequences vectors fry libc destructors -specialized-arrays.direct.alien ; +USING: accessors kernel classes.struct cocoa cocoa.types alien.c-types +locals math sequences vectors fry libc destructors ; IN: cocoa.enumeration +<< "id" require-c-array >> + CONSTANT: NS-EACH-BUFFER-SIZE 16 : with-enumeration-buffers ( quot -- ) '[ - "NSFastEnumerationState" malloc-object &free + NSFastEnumerationState malloc-struct &free NS-EACH-BUFFER-SIZE "id" malloc-array &free NS-EACH-BUFFER-SIZE @ ] with-destructors ; inline :: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- ) - object state stackbuf count -> countByEnumeratingWithState:objects:count: - dup 0 = [ drop ] [ - state NSFastEnumerationState-itemsPtr [ stackbuf ] unless* - swap quot each + object state stackbuf count -> countByEnumeratingWithState:objects:count: :> items-count + items-count 0 = [ + state itemsPtr>> [ items-count "id" ] [ stackbuf ] if* :> items + items-count iota [ items nth quot call ] each object quot state stackbuf count (NSFastEnumeration-each) - ] if ; inline recursive + ] unless ; inline recursive : NSFastEnumeration-each ( object quot -- ) [ (NSFastEnumeration-each) ] with-enumeration-buffers ; inline diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor old mode 100644 new mode 100755 index a3fa788f20..7342451c38 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types alien.strings arrays assocs -continuations combinators compiler compiler.alien stack-checker kernel -math namespaces make quotations sequences strings words -cocoa.runtime io macros memoize io.encodings.utf8 effects libc -libc.private lexer init core-foundation fry generalizations -specialized-arrays.direct.alien ; +classes.struct continuations combinators compiler compiler.alien +stack-checker kernel math namespaces make quotations sequences +strings words cocoa.runtime io macros memoize io.encodings.utf8 +effects libc libc.private lexer init core-foundation fry +generalizations specialized-arrays.alien ; IN: cocoa.messages : make-sender ( method function -- quot ) @@ -31,11 +31,8 @@ super-message-senders [ H{ } clone ] initialize bi ; : ( receiver -- super ) - "objc-super" [ - [ dup object_getClass class_getSuperclass ] dip - set-objc-super-class - ] keep - [ set-objc-super-receiver ] keep ; + [ ] [ object_getClass class_getSuperclass ] bi + objc-super ; TUPLE: selector name object ; @@ -158,12 +155,16 @@ objc>alien-types get [ swap ] assoc-map } case assoc-union alien>objc-types set-global +: internal-cocoa-type? ( c-type -- ? ) + [ "?" = ] [ first CHAR: _ = ] bi or ; + +: warn-c-type ( c-type -- ) + dup internal-cocoa-type? + [ drop ] [ "Warning: no such C type: " write print ] if ; + : objc-struct-type ( i string -- ctype ) [ CHAR: = ] 2keep index-from swap subseq - dup c-types get key? [ - "Warning: no such C type: " write dup print - drop "void*" - ] unless ; + dup c-types get key? [ warn-c-type "void*" ] unless ; ERROR: no-objc-type name ; @@ -172,7 +173,7 @@ ERROR: no-objc-type name ; [ ] [ no-objc-type ] ?if ; : (parse-objc-type) ( i string -- ctype ) - [ [ 1+ ] dip ] [ nth ] 2bi { + [ [ 1 + ] dip ] [ nth ] 2bi { { [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] } { [ dup CHAR: ^ = ] [ 3drop "void*" ] } { [ dup CHAR: { = ] [ drop objc-struct-type ] } diff --git a/basis/cocoa/plists/plists-tests.factor b/basis/cocoa/plists/plists-tests.factor index 4f74cd850a..e5d7dfd239 100644 --- a/basis/cocoa/plists/plists-tests.factor +++ b/basis/cocoa/plists/plists-tests.factor @@ -1,7 +1,7 @@ -IN: cocoa.plists.tests USING: tools.test cocoa.plists colors kernel hashtables core-foundation.utilities core-foundation destructors assocs cocoa.enumeration ; +IN: cocoa.plists.tests [ [ V{ } ] [ H{ } >cf &CFRelease [ ] NSFastEnumeration-map ] unit-test @@ -37,4 +37,4 @@ assocs cocoa.enumeration ; [ 3.5 ] [ 3.5 >cf &CFRelease plist> ] unit-test -] with-destructors \ No newline at end of file +] with-destructors diff --git a/basis/cocoa/runtime/runtime.factor b/basis/cocoa/runtime/runtime.factor index 7817d0006c..28d812a489 100644 --- a/basis/cocoa/runtime/runtime.factor +++ b/basis/cocoa/runtime/runtime.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax ; +USING: alien.syntax classes.struct ; IN: cocoa.runtime TYPEDEF: void* SEL @@ -17,9 +17,9 @@ TYPEDEF: void* Class TYPEDEF: void* Method TYPEDEF: void* Protocol -C-STRUCT: objc-super - { "id" "receiver" } - { "Class" "class" } ; +STRUCT: objc-super + { receiver id } + { class Class } ; CONSTANT: CLS_CLASS HEX: 1 CONSTANT: CLS_META HEX: 2 diff --git a/basis/cocoa/types/types.factor b/basis/cocoa/types/types.factor index 6e03a21bbc..0e0ef72ad2 100644 --- a/basis/cocoa/types/types.factor +++ b/basis/cocoa/types/types.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types alien.syntax combinators kernel layouts -core-graphics.types ; +classes.struct core-graphics.types ; IN: cocoa.types TYPEDEF: long NSInteger @@ -16,9 +16,9 @@ TYPEDEF: NSSize _NSSize TYPEDEF: CGRect NSRect TYPEDEF: NSRect _NSRect -C-STRUCT: NSRange - { "NSUInteger" "location" } - { "NSUInteger" "length" } ; +STRUCT: NSRange + { location NSUInteger } + { length NSUInteger } ; TYPEDEF: NSRange _NSRange @@ -27,13 +27,11 @@ TYPEDEF: int long32 TYPEDEF: uint ulong32 TYPEDEF: void* unknown_type -: ( length location -- size ) - "NSRange" - [ set-NSRange-length ] keep - [ set-NSRange-location ] keep ; +: ( location length -- size ) + NSRange ; -C-STRUCT: NSFastEnumerationState - { "ulong" "state" } - { "id*" "itemsPtr" } - { "ulong*" "mutationsPtr" } - { "ulong[5]" "extra" } ; +STRUCT: NSFastEnumerationState + { state ulong } + { itemsPtr id* } + { mutationsPtr ulong* } + { extra ulong[5] } ; diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor index f65fddac58..badcac5cdb 100644 --- a/basis/cocoa/views/views.factor +++ b/basis/cocoa/views/views.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: specialized-arrays.int arrays kernel math namespaces make +USING: arrays kernel math namespaces make cocoa cocoa.messages cocoa.classes core-graphics core-graphics.types sequences continuations accessors ; IN: cocoa.views @@ -58,6 +58,6 @@ CONSTANT: NSOpenGLCPSwapInterval 222 : mouse-location ( view event -- loc ) [ -> locationInWindow f -> convertPoint:fromView: - [ CGPoint-x ] [ CGPoint-y ] bi + [ x>> ] [ y>> ] bi ] [ drop -> frame CGRect-h ] 2bi swap - [ >integer ] bi@ 2array ; diff --git a/basis/cocoa/windows/windows-docs.factor b/basis/cocoa/windows/windows-docs.factor index 39bd631b19..690fe9b5aa 100644 --- a/basis/cocoa/windows/windows-docs.factor +++ b/basis/cocoa/windows/windows-docs.factor @@ -2,11 +2,11 @@ USING: help.markup help.syntax ; IN: cocoa.windows HELP: -{ $values { "rect" "an " { $snippet "NSRect" } } { "window" "an " { $snippet "NSWindow" } } } +{ $values { "rect" "an " { $snippet "NSRect" } } { "style" "a style mask" } { "class" "an Objective-C class" } { "window" "an " { $snippet "NSWindow" } } } { $description "Creates a new " { $snippet "NSWindow" } " with the specified dimensions." } ; HELP: -{ $values { "view" "an " { $snippet "NSView" } } { "rect" "an " { $snippet "NSRect" } } { "window" "an " { $snippet "NSWindow" } } } +{ $values { "view" "an " { $snippet "NSView" } } { "rect" "an " { $snippet "NSRect" } } { "style" "a style mask" } { "window" "an " { $snippet "NSWindow" } } } { $description "Creates a new " { $snippet "NSWindow" } " with the specified dimensions, containing the given view." } ; ARTICLE: "cocoa-window-utils" "Cocoa window utilities" diff --git a/basis/cocoa/windows/windows.factor b/basis/cocoa/windows/windows.factor index 4e0f768b96..ed2c2d51bd 100644 --- a/basis/cocoa/windows/windows.factor +++ b/basis/cocoa/windows/windows.factor @@ -4,36 +4,37 @@ USING: arrays kernel math cocoa cocoa.messages cocoa.classes sequences math.bitwise ; IN: cocoa.windows +! Window styles CONSTANT: NSBorderlessWindowMask 0 CONSTANT: NSTitledWindowMask 1 CONSTANT: NSClosableWindowMask 2 CONSTANT: NSMiniaturizableWindowMask 4 CONSTANT: NSResizableWindowMask 8 +! Additional panel-only styles +CONSTANT: NSUtilityWindowMask 16 +CONSTANT: NSDocModalWindowMask 64 +CONSTANT: NSNonactivatingPanelMask 128 +CONSTANT: NSHUDWindowMask HEX: 1000 + CONSTANT: NSBackingStoreRetained 0 CONSTANT: NSBackingStoreNonretained 1 CONSTANT: NSBackingStoreBuffered 2 -: standard-window-type ( -- n ) - { - NSTitledWindowMask - NSClosableWindowMask - NSMiniaturizableWindowMask - NSResizableWindowMask - } flags ; inline - -: ( rect -- window ) - NSWindow -> alloc swap - standard-window-type NSBackingStoreBuffered 1 +: ( rect style class -- window ) + [ -> alloc ] curry 2dip NSBackingStoreBuffered 1 -> initWithContentRect:styleMask:backing:defer: ; -: ( view rect -- window ) - [ swap -> setContentView: ] keep +: class-for-style ( style -- NSWindow/NSPanel ) + HEX: 1ff0 bitand zero? NSWindow NSPanel ? ; + +: ( view rect style -- window ) + dup class-for-style [ swap -> setContentView: ] keep dup dup -> contentView -> setInitialFirstResponder: dup 1 -> setAcceptsMouseMovedEvents: dup 0 -> setReleasedWhenClosed: ; : window-content-rect ( window -- rect ) - [ NSWindow ] dip + dup -> class swap [ -> frame ] [ -> styleMask ] bi -> contentRectForFrameRect:styleMask: ; diff --git a/basis/colors/constants/constants.factor b/basis/colors/constants/constants.factor index 38339577cf..98e7d43411 100644 --- a/basis/colors/constants/constants.factor +++ b/basis/colors/constants/constants.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel assocs math math.parser memoize -io.encodings.ascii io.files lexer parser -colors sequences splitting combinators.smart ascii ; +USING: kernel assocs math math.parser memoize io.encodings.utf8 +io.files lexer parser colors sequences splitting +combinators.smart ascii ; IN: colors.constants assoc ; MEMO: rgb.txt ( -- assoc ) - "resource:basis/colors/constants/rgb.txt" ascii file-lines parse-rgb.txt ; + "resource:basis/colors/constants/rgb.txt" utf8 file-lines parse-rgb.txt ; PRIVATE> diff --git a/basis/colors/hsv/hsv-tests.factor b/basis/colors/hsv/hsv-tests.factor index a825cacda8..278906ce0e 100644 --- a/basis/colors/hsv/hsv-tests.factor +++ b/basis/colors/hsv/hsv-tests.factor @@ -1,5 +1,5 @@ -IN: colors.hsv.tests USING: accessors kernel colors colors.hsv tools.test math ; +IN: colors.hsv.tests : hsv>rgb ( h s v -- r g b ) [ 360 * ] 2dip @@ -25,4 +25,4 @@ USING: accessors kernel colors colors.hsv tools.test math ; [ 5/6 5/36 5/6 ] [ 5/6 5/6 5/6 hsv>rgb ] unit-test [ 1/6 0 1/6 ] [ 5/6 1 1/6 hsv>rgb ] unit-test -[ 0.5 ] [ 180 0.1 0.2 0.5 alpha>> ] unit-test \ No newline at end of file +[ 0.5 ] [ 180 0.1 0.2 0.5 alpha>> ] unit-test diff --git a/basis/columns/columns-tests.factor b/basis/columns/columns-tests.factor index 657b9e0a25..a53f5c1185 100644 --- a/basis/columns/columns-tests.factor +++ b/basis/columns/columns-tests.factor @@ -1,5 +1,5 @@ -IN: columns.tests USING: columns sequences kernel namespaces arrays tools.test math ; +IN: columns.tests ! Columns { { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set diff --git a/basis/combinators/short-circuit/short-circuit-docs.factor b/basis/combinators/short-circuit/short-circuit-docs.factor index 6cd18201fe..db7056bd5a 100644 --- a/basis/combinators/short-circuit/short-circuit-docs.factor +++ b/basis/combinators/short-circuit/short-circuit-docs.factor @@ -1,62 +1,46 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax io.streams.string quotations -math ; +math kernel ; IN: combinators.short-circuit HELP: 0&& -{ $values - { "quots" "a sequence of quotations" } - { "quot" quotation } } -{ $description "Returns true if every quotation in the sequence of quotations returns true." } ; +{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } } +{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ; HELP: 0|| -{ $values - { "quots" "a sequence of quotations" } - { "quot" quotation } } -{ $description "Returns true if any quotation in the sequence returns true." } ; +{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the first true result, or " { $link f } } } +{ $description "If every quotation in the sequence outputs " { $link f } ", outputs " { $link f } ", otherwise outputs the result of the first quotation that did not yield " { $link f } "." } ; HELP: 1&& -{ $values - { "quots" "a sequence of quotations" } - { "quot" quotation } } -{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same element from the datastack and must output a boolean." } ; +{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj -- )" } } { "?" "the result of the last quotation, or " { $link f } } } +{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ; HELP: 1|| -{ $values - { "quots" "a sequence of quotations" } - { "quot" quotation } } +{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj -- )" } } { "?" "the first true result, or " { $link f } } } { $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same element from the datastack and must return a boolean." } ; HELP: 2&& -{ $values - { "quots" "a sequence of quotations" } - { "quot" quotation } } -{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same two elements from the datastack and must output a boolean." } ; +{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 -- )" } } { "?" "the result of the last quotation, or " { $link f } } } +{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ; HELP: 2|| -{ $values - { "quots" "a sequence of quotations" } - { "quot" quotation } } +{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 -- )" } } { "?" "the first true result, or " { $link f } } } { $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same two elements from the datastack and must return a boolean." } ; HELP: 3&& -{ $values - { "quots" "a sequence of quotations" } - { "quot" quotation } } -{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same three elements from the datastack and must output a boolean." } ; +{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 obj3 -- )" } } { "?" "the result of the last quotation, or " { $link f } } } +{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ; HELP: 3|| -{ $values - { "quots" "a sequence of quotations" } - { "quot" quotation } } +{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 obj3 -- )" } } { "?" "the first true result, or " { $link f } } } { $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same three elements from the datastack and must return a boolean." } ; HELP: n&& { $values - { "quots" "a sequence of quotations" } { "N" integer } + { "quots" "a sequence of quotations" } { "n" integer } { "quot" quotation } } -{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each AND quotation." } ; +{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each quotation, evaluating the result in the same manner as " { $link 0&& } "." } ; HELP: n|| { $values diff --git a/basis/combinators/short-circuit/short-circuit-tests.factor b/basis/combinators/short-circuit/short-circuit-tests.factor index e392d67d2a..b2bcb2a60f 100644 --- a/basis/combinators/short-circuit/short-circuit-tests.factor +++ b/basis/combinators/short-circuit/short-circuit-tests.factor @@ -1,32 +1,25 @@ - USING: kernel math tools.test combinators.short-circuit ; - IN: combinators.short-circuit.tests -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +[ 3 ] [ { [ 1 ] [ 2 ] [ 3 ] } 0&& ] unit-test +[ 5 ] [ 3 { [ 0 > ] [ odd? ] [ 2 + ] } 1&& ] unit-test +[ 30 ] [ 10 20 { [ + 0 > ] [ - even? ] [ + ] } 2&& ] unit-test -: must-be-t ( in -- ) [ t ] swap unit-test ; -: must-be-f ( in -- ) [ f ] swap unit-test ; +[ f ] [ { [ 1 ] [ f ] [ 3 ] } 0&& ] unit-test +[ f ] [ 3 { [ 0 > ] [ even? ] [ 2 + ] } 1&& ] unit-test +[ f ] [ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } 2&& ] unit-test -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +[ "factor" ] [ { [ 10 0 < ] [ f ] [ "factor" ] } 0|| ] unit-test +[ 11 ] [ 10 { [ odd? ] [ 100 > ] [ 1 + ] } 1|| ] unit-test +[ 30 ] [ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } 2|| ] unit-test +[ f ] [ { [ 10 0 < ] [ f ] [ 0 1 = ] } 0|| ] unit-test -[ { [ 1 ] [ 2 ] [ 3 ] } 0&& 3 = ] must-be-t -[ 3 { [ 0 > ] [ odd? ] [ 2 + ] } 1&& 5 = ] must-be-t -[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } 2&& 30 = ] must-be-t +: compiled-&& ( a -- ? ) { [ 0 > ] [ even? ] [ 2 + ] } 1&& ; -[ { [ 1 ] [ f ] [ 3 ] } 0&& 3 = ] must-be-f -[ 3 { [ 0 > ] [ even? ] [ 2 + ] } 1&& ] must-be-f -[ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } 2&& 30 = ] must-be-f +[ f ] [ 3 compiled-&& ] unit-test +[ 4 ] [ 2 compiled-&& ] unit-test -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -[ { [ 10 0 < ] [ f ] [ "factor" ] } 0|| "factor" = ] must-be-t - -[ 10 { [ odd? ] [ 100 > ] [ 1 + ] } 1|| 11 = ] must-be-t - -[ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } 2|| 30 = ] must-be-t - -[ { [ 10 0 < ] [ f ] [ 0 1 = ] } 0|| ] must-be-f - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: compiled-|| ( a b -- ? ) { [ + odd? ] [ + 100 > ] [ + ] } 2|| ; +[ 30 ] [ 10 20 compiled-|| ] unit-test +[ 2 ] [ 1 1 compiled-|| ] unit-test \ No newline at end of file diff --git a/basis/combinators/short-circuit/short-circuit.factor b/basis/combinators/short-circuit/short-circuit.factor index d8bab4dd34..a625a462af 100644 --- a/basis/combinators/short-circuit/short-circuit.factor +++ b/basis/combinators/short-circuit/short-circuit.factor @@ -12,10 +12,17 @@ MACRO:: n&& ( quots n -- quot ) n '[ _ nnip ] suffix 1array [ cond ] 3append ; -MACRO: 0&& ( quots -- quot ) '[ _ 0 n&& ] ; -MACRO: 1&& ( quots -- quot ) '[ _ 1 n&& ] ; -MACRO: 2&& ( quots -- quot ) '[ _ 2 n&& ] ; -MACRO: 3&& ( quots -- quot ) '[ _ 3 n&& ] ; + + +: 0&& ( quots -- ? ) [ ] unoptimized-&& ; +: 1&& ( obj quots -- ? ) [ with ] unoptimized-&& ; +: 2&& ( obj1 obj2 quots -- ? ) [ with with ] unoptimized-&& ; +: 3&& ( obj1 obj2 obj3 quots -- ? ) [ with with with ] unoptimized-&& ; MACRO:: n|| ( quots n -- quot ) [ f ] quots [| q | @@ -27,7 +34,14 @@ MACRO:: n|| ( quots n -- quot ) n '[ drop _ ndrop t ] [ f ] 2array suffix 1array [ cond ] 3append ; -MACRO: 0|| ( quots -- quot ) '[ _ 0 n|| ] ; -MACRO: 1|| ( quots -- quot ) '[ _ 1 n|| ] ; -MACRO: 2|| ( quots -- quot ) '[ _ 2 n|| ] ; -MACRO: 3|| ( quots -- quot ) '[ _ 3 n|| ] ; + + +: 0|| ( quots -- ? ) [ ] unoptimized-|| ; +: 1|| ( obj quots -- ? ) [ with ] unoptimized-|| ; +: 2|| ( obj1 obj2 quots -- ? ) [ with with ] unoptimized-|| ; +: 3|| ( obj1 obj2 obj3 quots -- ? ) [ with with with ] unoptimized-|| ; diff --git a/basis/combinators/short-circuit/smart/smart-tests.factor b/basis/combinators/short-circuit/smart/smart-tests.factor index 7ec4a0e657..c8cf8ffc1b 100644 --- a/basis/combinators/short-circuit/smart/smart-tests.factor +++ b/basis/combinators/short-circuit/smart/smart-tests.factor @@ -1,32 +1,18 @@ - USING: kernel math tools.test combinators.short-circuit.smart ; - IN: combinators.short-circuit.smart.tests -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +[ t ] [ { [ 1 ] [ 2 ] [ 3 ] } && 3 = ] unit-test +[ t ] [ 3 { [ 0 > ] [ odd? ] [ 2 + ] } && 5 = ] unit-test +[ t ] [ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] unit-test -: must-be-t ( in -- ) [ t ] swap unit-test ; -: must-be-f ( in -- ) [ f ] swap unit-test ; +[ f ] [ { [ 1 ] [ f ] [ 3 ] } && 3 = ] unit-test +[ f ] [ 3 { [ 0 > ] [ even? ] [ 2 + ] } && ] unit-test +[ f ] [ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] unit-test -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +[ t ] [ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] unit-test -[ { [ 1 ] [ 2 ] [ 3 ] } && 3 = ] must-be-t -[ 3 { [ 0 > ] [ odd? ] [ 2 + ] } && 5 = ] must-be-t -[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] must-be-t +[ t ] [ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ] unit-test -[ { [ 1 ] [ f ] [ 3 ] } && 3 = ] must-be-f -[ 3 { [ 0 > ] [ even? ] [ 2 + ] } && ] must-be-f -[ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] must-be-f - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -[ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] must-be-t - -[ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ] must-be-t - -[ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ] must-be-t - -[ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] must-be-f - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +[ t ] [ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ] unit-test +[ f ] [ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] unit-test diff --git a/basis/combinators/short-circuit/smart/smart.factor b/basis/combinators/short-circuit/smart/smart.factor index b80e7294d1..7264a07917 100644 --- a/basis/combinators/short-circuit/smart/smart.factor +++ b/basis/combinators/short-circuit/smart/smart.factor @@ -1,13 +1,15 @@ -USING: kernel sequences math stack-checker effects accessors macros -fry combinators.short-circuit ; +USING: kernel sequences math stack-checker effects accessors +macros fry combinators.short-circuit ; IN: combinators.short-circuit.smart > [ "Cannot determine arity" throw ] when - effect-height neg 1+ ; + dup terminated?>> [ cannot-determine-arity ] when + effect-height neg 1 + ; PRIVATE> diff --git a/basis/combinators/smart/smart-docs.factor b/basis/combinators/smart/smart-docs.factor index d8ee89ef2d..85545a730c 100644 --- a/basis/combinators/smart/smart-docs.factor +++ b/basis/combinators/smart/smart-docs.factor @@ -28,7 +28,7 @@ HELP: output>array { $example <" USING: combinators combinators.smart math prettyprint ; 9 [ - { [ 1- ] [ 1+ ] [ sq ] } cleave + { [ 1 - ] [ 1 + ] [ sq ] } cleave ] output>array ."> "{ 8 10 81 }" } @@ -71,7 +71,7 @@ HELP: sum-outputs { $examples { $example "USING: combinators.smart kernel math prettyprint ;" - "10 [ [ 1- ] [ 1+ ] bi ] sum-outputs ." + "10 [ [ 1 - ] [ 1 + ] bi ] sum-outputs ." "20" } } ; @@ -106,11 +106,21 @@ HELP: append-outputs-as { append-outputs append-outputs-as } related-words +HELP: drop-outputs +{ $values { "quot" quotation } } +{ $description "Calls a quotation and drops any values it leaves on the stack." } ; + +HELP: keep-inputs +{ $values { "quot" quotation } } +{ $description "Calls a quotation and preserves any values it takes off the stack." } ; + +{ drop-outputs keep-inputs } related-words ARTICLE: "combinators.smart" "Smart combinators" "A " { $emphasis "smart combinator" } " is a macro which reflects on the stack effect of an input quotation. The " { $vocab-link "combinators.smart" } " vocabulary implements a few simple smart combinators which look at the static stack effects of input quotations and generate code which produces or consumes the relevant number of stack values." $nl -"Call a quotation and discard all output values:" +"Call a quotation and discard all output values or preserve all input values:" { $subsection drop-outputs } +{ $subsection keep-inputs } "Take all input values from a sequence:" { $subsection inputarray ] must-infer [ { 9 11 } ] [ [ test-bi ] output>array ] unit-test @@ -46,4 +46,4 @@ IN: combinators.smart.tests [ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test -[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test \ No newline at end of file +[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor index 751a1f52e1..a00967742f 100644 --- a/basis/combinators/smart/smart.factor +++ b/basis/combinators/smart/smart.factor @@ -1,12 +1,15 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors fry generalizations kernel macros math.order -stack-checker math ; +stack-checker math sequences ; IN: combinators.smart MACRO: drop-outputs ( quot -- quot' ) dup infer out>> '[ @ _ ndrop ] ; +MACRO: keep-inputs ( quot -- quot' ) + dup infer in>> '[ _ _ nkeep ] ; + MACRO: output>sequence ( quot exemplar -- newquot ) [ dup infer out>> ] dip '[ @ _ _ nsequence ] ; @@ -39,3 +42,9 @@ MACRO: append-outputs-as ( quot exemplar -- newquot ) MACRO: append-outputs ( quot -- seq ) '[ _ { } append-outputs-as ] ; + +MACRO: preserving ( quot -- ) + [ infer in>> length ] keep '[ _ ndup @ ] ; + +MACRO: smart-if ( pred true false -- ) + '[ _ preserving _ _ if ] ; inline diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor deleted file mode 100644 index 79165f2c96..0000000000 --- a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor +++ /dev/null @@ -1 +0,0 @@ -IN: compiler.cfg.alias-analysis.tests diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index d0bb792f72..526df79cb3 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math namespaces assocs hashtables sequences arrays -accessors vectors combinators sets classes compiler.cfg +accessors vectors combinators sets classes cpu.architecture compiler.cfg compiler.cfg.registers compiler.cfg.instructions -compiler.cfg.copy-prop compiler.cfg.rpo -compiler.cfg.liveness compiler.cfg.local ; +compiler.cfg.copy-prop compiler.cfg.rpo compiler.cfg.liveness ; IN: compiler.cfg.alias-analysis ! We try to eliminate redundant slot operations using some simple heuristics. @@ -145,7 +144,7 @@ ERROR: vreg-has-no-slots vreg ; SYMBOL: ac-counter : next-ac ( -- n ) - ac-counter [ dup 1+ ] change ; + ac-counter [ dup 1 + ] change ; ! Alias class for objects which are loaded from the data stack ! or other object slots. We pessimistically assume that they @@ -197,7 +196,7 @@ M: ##set-slot insn-object obj>> resolve ; M: ##set-slot-imm insn-object obj>> resolve ; M: ##alien-global insn-object drop \ ##alien-global ; -: init-alias-analysis ( live-in -- ) +: init-alias-analysis ( insns -- insns' ) H{ } clone histories set H{ } clone vregs>acs set H{ } clone acs>vregs set @@ -208,7 +207,7 @@ M: ##alien-global insn-object drop \ ##alien-global ; 0 ac-counter set next-ac heap-ac set - [ set-heap-ac ] each ; + dup local-live-in [ set-heap-ac ] each ; GENERIC: analyze-aliases* ( insn -- insn' ) @@ -227,7 +226,7 @@ M: ##read analyze-aliases* call-next-method dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri 2dup live-slot dup [ - 2nip \ ##copy new-insn analyze-aliases* nip + 2nip any-rep \ ##copy new-insn analyze-aliases* nip ] [ drop remember-slot ] if ; @@ -280,9 +279,10 @@ M: insn eliminate-dead-stores* ; [ insn# set eliminate-dead-stores* ] map-index sift ; : alias-analysis-step ( insns -- insns' ) + init-alias-analysis analyze-aliases compute-live-stores eliminate-dead-stores ; : alias-analysis ( cfg -- cfg' ) - [ init-alias-analysis ] [ alias-analysis-step ] local-optimization ; \ No newline at end of file + [ alias-analysis-step ] local-optimization ; diff --git a/basis/compiler/cfg/block-joining/block-joining.factor b/basis/compiler/cfg/block-joining/block-joining.factor new file mode 100644 index 0000000000..60528a61bb --- /dev/null +++ b/basis/compiler/cfg/block-joining/block-joining.factor @@ -0,0 +1,37 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators.short-circuit kernel sequences math +compiler.utilities compiler.cfg compiler.cfg.instructions compiler.cfg.rpo +compiler.cfg.predecessors compiler.cfg.utilities ; +IN: compiler.cfg.block-joining + +! Joining blocks that are not calls and are connected by a single CFG edge. +! This pass does not update ##phi nodes and should therefore only run +! before stack analysis. +: join-block? ( bb -- ? ) + { + [ kill-block? not ] + [ predecessors>> length 1 = ] + [ predecessor kill-block? not ] + [ predecessor successors>> length 1 = ] + [ [ predecessor ] keep back-edge? not ] + } 1&& ; + +: join-instructions ( bb pred -- ) + [ instructions>> ] bi@ dup pop* push-all ; + +: update-successors ( bb pred -- ) + [ successors>> ] dip (>>successors) ; + +: join-block ( bb pred -- ) + [ join-instructions ] [ update-successors ] 2bi ; + +: join-blocks ( cfg -- cfg' ) + needs-predecessors + + dup post-order [ + dup join-block? + [ dup predecessor join-block ] [ drop ] if + ] each + + cfg-changed predecessors-changed ; diff --git a/basis/compiler/cfg/branch-splitting/authors.txt b/basis/compiler/cfg/branch-splitting/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/compiler/cfg/branch-splitting/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor b/basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor new file mode 100644 index 0000000000..f3790fd338 --- /dev/null +++ b/basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor @@ -0,0 +1,85 @@ +USING: accessors assocs compiler.cfg +compiler.cfg.branch-splitting compiler.cfg.debugger +compiler.cfg.predecessors compiler.cfg.rpo compiler.cfg.instructions fry kernel +tools.test namespaces sequences vectors ; +IN: compiler.cfg.branch-splitting.tests + +: get-predecessors ( cfg -- assoc ) + H{ } clone [ '[ [ predecessors>> ] keep _ set-at ] each-basic-block ] keep ; + +: check-predecessors ( cfg -- ) + [ get-predecessors ] + [ needs-predecessors drop ] + [ get-predecessors ] tri assert= ; + +: check-branch-splitting ( cfg -- ) + needs-predecessors + split-branches + check-predecessors ; + +: test-branch-splitting ( -- ) + cfg new 0 get >>entry check-branch-splitting ; + +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 + +test-diamond + +[ ] [ test-branch-splitting ] unit-test + +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 + +V{ T{ ##branch } } 5 test-bb + +0 { 1 2 } edges + +1 { 3 4 } edges + +2 { 3 4 } edges + +[ ] [ test-branch-splitting ] unit-test + +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 4 } edges + +2 4 edge + +[ ] [ test-branch-splitting ] unit-test + +V{ T{ ##branch } } 0 test-bb + +V{ T{ ##branch } } 1 test-bb + +V{ T{ ##branch } } 2 test-bb + +0 { 1 2 } edges + +1 2 edge + +[ ] [ test-branch-splitting ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/branch-splitting/branch-splitting.factor b/basis/compiler/cfg/branch-splitting/branch-splitting.factor new file mode 100644 index 0000000000..1daabf6f0e --- /dev/null +++ b/basis/compiler/cfg/branch-splitting/branch-splitting.factor @@ -0,0 +1,90 @@ +! Copyright (C) 2009 Doug Coleman, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators.short-circuit kernel math math.order +sequences assocs namespaces vectors fry arrays splitting +compiler.cfg.def-use compiler.cfg compiler.cfg.rpo compiler.cfg.predecessors +compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ; +IN: compiler.cfg.branch-splitting + +: clone-instructions ( insns -- insns' ) + [ clone dup rename-insn-temps ] map ; + +: clone-basic-block ( bb -- bb' ) + ! The new block temporarily gets the same RPO number as the old one, + ! until the next time RPO is computed. This is just to make + ! 'back-edge?' work. + + swap + [ instructions>> clone-instructions >>instructions ] + [ successors>> clone >>successors ] + [ number>> >>number ] + tri ; + +: new-blocks ( bb -- copies ) + dup predecessors>> [ + [ clone-basic-block ] dip + 1vector >>predecessors + ] with map ; + +: update-predecessor-successor ( pred copy old-bb -- ) + '[ + [ _ _ 3dup nip eq? [ drop nip ] [ 2drop ] if ] map + ] change-successors drop ; + +: update-predecessor-successors ( copies old-bb -- ) + [ predecessors>> swap ] keep + '[ _ update-predecessor-successor ] 2each ; + +: update-successor-predecessor ( copies old-bb succ -- ) + [ + swap 1array split swap join V{ } like + ] change-predecessors drop ; + +: update-successor-predecessors ( copies old-bb -- ) + dup successors>> [ + update-successor-predecessor + ] with with each ; + +: split-branch ( bb -- ) + [ new-blocks ] keep + [ update-predecessor-successors ] + [ update-successor-predecessors ] + 2bi ; + +UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ; + +: split-instructions? ( insns -- ? ) [ irrelevant? not ] count 5 <= ; + +: short-tail-block? ( bb -- ? ) + [ successors>> empty? ] [ instructions>> length 2 = ] bi and ; + +: short-block? ( bb -- ? ) + ! If block is empty, always split + [ predecessors>> length ] [ instructions>> length 1 - ] bi * 10 <= ; + +: cond-cond-block? ( bb -- ? ) + { + [ predecessors>> length 2 = ] + [ successors>> length 2 = ] + [ instructions>> length 20 <= ] + } 1&& ; + +: split-branch? ( bb -- ? ) + dup loop-entry? [ drop f ] [ + dup predecessors>> length 1 <= [ drop f ] [ + { + [ short-block? ] + [ short-tail-block? ] + [ cond-cond-block? ] + } 1|| + ] if + ] if ; + +: split-branches ( cfg -- cfg' ) + needs-predecessors + + dup [ + dup split-branch? [ split-branch ] [ drop ] if + ] each-basic-block + + cfg-changed ; diff --git a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor index e5be2d9eb9..90992fcc96 100644 --- a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor +++ b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor @@ -1,22 +1,25 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces accessors math.order assocs kernel sequences -combinators make classes words cpu.architecture +combinators make classes words cpu.architecture layouts compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stack-frame ; IN: compiler.cfg.build-stack-frame SYMBOL: frame-required? -SYMBOL: spill-counts - GENERIC: compute-stack-frame* ( insn -- ) : request-stack-frame ( stack-frame -- ) + frame-required? on stack-frame [ max-stack-frame ] change ; -M: ##stack-frame compute-stack-frame* - frame-required? on +UNION: stack-frame-insn + ##alien-invoke + ##alien-indirect + ##alien-callback ; + +M: stack-frame-insn compute-stack-frame* stack-frame>> request-stack-frame ; M: ##call compute-stack-frame* @@ -24,11 +27,11 @@ M: ##call compute-stack-frame* M: _gc compute-stack-frame* frame-required? on - stack-frame new swap gc-root-size>> >>gc-root-size + stack-frame new swap tagged-values>> length cells >>gc-root-size request-stack-frame ; -M: _spill-counts compute-stack-frame* - counts>> stack-frame get (>>spill-counts) ; +M: _spill-area-size compute-stack-frame* + n>> stack-frame get (>>spill-area-size) ; M: insn compute-stack-frame* class frame-required? word-prop [ @@ -36,23 +39,17 @@ M: insn compute-stack-frame* ] when ; \ _spill t frame-required? set-word-prop -\ ##fixnum-add t frame-required? set-word-prop -\ ##fixnum-sub t frame-required? set-word-prop -\ ##fixnum-mul t frame-required? set-word-prop -\ ##fixnum-add-tail f frame-required? set-word-prop -\ ##fixnum-sub-tail f frame-required? set-word-prop -\ ##fixnum-mul-tail f frame-required? set-word-prop +\ ##unary-float-function t frame-required? set-word-prop +\ ##binary-float-function t frame-required? set-word-prop : compute-stack-frame ( insns -- ) frame-required? off - T{ stack-frame } clone stack-frame set + stack-frame new stack-frame set [ compute-stack-frame* ] each stack-frame get dup stack-frame-size >>total-size drop ; GENERIC: insert-pro/epilogues* ( insn -- ) -M: ##stack-frame insert-pro/epilogues* drop ; - M: ##prologue insert-pro/epilogues* drop frame-required? get [ stack-frame get _prologue ] when ; diff --git a/basis/compiler/cfg/builder/blocks/blocks.factor b/basis/compiler/cfg/builder/blocks/blocks.factor new file mode 100644 index 0000000000..8e96255bdd --- /dev/null +++ b/basis/compiler/cfg/builder/blocks/blocks.factor @@ -0,0 +1,74 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays fry kernel make math namespaces sequences +compiler.cfg compiler.cfg.instructions compiler.cfg.stacks +compiler.cfg.stacks.local ; +IN: compiler.cfg.builder.blocks + +: set-basic-block ( basic-block -- ) + [ basic-block set ] [ instructions>> building set ] bi + begin-local-analysis ; + +: initial-basic-block ( -- ) + set-basic-block ; + +: end-basic-block ( -- ) + basic-block get [ end-local-analysis ] when + building off + basic-block off ; + +: (begin-basic-block) ( -- ) + + basic-block get [ dupd successors>> push ] when* + set-basic-block ; + +: begin-basic-block ( -- ) + basic-block get [ end-local-analysis ] when + (begin-basic-block) ; + +: emit-trivial-block ( quot -- ) + ##branch begin-basic-block + call + ##branch begin-basic-block ; inline + +: call-height ( #call -- n ) + [ out-d>> length ] [ in-d>> length ] bi - ; + +: emit-primitive ( node -- ) + [ + [ word>> ##call ] + [ call-height adjust-d ] bi + ] emit-trivial-block ; + +: begin-branch ( -- ) clone-current-height (begin-basic-block) ; + +: end-branch ( -- pair/f ) + ! pair is { final-bb final-height } + basic-block get dup [ + ##branch + end-local-analysis + current-height get clone 2array + ] when ; + +: with-branch ( quot -- pair/f ) + [ begin-branch call end-branch ] with-scope ; inline + +: set-successors ( branches -- ) + ! Set the successor of each branch's final basic block to the + ! current block. + basic-block get dup [ + '[ [ [ _ ] dip first successors>> push ] when* ] each + ] [ 2drop ] if ; + +: merge-heights ( branches -- ) + ! If all elements are f, that means every branch ended with a backward + ! jump so the height is irrelevant since this block is unreachable. + [ ] find nip [ second current-height set ] [ end-basic-block ] if* ; + +: emit-conditional ( branches -- ) + ! branchies is a sequence of pairs as above + end-basic-block + [ merge-heights begin-basic-block ] + [ set-successors ] + bi ; + diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index 58eae8181b..4e0c2aa112 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -1,12 +1,31 @@ +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 +strings.private accessors compiler.cfg.instructions ; IN: compiler.cfg.builder.tests -USING: tools.test kernel sequences -words sequences.private fry prettyprint alien alien.accessors -math.private compiler.tree.builder compiler.tree.optimizer -compiler.cfg.builder compiler.cfg.debugger arrays locals byte-arrays -kernel.private math ; ! Just ensure that various CFGs build correctly. -: unit-test-cfg ( quot -- ) '[ _ test-cfg drop ] [ ] swap unit-test ; +: unit-test-cfg ( quot -- ) + '[ _ test-cfg [ [ optimize-cfg check-cfg ] with-cfg ] each ] [ ] swap unit-test ; + +: blahblah ( nodes -- ? ) + { fixnum } declare [ + dup 3 bitand 1 = [ drop t ] [ + dup 3 bitand 2 = [ + blahblah + ] [ drop f ] if + ] if + ] any? ; inline recursive + +: more? ( x -- ? ) ; + +: test-case-1 ( -- ? ) f ; + +: test-case-2 ( -- ) + test-case-1 [ test-case-2 ] [ ] if ; inline recursive { [ ] @@ -18,10 +37,14 @@ kernel.private math ; [ 3 fixnum+fast ] [ fixnum*fast ] [ 3 fixnum*fast ] + [ 3 swap fixnum*fast ] [ fixnum-shift-fast ] [ 10 fixnum-shift-fast ] [ -10 fixnum-shift-fast ] [ 0 fixnum-shift-fast ] + [ 10 swap fixnum-shift-fast ] + [ -10 swap fixnum-shift-fast ] + [ 0 swap fixnum-shift-fast ] [ fixnum-bitnot ] [ eq? ] [ "hi" eq? ] @@ -45,6 +68,39 @@ kernel.private math ; [ "int" f "malloc" { "int" } alien-invoke ] [ "int" { "int" } "cdecl" alien-indirect ] [ "int" { "int" } "cdecl" [ ] alien-callback ] + [ swap - + * ] + [ swap slot ] + [ blahblah ] + [ 1000 [ dup [ reverse ] when ] times ] + [ 1array ] + [ 1 2 ? ] + [ { array } declare [ ] map ] + [ { array } declare dup 1 slot [ 1 slot ] when ] + [ [ dup more? ] [ dup ] produce ] + [ vector new over test-case-1 [ test-case-2 ] [ ] if ] + [ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ] + [ + { fixnum sbuf } declare 2dup 3 slot fixnum> [ + over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot + ] [ ] if + ] + [ [ 2 fixnum* ] when 3 ] + [ [ 2 fixnum+ ] when 3 ] + [ [ 2 fixnum- ] when 3 ] + [ 10000 [ ] times ] + [ + over integer? [ + over dup 16 <-integer-fixnum + [ 0 >=-integer-fixnum ] [ drop f ] if [ + nip dup + [ ] [ ] if + ] [ 2drop f ] if + ] [ 2drop f ] if + ] + [ + pick 10 fixnum>= [ [ 123 fixnum-bitand ] 2dip ] [ ] if + set-string-nth-fast + ] } [ unit-test-cfg ] each @@ -101,3 +157,37 @@ kernel.private math ; { pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-cfg { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg ] each + +: contains-insn? ( quot insn-check -- ? ) + [ test-mr [ instructions>> ] map ] dip + '[ _ any? ] any? ; inline + +[ t ] [ [ swap ] [ ##replace? ] contains-insn? ] unit-test + +[ f ] [ [ swap swap ] [ ##replace? ] contains-insn? ] unit-test + +[ t ] [ + [ { fixnum byte-array fixnum } declare set-alien-unsigned-1 ] + [ ##set-alien-integer-1? ] contains-insn? +] unit-test + +[ t ] [ + [ { fixnum byte-array fixnum } declare [ dup * dup * ] 2dip set-alien-unsigned-1 ] + [ ##set-alien-integer-1? ] contains-insn? +] unit-test + +[ f ] [ + [ { byte-array fixnum } declare set-alien-unsigned-1 ] + [ ##set-alien-integer-1? ] contains-insn? +] unit-test + +[ f ] [ + [ 1000 [ ] times ] + [ [ ##peek? ] [ ##replace? ] bi or ] contains-insn? +] unit-test + +[ f t ] [ + [ { fixnum simple-alien } declare 0 alien-cell ] + [ [ ##unbox-any-c-ptr? ] contains-insn? ] + [ [ ##slot-imm? ] contains-insn? ] bi +] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index d323263fc7..7b74d1c258 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs combinators hashtables kernel math fry namespaces make sequences words byte-arrays @@ -10,63 +10,54 @@ compiler.tree.combinators compiler.tree.propagation.info compiler.cfg compiler.cfg.hats -compiler.cfg.stacks -compiler.cfg.iterator compiler.cfg.utilities compiler.cfg.registers compiler.cfg.intrinsics +compiler.cfg.comparisons compiler.cfg.stack-frame compiler.cfg.instructions +compiler.cfg.predecessors +compiler.cfg.builder.blocks +compiler.cfg.stacks +compiler.cfg.stacks.local compiler.alien ; IN: compiler.cfg.builder -! Convert tree SSA IR to CFG SSA IR. +! Convert tree SSA IR to CFG IR. The result is not in SSA form; this is +! constructed later by calling compiler.cfg.ssa.construction:construct-ssa. SYMBOL: procedures -SYMBOL: current-word -SYMBOL: current-label SYMBOL: loops -SYMBOL: first-basic-block -! Basic block after prologue, makes recursion faster -SYMBOL: current-label-start - -: add-procedure ( -- ) - basic-block get current-word get current-label get - procedures get push ; +: begin-cfg ( word label -- cfg ) + initial-basic-block + H{ } clone loops set + [ basic-block get ] 2dip dup cfg set ; : begin-procedure ( word label -- ) - end-basic-block - begin-basic-block - H{ } clone loops set - current-label set - current-word set - add-procedure ; + begin-cfg procedures get push ; : with-cfg-builder ( nodes word label quot -- ) - '[ begin-procedure @ ] with-scope ; inline + '[ + begin-stack-analysis + begin-procedure + @ + end-stack-analysis + ] with-scope ; inline -GENERIC: emit-node ( node -- next ) - -: check-basic-block ( node -- node' ) - basic-block get [ drop f ] unless ; inline +GENERIC: emit-node ( node -- ) : emit-nodes ( nodes -- ) - [ current-node emit-node check-basic-block ] iterate-nodes ; + [ basic-block get [ emit-node ] [ drop ] if ] each ; : begin-word ( -- ) - #! We store the basic block after the prologue as a loop - #! labeled by the current word, so that self-recursive - #! calls can skip an epilogue/prologue. ##prologue ##branch - begin-basic-block - basic-block get first-basic-block set ; + begin-basic-block ; : (build-cfg) ( nodes word label -- ) [ begin-word - V{ } clone node-stack set emit-nodes ] with-cfg-builder ; @@ -77,57 +68,42 @@ GENERIC: emit-node ( node -- next ) ] with-variable ] keep ; -: local-recursive-call ( basic-block -- next ) +: emit-loop-call ( basic-block -- ) ##branch basic-block get successors>> push - stop-iterating ; + end-basic-block ; -: emit-call ( word height -- next ) - { - { [ over loops get key? ] [ drop loops get at local-recursive-call ] } - { [ terminate-call? ] [ ##call stop-iterating ] } - { [ tail-call? not ] [ ##call ##branch begin-basic-block iterate-next ] } - { [ dup current-label get eq? ] [ 2drop first-basic-block get local-recursive-call ] } - [ drop ##epilogue ##jump stop-iterating ] - } cond ; +: emit-call ( word height -- ) + over loops get key? + [ drop loops get at emit-loop-call ] + [ [ [ ##call ] [ adjust-d ] bi* ] emit-trivial-block ] + if ; ! #recursive : recursive-height ( #recursive -- n ) [ label>> return>> in-d>> length ] [ in-d>> length ] bi - ; -: emit-recursive ( #recursive -- next ) +: emit-recursive ( #recursive -- ) [ [ label>> id>> ] [ recursive-height ] bi emit-call ] [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ; : remember-loop ( label -- ) basic-block get swap loops get set-at ; -: emit-loop ( node -- next ) - ##loop-entry +: emit-loop ( node -- ) ##branch begin-basic-block - [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi - iterate-next ; + [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi ; M: #recursive emit-node dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ; ! #if : emit-branch ( obj -- final-bb ) - [ - begin-basic-block - emit-nodes - basic-block get dup [ ##branch ] when - ] with-scope ; + [ emit-nodes ] with-branch ; : emit-if ( node -- ) - children>> [ emit-branch ] map - end-basic-block - begin-basic-block - basic-block get '[ [ _ swap successors>> push ] when* ] each ; - -: ##branch-t ( vreg -- ) - \ f tag-number cc/= ##compare-imm-branch ; + children>> [ emit-branch ] map emit-conditional ; : trivial-branch? ( nodes -- value ? ) dup length 1 = [ @@ -152,16 +128,24 @@ M: #recursive emit-node : emit-trivial-not-if ( -- ) ds-pop \ f tag-number cc= ^^compare-imm ds-push ; +: emit-actual-if ( #if -- ) + ! Inputs to the final instruction need to be copied because of + ! loc>vreg sync + ds-pop ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ; + M: #if emit-node { { [ dup trivial-if? ] [ drop emit-trivial-if ] } { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] } - [ ds-pop ##branch-t emit-if ] - } cond iterate-next ; + [ emit-actual-if ] + } cond ; ! #dispatch M: #dispatch emit-node - ds-pop ^^offset>slot i ##dispatch emit-if iterate-next ; + ! Inputs to the final instruction need to be copied because of + ! loc>vreg sync. ^^offset>slot always returns a fresh vreg, + ! though. + ds-pop ^^offset>slot next-vreg ##dispatch emit-if ; ! #call M: #call emit-node @@ -173,29 +157,47 @@ M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ; ! #push M: #push emit-node - literal>> ^^load-literal ds-push iterate-next ; + literal>> ^^load-literal ds-push ; ! #shuffle + +! Even though low level IR has its own dead code elimination pass, +! we try not to introduce useless ##peeks here, since this reduces +! the accuracy of global stack analysis. + +: make-input-map ( #shuffle -- assoc ) + ! Assoc maps high-level IR values to stack locations. + [ + [ in-d>> [ swap set ] each-index ] + [ in-r>> [ swap set ] each-index ] bi + ] H{ } make-assoc ; + +: make-output-seq ( values mapping input-map -- vregs ) + '[ _ at _ at peek-loc ] map ; + +: load-shuffle ( #shuffle mapping input-map -- ds-vregs rs-vregs ) + [ [ out-d>> ] 2dip make-output-seq ] + [ [ out-r>> ] 2dip make-output-seq ] 3bi ; + +: store-shuffle ( #shuffle ds-vregs rs-vregs -- ) + [ [ in-d>> length neg inc-d ] dip ds-store ] + [ [ in-r>> length neg inc-r ] dip rs-store ] + bi-curry* bi ; + M: #shuffle emit-node - dup - H{ } clone - [ [ in-d>> [ length ds-load ] keep ] dip '[ _ set-at ] 2each ] - [ [ in-r>> [ length rs-load ] keep ] dip '[ _ set-at ] 2each ] - [ nip ] 2tri - [ [ [ out-d>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map ds-store ] - [ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi - iterate-next ; + dup dup [ mapping>> ] [ make-input-map ] bi load-shuffle store-shuffle ; ! #return -M: #return emit-node - drop ##epilogue ##return stop-iterating ; +: emit-return ( -- ) + ##branch begin-basic-block ##epilogue ##return ; + +M: #return emit-node drop emit-return ; M: #return-recursive emit-node - label>> id>> loops get key? - [ iterate-next ] [ ##epilogue ##return stop-iterating ] if ; + label>> id>> loops get key? [ emit-return ] unless ; ! #terminate -M: #terminate emit-node drop stop-iterating ; +M: #terminate emit-node drop ##no-tco end-basic-block ; ! FFI : return-size ( ctype -- n ) @@ -212,12 +214,14 @@ M: #terminate emit-node drop stop-iterating ; [ return>> return-size >>return ] [ alien-parameters parameter-sizes drop >>params ] bi ; -: alien-stack-frame ( params -- ) - ##stack-frame ; +: alien-node-height ( params -- ) + [ out-d>> length ] [ in-d>> length ] bi - adjust-d ; -: emit-alien-node ( node quot -- next ) - [ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi - ##branch begin-basic-block iterate-next ; inline +: emit-alien-node ( node quot -- ) + [ + [ params>> dup dup ] dip call + alien-node-height + ] emit-trivial-block ; inline M: #alien-invoke emit-node [ ##alien-invoke ] emit-alien-node ; @@ -229,17 +233,18 @@ M: #alien-callback emit-node dup params>> xt>> dup [ ##prologue - dup [ ##alien-callback ] emit-alien-node drop + dup [ ##alien-callback ] emit-alien-node ##epilogue params>> ##callback-return - ] with-cfg-builder - iterate-next ; + ] with-cfg-builder ; ! No-op nodes -M: #introduce emit-node drop iterate-next ; +M: #introduce emit-node drop ; -M: #copy emit-node drop iterate-next ; +M: #copy emit-node drop ; -M: #enter-recursive emit-node drop iterate-next ; +M: #enter-recursive emit-node drop ; -M: #phi emit-node drop iterate-next ; +M: #phi emit-node drop ; + +M: #declare emit-node drop ; \ No newline at end of file diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor index dabc7338d2..369e6ebc32 100644 --- a/basis/compiler/cfg/cfg.factor +++ b/basis/compiler/cfg/cfg.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel arrays vectors accessors -namespaces math make fry sequences ; +USING: kernel math vectors arrays accessors namespaces ; IN: compiler.cfg TUPLE: basic-block < identity-tuple @@ -20,16 +19,28 @@ M: basic-block hashcode* nip id>> ; V{ } clone >>predecessors \ basic-block counter >>id ; -: add-instructions ( bb quot -- ) - [ instructions>> building ] dip '[ - building get pop - _ dip - building get push - ] with-variable ; inline +TUPLE: cfg { entry basic-block } word label +spill-area-size reps +post-order linear-order +predecessors-valid? dominance-valid? loops-valid? ; -TUPLE: cfg { entry basic-block } word label spill-counts post-order ; +: ( entry word label -- cfg ) + cfg new + swap >>label + swap >>word + swap >>entry ; -: ( entry word label -- cfg ) f f cfg boa ; +: cfg-changed ( cfg -- cfg ) + f >>post-order + f >>linear-order + f >>dominance-valid? + f >>loops-valid? ; inline + +: predecessors-changed ( cfg -- cfg ) + f >>predecessors-valid? ; + +: with-cfg ( cfg quot: ( cfg -- ) -- ) + [ dup cfg ] dip with-variable ; inline TUPLE: mr { instructions array } word label ; diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index 4f215f1dc8..07e6cc8cea 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -1,34 +1,44 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel compiler.cfg.instructions compiler.cfg.rpo -compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.liveness -combinators.short-circuit accessors math sequences sets assocs ; +compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.utilities +compiler.cfg.mr combinators.short-circuit accessors math +sequences sets assocs ; IN: compiler.cfg.checker -ERROR: last-insn-not-a-jump insn ; +ERROR: bad-kill-block bb ; + +: check-kill-block ( bb -- ) + dup instructions>> first2 + swap ##epilogue? [ + { [ ##return? ] [ ##callback-return? ] [ ##jump? ] } 1|| + ] [ ##branch? ] if + [ drop ] [ bad-kill-block ] if ; + +ERROR: last-insn-not-a-jump bb ; : check-last-instruction ( bb -- ) - last dup { + dup instructions>> last { [ ##branch? ] [ ##dispatch? ] [ ##conditional-branch? ] [ ##compare-imm-branch? ] - [ ##return? ] - [ ##callback-return? ] - [ ##jump? ] - [ ##fixnum-add-tail? ] - [ ##fixnum-sub-tail? ] - [ ##fixnum-mul-tail? ] - [ ##call? ] + [ ##fixnum-add? ] + [ ##fixnum-sub? ] + [ ##fixnum-mul? ] + [ ##no-tco? ] } 1|| [ drop ] [ last-insn-not-a-jump ] if ; -ERROR: bad-loop-entry ; +ERROR: bad-kill-insn bb ; -: check-loop-entry ( bb -- ) - dup length 2 >= [ - 2 head* [ ##loop-entry? ] any? - [ bad-loop-entry ] when - ] [ drop ] if ; +: check-kill-instructions ( bb -- ) + dup instructions>> [ kill-vreg-insn? ] any? + [ bad-kill-insn ] [ drop ] if ; + +: check-normal-block ( bb -- ) + [ check-last-instruction ] + [ check-kill-instructions ] + bi ; ERROR: bad-successors ; @@ -37,10 +47,9 @@ ERROR: bad-successors ; [ bad-successors ] unless ; : check-basic-block ( bb -- ) - [ instructions>> check-last-instruction ] - [ instructions>> check-loop-entry ] + [ dup kill-block? [ check-kill-block ] [ check-normal-block ] if ] [ check-successors ] - tri ; + bi ; ERROR: bad-live-in ; @@ -50,12 +59,10 @@ ERROR: undefined-values uses defs ; ! Check that every used register has a definition instructions>> [ [ uses-vregs ] map concat ] - [ [ [ defs-vregs ] [ temp-vregs ] bi append ] map concat ] bi + [ [ [ temp-vregs ] [ defs-vreg ] bi [ suffix ] when* ] map concat ] bi 2dup subset? [ 2drop ] [ undefined-values ] if ; : check-cfg ( cfg -- ) - compute-liveness - [ entry>> live-in assoc-empty? [ bad-live-in ] unless ] [ [ check-basic-block ] each-basic-block ] - [ flatten-cfg check-mr ] - tri ; + [ build-mr check-mr ] + bi ; diff --git a/basis/compiler/cfg/comparisons/comparisons.factor b/basis/compiler/cfg/comparisons/comparisons.factor new file mode 100644 index 0000000000..e7c19e7206 --- /dev/null +++ b/basis/compiler/cfg/comparisons/comparisons.factor @@ -0,0 +1,83 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs math.order sequences ; +IN: compiler.cfg.comparisons + +SYMBOL: +unordered+ + +SYMBOLS: + cc< cc<= cc= cc> cc>= cc<> cc<>= + cc/< cc/<= cc/= cc/> cc/>= cc/<> cc/<>= ; + +: negate-cc ( cc -- cc' ) + H{ + { cc< cc/< } + { cc<= cc/<= } + { cc> cc/> } + { cc>= cc/>= } + { cc= cc/= } + { cc<> cc/<> } + { cc<>= cc/<>= } + { cc/< cc< } + { cc/<= cc<= } + { cc/> cc> } + { cc/>= cc>= } + { cc/= cc= } + { cc/<> cc<> } + { cc/<>= cc<>= } + } at ; + +: swap-cc ( cc -- cc' ) + H{ + { cc< cc> } + { cc<= cc>= } + { cc> cc< } + { cc>= cc<= } + { cc= cc= } + { cc<> cc<> } + { cc<>= cc<>= } + { cc/< cc/> } + { cc/<= cc/>= } + { cc/> cc/< } + { cc/>= cc/<= } + { cc/= cc/= } + { cc/<> cc/<> } + { cc/<>= cc/<>= } + } at ; + +: order-cc ( cc -- cc' ) + H{ + { cc< cc< } + { cc<= cc<= } + { cc> cc> } + { cc>= cc>= } + { cc= cc= } + { cc<> cc/= } + { cc<>= t } + { cc/< cc>= } + { cc/<= cc> } + { cc/> cc<= } + { cc/>= cc< } + { cc/= cc/= } + { cc/<> cc= } + { cc/<>= f } + } at ; + +: evaluate-cc ( result cc -- ? ) + H{ + { cc< { +lt+ } } + { cc<= { +lt+ +eq+ } } + { cc= { +eq+ } } + { cc>= { +eq+ +gt+ } } + { cc> { +gt+ } } + { cc<> { +lt+ +gt+ } } + { cc<>= { +lt+ +eq+ +gt+ } } + { cc/< { +eq+ +gt+ +unordered+ } } + { cc/<= { +gt+ +unordered+ } } + { cc/= { +lt+ +gt+ +unordered+ } } + { cc/>= { +lt+ +unordered+ } } + { cc/> { +lt+ +eq+ +unordered+ } } + { cc/<> { +eq+ +unordered+ } } + { cc/<>= { +unordered+ } } + } at memq? ; + diff --git a/basis/compiler/cfg/copy-prop/copy-prop.factor b/basis/compiler/cfg/copy-prop/copy-prop.factor index d526ea9c1d..6919ba8b9b 100644 --- a/basis/compiler/cfg/copy-prop/copy-prop.factor +++ b/basis/compiler/cfg/copy-prop/copy-prop.factor @@ -1,12 +1,78 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces assocs accessors ; +USING: kernel namespaces assocs accessors sequences grouping +combinators compiler.cfg.rpo compiler.cfg.renaming +compiler.cfg.instructions compiler.cfg.predecessors ; IN: compiler.cfg.copy-prop +! The first three definitions are also used in compiler.cfg.alias-analysis. SYMBOL: copies -: resolve ( vreg -- vreg ) - [ copies get at ] keep or ; +! Initialized per-basic-block; a mapping from inputs to dst for eliminating +! redundant phi instructions +SYMBOL: phis -: record-copy ( insn -- ) - [ src>> resolve ] [ dst>> ] bi copies get set-at ; inline +: 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 + +> ] [ inputs>> values [ resolve ] map ] bi + { + { [ dup all-equal? ] [ useless-phi ] } + { [ dup phis get key? ] [ redundant-phi ] } + [ record-phi ] + } cond ; + +M: insn visit-insn drop ; + +: collect-copies ( cfg -- ) + H{ } clone copies set + [ + H{ } clone phis set + instructions>> [ visit-insn ] each + ] each-basic-block ; + +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 ; + +M: insn update-insn rename-insn-uses t ; + +: rename-copies ( cfg -- ) + copies get dup assoc-empty? [ 2drop ] [ + renamings set + [ + instructions>> [ update-insn ] filter-here + ] each-basic-block + ] if ; + +PRIVATE> + +: copy-propagation ( cfg -- cfg' ) + needs-predecessors + + [ collect-copies ] + [ rename-copies ] + [ ] + tri ; diff --git a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor new file mode 100644 index 0000000000..dde44fd15d --- /dev/null +++ b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor @@ -0,0 +1,145 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs deques dlists kernel locals sequences lexer +namespaces functors compiler.cfg.rpo compiler.cfg.utilities +compiler.cfg.predecessors compiler.cfg ; +IN: compiler.cfg.dataflow-analysis + +GENERIC: join-sets ( sets bb dfa -- set ) +GENERIC: transfer-set ( in-set bb dfa -- out-set ) +GENERIC: block-order ( cfg dfa -- bbs ) +GENERIC: successors ( bb dfa -- seq ) +GENERIC: predecessors ( bb dfa -- seq ) + + ( cfg dfa -- queue ) + block-order [ push-all-front ] keep ; + +GENERIC# compute-in-set 2 ( bb out-sets dfa -- set ) + +M: kill-block compute-in-set 3drop f ; + +M:: basic-block compute-in-set ( bb out-sets dfa -- set ) + ! Only consider initialized sets. + bb dfa predecessors + [ out-sets key? ] filter + [ out-sets at ] map + bb dfa join-sets ; + +:: update-in-set ( bb in-sets out-sets dfa -- ? ) + bb out-sets dfa compute-in-set + bb in-sets maybe-set-at ; inline + +GENERIC# compute-out-set 2 ( bb out-sets dfa -- set ) + +M: kill-block compute-out-set 3drop f ; + +M:: basic-block compute-out-set ( bb in-sets dfa -- set ) + bb in-sets at bb dfa transfer-set ; + +:: update-out-set ( bb in-sets out-sets dfa -- ? ) + bb in-sets dfa compute-out-set + bb out-sets maybe-set-at ; inline + +:: dfa-step ( bb in-sets out-sets dfa work-list -- ) + bb in-sets out-sets dfa update-in-set [ + bb in-sets out-sets dfa update-out-set [ + bb dfa successors work-list push-all-front + ] when + ] when ; inline + +:: run-dataflow-analysis ( cfg dfa -- in-sets out-sets ) + cfg needs-predecessors drop + H{ } clone :> in-sets + H{ } clone :> out-sets + cfg dfa :> work-list + work-list [ in-sets out-sets dfa work-list dfa-step ] slurp-deque + in-sets + out-sets ; inline + +M: dataflow-analysis join-sets 2drop assoc-refine ; + +FUNCTOR: define-analysis ( name -- ) + +name-analysis DEFINES-CLASS ${name}-analysis +name-ins DEFINES ${name}-ins +name-outs DEFINES ${name}-outs +name-in DEFINES ${name}-in +name-out DEFINES ${name}-out + +WHERE + +SINGLETON: name-analysis + +SYMBOL: name-ins + +: name-in ( bb -- set ) name-ins get at ; + +SYMBOL: name-outs + +: name-out ( bb -- set ) name-outs get at ; + +;FUNCTOR + +! ! ! Forward dataflow analysis + +MIXIN: forward-analysis +INSTANCE: forward-analysis dataflow-analysis + +M: forward-analysis block-order drop reverse-post-order ; +M: forward-analysis successors drop successors>> ; +M: forward-analysis predecessors drop predecessors>> ; + +FUNCTOR: define-forward-analysis ( name -- ) + +name-analysis IS ${name}-analysis +name-ins IS ${name}-ins +name-outs IS ${name}-outs +compute-name-sets DEFINES compute-${name}-sets + +WHERE + +INSTANCE: name-analysis forward-analysis + +: compute-name-sets ( cfg -- ) + name-analysis run-dataflow-analysis + [ name-ins set ] [ name-outs set ] bi* ; + +;FUNCTOR + +! ! ! Backward dataflow analysis + +MIXIN: backward-analysis +INSTANCE: backward-analysis dataflow-analysis + +M: backward-analysis block-order drop post-order ; +M: backward-analysis successors drop predecessors>> ; +M: backward-analysis predecessors drop successors>> ; + +FUNCTOR: define-backward-analysis ( name -- ) + +name-analysis IS ${name}-analysis +name-ins IS ${name}-ins +name-outs IS ${name}-outs +compute-name-sets DEFINES compute-${name}-sets + +WHERE + +INSTANCE: name-analysis backward-analysis + +: compute-name-sets ( cfg -- ) + \ name-analysis run-dataflow-analysis + [ name-outs set ] [ name-ins set ] bi* ; + +;FUNCTOR + +PRIVATE> + +SYNTAX: FORWARD-ANALYSIS: + scan [ define-analysis ] [ define-forward-analysis ] bi ; + +SYNTAX: BACKWARD-ANALYSIS: + scan [ define-analysis ] [ define-backward-analysis ] bi ; diff --git a/basis/compiler/cfg/dce/authors.txt b/basis/compiler/cfg/dce/authors.txt index d4f5d6b3ae..a44f8d7f8d 100644 --- a/basis/compiler/cfg/dce/authors.txt +++ b/basis/compiler/cfg/dce/authors.txt @@ -1 +1,2 @@ -Slava Pestov \ No newline at end of file +Slava Pestov +Daniel Ehrenberg diff --git a/basis/compiler/cfg/dce/dce-tests.factor b/basis/compiler/cfg/dce/dce-tests.factor new file mode 100644 index 0000000000..6a7ef08257 --- /dev/null +++ b/basis/compiler/cfg/dce/dce-tests.factor @@ -0,0 +1,72 @@ +! Copyright (C) 2009 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test compiler.cfg kernel accessors compiler.cfg.dce +compiler.cfg.instructions compiler.cfg.registers cpu.architecture ; +IN: compiler.cfg.dce.tests + +: test-dce ( insns -- insns' ) + swap >>instructions + cfg new swap >>entry + eliminate-dead-code + entry>> instructions>> ; + +[ V{ + T{ ##load-immediate { dst 1 } { val 8 } } + T{ ##load-immediate { 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{ ##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{ ##add { dst 3 } { src1 1 } { src2 2 } } +} test-dce ] unit-test + +[ V{ } ] [ V{ + T{ ##load-immediate { dst 3 } { val 8 } } + T{ ##allot { dst 1 } { temp 2 } } +} test-dce ] unit-test + +[ V{ } ] [ V{ + T{ ##load-immediate { 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{ ##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{ ##allot { dst 1 } { temp 2 } } + T{ ##set-slot-imm { obj 1 } { src 3 } } + T{ ##replace { src 1 } { loc D 0 } } +} test-dce ] unit-test + +[ V{ + T{ ##allot { dst 1 } { temp 2 } } + T{ ##replace { src 1 } { loc D 0 } } +} ] [ V{ + T{ ##allot { dst 1 } { temp 2 } } + T{ ##replace { src 1 } { loc D 0 } } +} test-dce ] unit-test + +[ V{ + T{ ##allot { dst 1 } { temp 2 } } + T{ ##replace { src 1 } { loc D 0 } } + T{ ##load-immediate { 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{ ##set-slot-imm { obj 1 } { src 3 } } +} test-dce ] unit-test diff --git a/basis/compiler/cfg/dce/dce.factor b/basis/compiler/cfg/dce/dce.factor index 68c89be455..dd42475a13 100644 --- a/basis/compiler/cfg/dce/dce.factor +++ b/basis/compiler/cfg/dce/dce.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs sets kernel namespaces sequences compiler.cfg.instructions compiler.cfg.def-use -compiler.cfg.rpo ; +compiler.cfg.rpo compiler.cfg.predecessors ; IN: compiler.cfg.dce ! Maps vregs to sequences of vregs @@ -11,35 +11,95 @@ SYMBOL: liveness-graph ! vregs which participate in side effects and thus are always live SYMBOL: live-vregs +: live-vreg? ( vreg -- ? ) + live-vregs get key? ; + +! vregs which are the result of an allocation +SYMBOL: allocations + +: allocation? ( vreg -- ? ) + allocations get key? ; + : init-dead-code ( -- ) H{ } clone liveness-graph set - H{ } clone live-vregs set ; + H{ } clone live-vregs set + H{ } clone allocations set ; -GENERIC: update-liveness-graph ( insn -- ) +GENERIC: build-liveness-graph ( insn -- ) -M: ##flushable update-liveness-graph - [ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ; +: add-edges ( insn register -- ) + [ uses-vregs ] dip liveness-graph get [ union ] change-at ; -: record-live ( vregs -- ) +: setter-liveness-graph ( insn vreg -- ) + dup allocation? [ add-edges ] [ 2drop ] if ; + +M: ##set-slot build-liveness-graph + dup obj>> setter-liveness-graph ; + +M: ##set-slot-imm build-liveness-graph + dup obj>> setter-liveness-graph ; + +M: ##write-barrier build-liveness-graph + dup src>> setter-liveness-graph ; + +M: ##flushable build-liveness-graph + dup dst>> add-edges ; + +M: ##allot build-liveness-graph + [ dst>> allocations get conjoin ] + [ call-next-method ] bi ; + +M: insn build-liveness-graph drop ; + +GENERIC: compute-live-vregs ( insn -- ) + +: (record-live) ( vregs -- ) [ dup live-vregs get key? [ drop ] [ [ live-vregs get conjoin ] - [ liveness-graph get at record-live ] + [ liveness-graph get at (record-live) ] bi ] if ] each ; -M: insn update-liveness-graph uses-vregs record-live ; +: record-live ( insn -- ) + uses-vregs (record-live) ; + +: setter-live-vregs ( insn vreg -- ) + allocation? [ drop ] [ record-live ] if ; + +M: ##set-slot compute-live-vregs + dup obj>> setter-live-vregs ; + +M: ##set-slot-imm compute-live-vregs + dup obj>> setter-live-vregs ; + +M: ##write-barrier compute-live-vregs + dup src>> setter-live-vregs ; + +M: ##flushable compute-live-vregs drop ; + +M: insn compute-live-vregs + record-live ; GENERIC: live-insn? ( insn -- ? ) -M: ##flushable live-insn? dst>> live-vregs get key? ; +M: ##flushable live-insn? dst>> live-vreg? ; + +M: ##set-slot live-insn? obj>> live-vreg? ; + +M: ##set-slot-imm live-insn? obj>> live-vreg? ; + +M: ##write-barrier live-insn? src>> live-vreg? ; M: insn live-insn? drop t ; : eliminate-dead-code ( cfg -- cfg' ) + needs-predecessors + init-dead-code - [ [ instructions>> [ update-liveness-graph ] each ] each-basic-block ] - [ [ [ [ live-insn? ] filter ] change-instructions drop ] each-basic-block ] - [ ] - tri ; \ No newline at end of file + dup + [ [ instructions>> [ build-liveness-graph ] each ] each-basic-block ] + [ [ instructions>> [ compute-live-vregs ] each ] each-basic-block ] + [ [ instructions>> [ live-insn? ] filter-here ] each-basic-block ] + tri ; diff --git a/basis/compiler/cfg/dce/summary.txt b/basis/compiler/cfg/dce/summary.txt new file mode 100644 index 0000000000..82b391c2bf --- /dev/null +++ b/basis/compiler/cfg/dce/summary.txt @@ -0,0 +1 @@ +Dead code elimination diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor index cb56937758..d51aa477c9 100644 --- a/basis/compiler/cfg/debugger/debugger.factor +++ b/basis/compiler/cfg/debugger/debugger.factor @@ -1,32 +1,38 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel words sequences quotations namespaces io -classes.tuple accessors prettyprint prettyprint.config -prettyprint.backend prettyprint.custom prettyprint.sections -parser compiler.tree.builder compiler.tree.optimizer -compiler.cfg.builder compiler.cfg.linearization -compiler.cfg.registers compiler.cfg.stack-frame -compiler.cfg.linear-scan compiler.cfg.two-operand -compiler.cfg.liveness compiler.cfg.optimizer -compiler.cfg.mr ; +USING: kernel words sequences quotations namespaces io vectors +arrays hashtables classes.tuple accessors prettyprint +prettyprint.config assocs prettyprint.backend prettyprint.custom +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.two-operand 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 ; IN: compiler.cfg.debugger GENERIC: test-cfg ( quot -- cfgs ) M: callable test-cfg + 0 vreg-counter set-global build-tree optimize-tree gensym build-cfg ; M: word test-cfg + 0 vreg-counter set-global [ build-tree optimize-tree ] keep build-cfg ; : test-mr ( quot -- mrs ) test-cfg [ - optimize-cfg - build-mr + [ + optimize-cfg + build-mr + ] with-cfg ] map ; : insn. ( insn -- ) - tuple>array [ pprint bl ] each nl ; + tuple>array but-last [ pprint bl ] each nl ; : mr. ( mrs -- ) [ @@ -39,13 +45,38 @@ M: word test-cfg ] each ; ! Prettyprinting -M: vreg pprint* - > pprint* ] [ n>> pprint* ] bi - block> ; - : pprint-loc ( loc word -- ) > pprint* block> ; M: ds-loc pprint* \ D pprint-loc ; M: rs-loc pprint* \ R pprint-loc ; + +: resolve-phis ( bb -- ) + [ + [ [ [ get ] dip ] assoc-map ] change-inputs drop + ] each-phi ; + +: test-bb ( insns n -- ) + [ swap >>number swap >>instructions dup ] keep set + resolve-phis ; + +: edge ( from to -- ) + [ get ] bi@ 1vector >>successors drop ; + +: edges ( from tos -- ) + [ get ] [ [ get ] V{ } map-as ] bi* >>successors drop ; + +: test-diamond ( -- ) + 0 1 edge + 1 { 2 3 } edges + 2 4 edge + 3 4 edge ; + +: fake-representations ( cfg -- ) + post-order [ + instructions>> [ + [ [ temp-vregs ] [ temp-vreg-reps ] bi zip ] + [ [ defs-vreg ] [ defs-vreg-rep ] bi 2dup and [ 2array ] [ 2drop f ] if ] + bi [ suffix ] when* + ] map concat + ] map concat >hashtable representations set ; \ No newline at end of file diff --git a/basis/compiler/cfg/def-use/authors.txt b/basis/compiler/cfg/def-use/authors.txt new file mode 100644 index 0000000000..a44f8d7f8d --- /dev/null +++ b/basis/compiler/cfg/def-use/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Daniel Ehrenberg diff --git a/basis/compiler/cfg/def-use/def-use-tests.factor b/basis/compiler/cfg/def-use/def-use-tests.factor new file mode 100644 index 0000000000..a4f0819397 --- /dev/null +++ b/basis/compiler/cfg/def-use/def-use-tests.factor @@ -0,0 +1,36 @@ +! Copyright (C) 2009 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel tools.test accessors vectors sequences namespaces +arrays +cpu.architecture +compiler.cfg.def-use +compiler.cfg +compiler.cfg.debugger +compiler.cfg.instructions +compiler.cfg.registers ; +IN: compiler.cfg.def-use.tests + +V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 0 } + T{ ##peek f 2 D 0 } +} 1 test-bb +V{ + T{ ##replace f 2 D 0 } +} 2 test-bb +1 2 edge +V{ + T{ ##replace f 0 D 0 } +} 3 test-bb +2 3 edge +V{ } 4 test-bb +V{ } 5 test-bb +3 { 4 5 } edges +V{ + T{ ##phi f 2 H{ { 2 0 } { 3 1 } } } +} 6 test-bb +4 6 edge +5 6 edge + +cfg new 1 get >>entry 0 set +[ ] [ 0 get [ compute-defs ] [ compute-uses ] bi ] unit-test diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index 4ff9814e6d..3102d75a4e 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -1,14 +1,17 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays kernel compiler.cfg.instructions ; +USING: accessors arrays kernel assocs sequences namespaces fry +sets compiler.cfg.rpo compiler.cfg.instructions locals ; IN: compiler.cfg.def-use -GENERIC: defs-vregs ( insn -- seq ) +GENERIC: defs-vreg ( insn -- vreg/f ) GENERIC: temp-vregs ( insn -- seq ) GENERIC: uses-vregs ( insn -- seq ) -M: ##flushable defs-vregs dst>> 1array ; -M: insn defs-vregs drop f ; +M: ##flushable defs-vreg dst>> ; +M: ##fixnum-overflow defs-vreg dst>> ; +M: _fixnum-overflow defs-vreg dst>> ; +M: insn defs-vreg drop f ; M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ; M: ##unary/temp temp-vregs temp>> 1array ; @@ -18,11 +21,10 @@ M: ##slot temp-vregs temp>> 1array ; M: ##set-slot temp-vregs temp>> 1array ; M: ##string-nth temp-vregs temp>> 1array ; M: ##set-string-nth-fast temp-vregs temp>> 1array ; +M: ##box-displaced-alien temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ; M: ##compare temp-vregs temp>> 1array ; M: ##compare-imm temp-vregs temp>> 1array ; M: ##compare-float temp-vregs temp>> 1array ; -M: ##fixnum-mul temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ; -M: ##fixnum-mul-tail temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ; M: ##gc temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ; M: _dispatch temp-vregs temp>> 1array ; M: insn temp-vregs drop f ; @@ -43,23 +45,51 @@ M: ##dispatch uses-vregs src>> 1array ; M: ##alien-getter uses-vregs src>> 1array ; M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ; M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ; -M: ##phi uses-vregs inputs>> ; +M: ##phi uses-vregs inputs>> values ; M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ; M: _compare-imm-branch uses-vregs src1>> 1array ; M: _dispatch uses-vregs src>> 1array ; M: insn uses-vregs drop f ; -! Instructions that use vregs -UNION: vreg-insn -##flushable -##write-barrier -##dispatch -##effect -##fixnum-overflow -##conditional-branch -##compare-imm-branch -##phi -##gc -_conditional-branch -_compare-imm-branch -_dispatch ; +! Computing def-use chains. + +SYMBOLS: defs insns uses ; + +: def-of ( vreg -- node ) defs get at ; +: uses-of ( vreg -- nodes ) uses get at ; +: insn-of ( vreg -- insn ) insns get at ; + +: set-def-of ( obj insn assoc -- ) + swap defs-vreg dup [ swap set-at ] [ 3drop ] if ; + +: compute-defs ( cfg -- ) + H{ } clone [ + '[ + dup instructions>> [ + _ set-def-of + ] with each + ] each-basic-block + ] keep + defs set ; + +: compute-insns ( cfg -- ) + H{ } clone [ + '[ + instructions>> [ + dup _ set-def-of + ] each + ] each-basic-block + ] keep insns set ; + +:: compute-uses ( cfg -- ) + ! Here, a phi node uses its argument in the block that it comes from. + H{ } clone :> use + cfg [| block | + block instructions>> [ + dup ##phi? + [ inputs>> [ use conjoin-at ] assoc-each ] + [ uses-vregs [ block swap use conjoin-at ] each ] + if + ] each + ] each-basic-block + use [ keys ] assoc-map uses set ; diff --git a/basis/compiler/cfg/dominance/dominance-tests.factor b/basis/compiler/cfg/dominance/dominance-tests.factor new file mode 100644 index 0000000000..b24e51abfb --- /dev/null +++ b/basis/compiler/cfg/dominance/dominance-tests.factor @@ -0,0 +1,75 @@ +USING: tools.test sequences vectors namespaces kernel accessors assocs sets +math.ranges arrays compiler.cfg compiler.cfg.dominance compiler.cfg.debugger +compiler.cfg.predecessors ; +IN: compiler.cfg.dominance.tests + +: test-dominance ( -- ) + cfg new 0 get >>entry + needs-dominance drop ; + +! Example with no back edges +V{ } 0 test-bb +V{ } 1 test-bb +V{ } 2 test-bb +V{ } 3 test-bb +V{ } 4 test-bb +V{ } 5 test-bb + +0 { 1 2 } edges +1 3 edge +2 4 edge +3 4 edge +4 5 edge + +[ ] [ test-dominance ] unit-test + +[ t ] [ 0 get dom-parent 0 get eq? ] unit-test +[ t ] [ 1 get dom-parent 0 get eq? ] unit-test +[ t ] [ 2 get dom-parent 0 get eq? ] unit-test +[ t ] [ 4 get dom-parent 0 get eq? ] unit-test +[ t ] [ 3 get dom-parent 1 get eq? ] unit-test +[ t ] [ 5 get dom-parent 4 get eq? ] unit-test + +[ t ] [ 0 get dom-children 1 get 2 get 4 get 3array set= ] unit-test + +[ t ] [ 0 get 3 get dominates? ] unit-test +[ f ] [ 3 get 4 get dominates? ] unit-test +[ f ] [ 1 get 4 get dominates? ] unit-test +[ t ] [ 4 get 5 get dominates? ] unit-test +[ f ] [ 1 get 5 get dominates? ] unit-test + +! Example from the paper +V{ } 0 test-bb +V{ } 1 test-bb +V{ } 2 test-bb +V{ } 3 test-bb +V{ } 4 test-bb + +0 { 1 2 } edges +1 3 edge +2 4 edge +3 4 edge +4 3 edge + +[ ] [ test-dominance ] unit-test + +[ t ] [ 0 4 [a,b] [ get dom-parent 0 get eq? ] all? ] unit-test + +! The other example from the paper +V{ } 0 test-bb +V{ } 1 test-bb +V{ } 2 test-bb +V{ } 3 test-bb +V{ } 4 test-bb +V{ } 5 test-bb + +0 { 1 2 } edges +1 5 edge +2 { 4 3 } edges +5 4 edge +4 { 5 3 } edges +3 4 edge + +[ ] [ test-dominance ] unit-test + +[ t ] [ 0 5 [a,b] [ get dom-parent 0 get eq? ] all? ] unit-test diff --git a/basis/compiler/cfg/dominance/dominance.factor b/basis/compiler/cfg/dominance/dominance.factor index 750a46ee6c..d21e81526e 100644 --- a/basis/compiler/cfg/dominance/dominance.factor +++ b/basis/compiler/cfg/dominance/dominance.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs combinators compiler.cfg.rpo -compiler.cfg.stack-analysis fry kernel math.order namespaces -sequences ; +USING: accessors assocs combinators sets math fry kernel math.order +dlists deques vectors namespaces sequences sorting locals +compiler.cfg.rpo compiler.cfg.predecessors ; IN: compiler.cfg.dominance ! Reference: @@ -11,31 +11,96 @@ IN: compiler.cfg.dominance ! Keith D. Cooper, Timothy J. Harvey, and Ken Kennedy ! http://www.cs.rice.edu/~keith/EMBED/dom.pdf -SYMBOL: idoms - -: idom ( bb -- bb' ) idoms get at ; +! Also, a nice overview is given in these lecture notes: +! http://llvm.cs.uiuc.edu/~vadve/CS526/public_html/Notes/4ssa.4up.pdf idom(bb) +SYMBOL: dom-parents + +PRIVATE> + +: dom-parent ( bb -- bb' ) dom-parents get at ; + +> ] compare { - { +lt+ [ [ idom ] dip intersect ] } - { +gt+ [ idom intersect ] } + { +gt+ [ [ dom-parent ] dip intersect ] } + { +lt+ [ dom-parent intersect ] } [ 2drop ] } case ; : compute-idom ( bb -- idom ) - predecessors>> [ idom ] map sift + predecessors>> [ dom-parent ] filter [ ] [ intersect ] map-reduce ; : iterate ( rpo -- changed? ) [ [ compute-idom ] keep set-idom ] map [ ] any? ; +: compute-dom-parents ( cfg -- ) + H{ } clone dom-parents set + reverse-post-order + unclip dup set-idom drop '[ _ iterate ] loop ; + +! Maps bb -> {bb' | idom(bb') = bb} +SYMBOL: dom-childrens + PRIVATE> -: compute-dominance ( cfg -- cfg ) - H{ } clone idoms set - dup reverse-post-order - unclip dup set-idom drop '[ _ iterate ] loop ; \ No newline at end of file +: dom-children ( bb -- seq ) dom-childrens get at ; + + + +: pre-of ( bb -- n ) [ preorder get at ] [ -1/0. ] if* ; + +: maxpre-of ( bb -- n ) [ maxpreorder get at ] [ 1/0. ] if* ; + +> (compute-dfs) drop ; + +: compute-dominance ( cfg -- cfg' ) + [ compute-dom-parents compute-dom-children ] [ compute-dfs ] [ ] tri ; + +PRIVATE> + +: needs-dominance ( cfg -- cfg' ) + needs-predecessors + dup dominance-valid?>> [ compute-dominance t >>dominance-valid? ] unless ; + +: dominates? ( bb1 bb2 -- ? ) + swap [ pre-of ] [ [ pre-of ] [ maxpre-of ] bi ] bi* between? ; + +:: breadth-first-order ( cfg -- bfo ) + :> work-list + cfg post-order length :> accum + cfg entry>> work-list push-front + work-list [ + [ accum push ] + [ dom-children work-list push-all-front ] bi + ] slurp-deque + accum ; \ No newline at end of file diff --git a/basis/compiler/cfg/empty-blocks/empty-blocks.factor b/basis/compiler/cfg/empty-blocks/empty-blocks.factor new file mode 100644 index 0000000000..605c572cb3 --- /dev/null +++ b/basis/compiler/cfg/empty-blocks/empty-blocks.factor @@ -0,0 +1,47 @@ +! Copyright (C) 2008, 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors sequences namespaces combinators +combinators.short-circuit classes vectors compiler.cfg +compiler.cfg.instructions compiler.cfg.rpo ; +IN: compiler.cfg.empty-blocks + +> first [ + [ + 2dup eq? [ drop successors>> first ] [ nip ] if + ] with map + ] change-successors drop ; + +: update-successor ( bb -- ) + ! We have to replace occurrences of bb with bb's predecessor + ! in bb's sucessor's list of predecessors. + dup successors>> first [ + [ + 2dup eq? [ drop predecessors>> first ] [ nip ] if + ] with map + ] change-predecessors drop ; + +SYMBOL: changed? + +: delete-basic-block ( bb -- ) + [ update-predecessor ] [ update-successor ] bi + changed? on ; + +: delete-basic-block? ( bb -- ? ) + { + [ instructions>> length 1 = ] + [ predecessors>> length 1 = ] + [ successors>> length 1 = ] + [ instructions>> first ##branch? ] + } 1&& ; + +PRIVATE> + +: delete-empty-blocks ( cfg -- cfg' ) + changed? off + dup [ dup delete-basic-block? [ delete-basic-block ] [ drop ] if ] each-basic-block + changed? get [ cfg-changed ] when ; \ No newline at end of file diff --git a/basis/compiler/cfg/gc-checks/gc-checks-tests.factor b/basis/compiler/cfg/gc-checks/gc-checks-tests.factor new file mode 100644 index 0000000000..5580de9a47 --- /dev/null +++ b/basis/compiler/cfg/gc-checks/gc-checks-tests.factor @@ -0,0 +1,26 @@ +USING: compiler.cfg.gc-checks compiler.cfg.debugger +compiler.cfg.registers compiler.cfg.instructions compiler.cfg +compiler.cfg.predecessors cpu.architecture tools.test kernel vectors +namespaces accessors sequences ; +IN: compiler.cfg.gc-checks.tests + +: test-gc-checks ( -- ) + H{ } clone representations set + cfg new 0 get >>entry + insert-gc-checks + drop ; + +V{ + T{ ##inc-d f 3 } + T{ ##replace f 0 D 1 } +} 0 test-bb + +V{ + T{ ##box-float f 0 1 } +} 1 test-bb + +0 1 edge + +[ ] [ test-gc-checks ] unit-test + +[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test diff --git a/basis/compiler/cfg/gc-checks/gc-checks.factor b/basis/compiler/cfg/gc-checks/gc-checks.factor index 4176914126..21a60768ea 100644 --- a/basis/compiler/cfg/gc-checks/gc-checks.factor +++ b/basis/compiler/cfg/gc-checks/gc-checks.factor @@ -1,21 +1,32 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences assocs -cpu.architecture compiler.cfg.rpo -compiler.cfg.liveness compiler.cfg.instructions -compiler.cfg.hats ; +USING: accessors kernel sequences assocs fry +cpu.architecture +compiler.cfg.rpo +compiler.cfg.registers +compiler.cfg.instructions +compiler.cfg.stacks.uninitialized ; IN: compiler.cfg.gc-checks -: gc? ( bb -- ? ) +! Garbage collection check insertion. This pass runs after representation +! selection, so it must keep track of representations. + +: insert-gc-check? ( bb -- ? ) instructions>> [ ##allocation? ] any? ; -: object-pointer-regs ( basic-block -- vregs ) - live-in keys [ reg-class>> int-regs eq? ] filter ; +: blocks-with-gc ( cfg -- bbs ) + post-order [ insert-gc-check? ] filter ; -: insert-gc-check ( basic-block -- ) - dup gc? [ - [ i i f f \ ##gc new-insn prefix ] change-instructions drop - ] [ drop ] if ; +: insert-gc-check ( bb -- ) + dup '[ + int-rep next-vreg-rep + int-rep next-vreg-rep + f f _ uninitialized-locs \ ##gc new-insn + prefix + ] change-instructions drop ; : insert-gc-checks ( cfg -- cfg' ) - dup [ insert-gc-check ] each-basic-block ; \ No newline at end of file + dup blocks-with-gc [ + over compute-uninitialized-sets + [ insert-gc-check ] each + ] unless-empty ; \ No newline at end of file diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index b61f091fad..2d79cbebc3 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -1,77 +1,83 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays byte-arrays kernel layouts math namespaces +USING: accessors arrays byte-arrays kernel layouts math namespaces sequences classes.tuple cpu.architecture compiler.cfg.registers compiler.cfg.instructions ; IN: compiler.cfg.hats -: i ( -- vreg ) int-regs next-vreg ; inline -: ^^i ( -- vreg vreg ) i dup ; inline -: ^^i1 ( obj -- vreg vreg obj ) [ ^^i ] dip ; inline -: ^^i2 ( obj obj -- vreg vreg obj obj ) [ ^^i ] 2dip ; inline -: ^^i3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^i ] 3dip ; inline +: ^^r ( -- vreg vreg ) next-vreg dup ; inline +: ^^r1 ( obj -- vreg vreg obj ) [ ^^r ] dip ; inline +: ^^r2 ( obj obj -- vreg vreg obj obj ) [ ^^r ] 2dip ; inline +: ^^r3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^r ] 3dip ; inline -: d ( -- vreg ) double-float-regs next-vreg ; inline -: ^^d ( -- vreg vreg ) d dup ; inline -: ^^d1 ( obj -- vreg vreg obj ) [ ^^d ] dip ; inline -: ^^d2 ( obj obj -- vreg vreg obj obj ) [ ^^d ] 2dip ; inline -: ^^d3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^d ] 3dip ; inline - -: ^^load-literal ( obj -- dst ) ^^i1 ##load-literal ; inline -: ^^peek ( loc -- dst ) ^^i1 ##peek ; inline -: ^^slot ( obj slot tag -- dst ) ^^i3 i ##slot ; inline -: ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline -: ^^set-slot ( src obj slot tag -- ) i ##set-slot ; inline -: ^^string-nth ( obj index -- dst ) ^^i2 i ##string-nth ; inline -: ^^add ( src1 src2 -- dst ) ^^i2 ##add ; inline -: ^^add-imm ( src1 src2 -- dst ) ^^i2 ##add-imm ; inline -: ^^sub ( src1 src2 -- dst ) ^^i2 ##sub ; inline -: ^^sub-imm ( src1 src2 -- dst ) ^^i2 ##sub-imm ; inline -: ^^mul ( src1 src2 -- dst ) ^^i2 ##mul ; inline -: ^^mul-imm ( src1 src2 -- dst ) ^^i2 ##mul-imm ; inline -: ^^and ( input mask -- output ) ^^i2 ##and ; inline -: ^^and-imm ( input mask -- output ) ^^i2 ##and-imm ; inline -: ^^or ( src1 src2 -- dst ) ^^i2 ##or ; inline -: ^^or-imm ( src1 src2 -- dst ) ^^i2 ##or-imm ; inline -: ^^xor ( src1 src2 -- dst ) ^^i2 ##xor ; inline -: ^^xor-imm ( src1 src2 -- dst ) ^^i2 ##xor-imm ; inline -: ^^shl-imm ( src1 src2 -- dst ) ^^i2 ##shl-imm ; inline -: ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline -: ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline -: ^^not ( src -- dst ) ^^i1 ##not ; inline -: ^^log2 ( src -- dst ) ^^i1 ##log2 ; inline -: ^^bignum>integer ( src -- dst ) ^^i1 i ##bignum>integer ; inline -: ^^integer>bignum ( src -- dst ) ^^i1 i ##integer>bignum ; inline -: ^^add-float ( src1 src2 -- dst ) ^^d2 ##add-float ; inline -: ^^sub-float ( src1 src2 -- dst ) ^^d2 ##sub-float ; inline -: ^^mul-float ( src1 src2 -- dst ) ^^d2 ##mul-float ; inline -: ^^div-float ( src1 src2 -- dst ) ^^d2 ##div-float ; inline -: ^^float>integer ( src -- dst ) ^^i1 ##float>integer ; inline -: ^^integer>float ( src -- dst ) ^^d1 ##integer>float ; inline -: ^^allot ( size class -- dst ) ^^i2 i ##allot ; inline +: ^^load-literal ( obj -- dst ) ^^r1 ##load-literal ; inline +: ^^copy ( src -- dst ) ^^r1 any-rep ##copy ; inline +: ^^slot ( obj slot tag -- dst ) ^^r3 next-vreg ##slot ; inline +: ^^slot-imm ( obj slot tag -- dst ) ^^r3 ##slot-imm ; inline +: ^^set-slot ( src obj slot tag -- ) next-vreg ##set-slot ; inline +: ^^string-nth ( obj index -- dst ) ^^r2 next-vreg ##string-nth ; inline +: ^^add ( src1 src2 -- dst ) ^^r2 ##add ; inline +: ^^add-imm ( src1 src2 -- dst ) ^^r2 ##add-imm ; inline +: ^^sub ( src1 src2 -- dst ) ^^r2 ##sub ; inline +: ^^sub-imm ( src1 src2 -- dst ) ^^r2 ##sub-imm ; inline +: ^^neg ( src -- dst ) [ 0 ^^load-literal ] dip ^^sub ; inline +: ^^mul ( src1 src2 -- dst ) ^^r2 ##mul ; inline +: ^^mul-imm ( src1 src2 -- dst ) ^^r2 ##mul-imm ; inline +: ^^and ( input mask -- output ) ^^r2 ##and ; inline +: ^^and-imm ( input mask -- output ) ^^r2 ##and-imm ; inline +: ^^or ( src1 src2 -- dst ) ^^r2 ##or ; inline +: ^^or-imm ( src1 src2 -- dst ) ^^r2 ##or-imm ; inline +: ^^xor ( src1 src2 -- dst ) ^^r2 ##xor ; inline +: ^^xor-imm ( src1 src2 -- dst ) ^^r2 ##xor-imm ; inline +: ^^shl ( src1 src2 -- dst ) ^^r2 ##shl ; inline +: ^^shl-imm ( src1 src2 -- dst ) ^^r2 ##shl-imm ; inline +: ^^shr ( src1 src2 -- dst ) ^^r2 ##shr ; inline +: ^^shr-imm ( src1 src2 -- dst ) ^^r2 ##shr-imm ; inline +: ^^sar ( src1 src2 -- dst ) ^^r2 ##sar ; inline +: ^^sar-imm ( src1 src2 -- dst ) ^^r2 ##sar-imm ; inline +: ^^min ( src1 src2 -- dst ) ^^r2 ##min ; inline +: ^^max ( src1 src2 -- dst ) ^^r2 ##max ; inline +: ^^not ( src -- dst ) ^^r1 ##not ; inline +: ^^log2 ( src -- dst ) ^^r1 ##log2 ; inline +: ^^bignum>integer ( src -- dst ) ^^r1 next-vreg ##bignum>integer ; inline +: ^^integer>bignum ( src -- dst ) ^^r1 next-vreg ##integer>bignum ; inline +: ^^add-float ( src1 src2 -- dst ) ^^r2 ##add-float ; inline +: ^^sub-float ( src1 src2 -- dst ) ^^r2 ##sub-float ; inline +: ^^mul-float ( src1 src2 -- dst ) ^^r2 ##mul-float ; inline +: ^^div-float ( src1 src2 -- dst ) ^^r2 ##div-float ; inline +: ^^max-float ( src1 src2 -- dst ) ^^r2 ##max-float ; inline +: ^^min-float ( src1 src2 -- dst ) ^^r2 ##min-float ; inline +: ^^unary-float-function ( src func -- dst ) ^^r2 ##unary-float-function ; inline +: ^^binary-float-function ( src1 src2 func -- dst ) ^^r3 ##binary-float-function ; inline +: ^^sqrt ( src -- dst ) ^^r1 ##sqrt ; inline +: ^^float>integer ( src -- dst ) ^^r1 ##float>integer ; inline +: ^^integer>float ( src -- dst ) ^^r1 ##integer>float ; inline +: ^^allot ( size class -- dst ) ^^r2 next-vreg ##allot ; inline : ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline : ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline : ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline -: ^^box-float ( src -- dst ) ^^i1 i ##box-float ; inline -: ^^unbox-float ( src -- dst ) ^^d1 ##unbox-float ; inline -: ^^box-alien ( src -- dst ) ^^i1 i ##box-alien ; inline -: ^^unbox-alien ( src -- dst ) ^^i1 ##unbox-alien ; inline -: ^^unbox-c-ptr ( src class -- dst ) ^^i2 i ##unbox-c-ptr ; -: ^^alien-unsigned-1 ( src -- dst ) ^^i1 ##alien-unsigned-1 ; inline -: ^^alien-unsigned-2 ( src -- dst ) ^^i1 ##alien-unsigned-2 ; inline -: ^^alien-unsigned-4 ( src -- dst ) ^^i1 ##alien-unsigned-4 ; inline -: ^^alien-signed-1 ( src -- dst ) ^^i1 ##alien-signed-1 ; inline -: ^^alien-signed-2 ( src -- dst ) ^^i1 ##alien-signed-2 ; inline -: ^^alien-signed-4 ( src -- dst ) ^^i1 ##alien-signed-4 ; inline -: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline -: ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline -: ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline -: ^^alien-global ( symbol library -- dst ) ^^i2 ##alien-global ; inline -: ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline -: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline -: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline -: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline -: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline -: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline - -: ^^phi ( inputs -- dst ) ^^i1 ##phi ; inline \ No newline at end of file +: ^^box-alien ( src -- dst ) ^^r1 next-vreg ##box-alien ; inline +: ^^box-displaced-alien ( base displacement base-class -- dst ) + ^^r3 [ next-vreg next-vreg ] dip ##box-displaced-alien ; inline +: ^^unbox-alien ( src -- dst ) ^^r1 ##unbox-alien ; inline +: ^^unbox-c-ptr ( src class -- dst ) ^^r2 next-vreg ##unbox-c-ptr ; +: ^^alien-unsigned-1 ( src -- dst ) ^^r1 ##alien-unsigned-1 ; inline +: ^^alien-unsigned-2 ( src -- dst ) ^^r1 ##alien-unsigned-2 ; inline +: ^^alien-unsigned-4 ( src -- dst ) ^^r1 ##alien-unsigned-4 ; inline +: ^^alien-signed-1 ( src -- dst ) ^^r1 ##alien-signed-1 ; inline +: ^^alien-signed-2 ( src -- dst ) ^^r1 ##alien-signed-2 ; inline +: ^^alien-signed-4 ( src -- dst ) ^^r1 ##alien-signed-4 ; inline +: ^^alien-cell ( src -- dst ) ^^r1 ##alien-cell ; inline +: ^^alien-float ( src -- dst ) ^^r1 ##alien-float ; inline +: ^^alien-double ( src -- dst ) ^^r1 ##alien-double ; inline +: ^^alien-global ( symbol library -- dst ) ^^r2 ##alien-global ; inline +: ^^compare ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare ; inline +: ^^compare-imm ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare-imm ; inline +: ^^compare-float ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare-float ; inline +: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ ^^copy ] if ; inline +: ^^tag-fixnum ( src -- dst ) ^^r1 ##tag-fixnum ; inline +: ^^untag-fixnum ( src -- dst ) ^^r1 ##untag-fixnum ; inline +: ^^fixnum-add ( src1 src2 -- dst ) ^^r2 ##fixnum-add ; inline +: ^^fixnum-sub ( src1 src2 -- dst ) ^^r2 ##fixnum-sub ; inline +: ^^fixnum-mul ( src1 src2 -- dst ) ^^r2 ##fixnum-mul ; inline +: ^^phi ( inputs -- dst ) ^^r1 ##phi ; inline \ No newline at end of file diff --git a/basis/compiler/cfg/height/height.factor b/basis/compiler/cfg/height/height.factor deleted file mode 100644 index 14a0a54715..0000000000 --- a/basis/compiler/cfg/height/height.factor +++ /dev/null @@ -1,55 +0,0 @@ -! Copyright (C) 2008, 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors math namespaces sequences kernel fry -compiler.cfg compiler.cfg.registers compiler.cfg.instructions -compiler.cfg.liveness compiler.cfg.local ; -IN: compiler.cfg.height - -! Combine multiple stack height changes into one at the -! start of the basic block. - -SYMBOL: ds-height -SYMBOL: rs-height - -GENERIC: compute-heights ( insn -- ) - -M: ##inc-d compute-heights n>> ds-height [ + ] change ; -M: ##inc-r compute-heights n>> rs-height [ + ] change ; -M: insn compute-heights drop ; - -GENERIC: normalize-height* ( insn -- insn' ) - -: normalize-inc-d/r ( insn stack -- insn' ) - swap n>> '[ _ - ] change f ; inline - -M: ##inc-d normalize-height* ds-height normalize-inc-d/r ; -M: ##inc-r normalize-height* rs-height normalize-inc-d/r ; - -GENERIC: loc-stack ( loc -- stack ) - -M: ds-loc loc-stack drop ds-height ; -M: rs-loc loc-stack drop rs-height ; - -GENERIC: ( n stack -- loc ) - -M: ds-loc drop ; -M: rs-loc drop ; - -: normalize-peek/replace ( insn -- insn' ) - [ [ [ n>> ] [ loc-stack get ] bi + ] keep ] change-loc ; inline - -M: ##peek normalize-height* normalize-peek/replace ; -M: ##replace normalize-height* normalize-peek/replace ; - -M: insn normalize-height* ; - -: height-step ( insns -- insns' ) - 0 ds-height set - 0 rs-height set - [ [ compute-heights ] each ] - [ [ [ normalize-height* ] map sift ] with-scope ] bi - ds-height get dup 0 = [ drop ] [ \ ##inc-d new-insn prefix ] if - rs-height get dup 0 = [ drop ] [ \ ##inc-r new-insn prefix ] if ; - -: normalize-height ( cfg -- cfg' ) - [ drop ] [ height-step ] local-optimization ; diff --git a/basis/compiler/cfg/height/summary.txt b/basis/compiler/cfg/height/summary.txt deleted file mode 100644 index ce1974ad60..0000000000 --- a/basis/compiler/cfg/height/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Stack height normalization coalesces height changes at start of basic block diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index fe853cf490..a7cc2e0603 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -6,35 +6,35 @@ compiler.constants combinators compiler.cfg.registers compiler.cfg.instructions.syntax ; IN: compiler.cfg.instructions -: new-insn ( ... class -- insn ) [ f f ] dip boa ; inline +: new-insn ( ... class -- insn ) f swap boa ; inline ! Virtual CPU instructions, used by CFG and machine IRs TUPLE: insn ; ! Instruction with no side effects; if 'out' is never read, we ! can eliminate it. -TUPLE: ##flushable < insn { dst vreg } ; +TUPLE: ##flushable < insn dst ; ! Instruction which is referentially transparent; we can replace ! repeated computation with a reference to a previous value TUPLE: ##pure < ##flushable ; -TUPLE: ##unary < ##pure { src vreg } ; -TUPLE: ##unary/temp < ##unary { temp vreg } ; -TUPLE: ##binary < ##pure { src1 vreg } { src2 vreg } ; -TUPLE: ##binary-imm < ##pure { src1 vreg } { src2 integer } ; +TUPLE: ##unary < ##pure src ; +TUPLE: ##unary/temp < ##unary temp ; +TUPLE: ##binary < ##pure src1 src2 ; +TUPLE: ##binary-imm < ##pure src1 { src2 integer } ; TUPLE: ##commutative < ##binary ; TUPLE: ##commutative-imm < ##binary-imm ; ! Instruction only used for its side effect, produces no values -TUPLE: ##effect < insn { src vreg } ; +TUPLE: ##effect < insn src ; ! Read/write ops: candidates for alias analysis TUPLE: ##read < ##flushable ; TUPLE: ##write < ##effect ; -TUPLE: ##alien-getter < ##flushable { src vreg } ; -TUPLE: ##alien-setter < ##effect { value vreg } ; +TUPLE: ##alien-getter < ##flushable src ; +TUPLE: ##alien-setter < ##effect value ; ! Stack operations INSN: ##load-immediate < ##pure { val integer } ; @@ -52,23 +52,25 @@ INSN: ##inc-d { n integer } ; INSN: ##inc-r { n integer } ; ! Subroutine calls -INSN: ##stack-frame stack-frame ; -INSN: ##call word { height integer } ; +INSN: ##call word ; INSN: ##jump word ; INSN: ##return ; +! Dummy instruction that simply inhibits TCO +INSN: ##no-tco ; + ! Jump tables INSN: ##dispatch src temp ; ! Slot access -INSN: ##slot < ##read { obj vreg } { slot vreg } { tag integer } { temp vreg } ; -INSN: ##slot-imm < ##read { obj vreg } { slot integer } { tag integer } ; -INSN: ##set-slot < ##write { obj vreg } { slot vreg } { tag integer } { temp vreg } ; -INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ; +INSN: ##slot < ##read obj slot { tag integer } temp ; +INSN: ##slot-imm < ##read obj { slot integer } { tag integer } ; +INSN: ##set-slot < ##write obj slot { tag integer } temp ; +INSN: ##set-slot-imm < ##write obj { slot integer } { tag integer } ; ! String element access -INSN: ##string-nth < ##flushable { obj vreg } { index vreg } { temp vreg } ; -INSN: ##set-string-nth-fast < ##effect { obj vreg } { index vreg } { temp vreg } ; +INSN: ##string-nth < ##flushable obj index temp ; +INSN: ##set-string-nth-fast < ##effect obj index temp ; ! Integer arithmetic INSN: ##add < ##commutative ; @@ -83,21 +85,17 @@ INSN: ##or < ##commutative ; INSN: ##or-imm < ##commutative-imm ; INSN: ##xor < ##commutative ; INSN: ##xor-imm < ##commutative-imm ; +INSN: ##shl < ##binary ; INSN: ##shl-imm < ##binary-imm ; +INSN: ##shr < ##binary ; INSN: ##shr-imm < ##binary-imm ; +INSN: ##sar < ##binary ; INSN: ##sar-imm < ##binary-imm ; +INSN: ##min < ##binary ; +INSN: ##max < ##binary ; INSN: ##not < ##unary ; INSN: ##log2 < ##unary ; -! Overflowing arithmetic -TUPLE: ##fixnum-overflow < insn src1 src2 ; -INSN: ##fixnum-add < ##fixnum-overflow ; -INSN: ##fixnum-add-tail < ##fixnum-overflow ; -INSN: ##fixnum-sub < ##fixnum-overflow ; -INSN: ##fixnum-sub-tail < ##fixnum-overflow ; -INSN: ##fixnum-mul < ##fixnum-overflow temp1 temp2 ; -INSN: ##fixnum-mul-tail < ##fixnum-overflow temp1 temp2 ; - : ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline : ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline @@ -110,18 +108,25 @@ INSN: ##add-float < ##commutative ; INSN: ##sub-float < ##binary ; INSN: ##mul-float < ##commutative ; INSN: ##div-float < ##binary ; +INSN: ##min-float < ##binary ; +INSN: ##max-float < ##binary ; +INSN: ##sqrt < ##unary ; + +! libc intrinsics +INSN: ##unary-float-function < ##unary func ; +INSN: ##binary-float-function < ##binary func ; ! Float/integer conversion INSN: ##float>integer < ##unary ; INSN: ##integer>float < ##unary ; ! Boxing and unboxing -INSN: ##copy < ##unary ; -INSN: ##copy-float < ##unary ; +INSN: ##copy < ##unary rep ; INSN: ##unbox-float < ##unary ; INSN: ##unbox-any-c-ptr < ##unary/temp ; INSN: ##box-float < ##unary/temp ; INSN: ##box-alien < ##unary/temp ; +INSN: ##box-displaced-alien < ##binary temp1 temp2 base-class ; : ##unbox-f ( dst src -- ) drop 0 ##load-immediate ; : ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ; @@ -154,18 +159,23 @@ INSN: ##set-alien-float < ##alien-setter ; INSN: ##set-alien-double < ##alien-setter ; ! Memory allocation -INSN: ##allot < ##flushable size class { temp vreg } ; +INSN: ##allot < ##flushable size class temp ; -UNION: ##allocation ##allot ##box-float ##box-alien ##integer>bignum ; +UNION: ##allocation +##allot +##box-float +##box-alien +##box-displaced-alien +##integer>bignum ; INSN: ##write-barrier < ##effect card# table ; INSN: ##alien-global < ##flushable symbol library ; ! FFI -INSN: ##alien-invoke params ; -INSN: ##alien-indirect params ; -INSN: ##alien-callback params ; +INSN: ##alien-invoke params stack-frame ; +INSN: ##alien-indirect params stack-frame ; +INSN: ##alien-callback params stack-frame ; INSN: ##callback-return params ; ! Instructions used by CFG IR only. @@ -174,42 +184,13 @@ INSN: ##epilogue ; INSN: ##branch ; -INSN: ##loop-entry ; - INSN: ##phi < ##pure inputs ; -! Condition codes -SYMBOL: cc< -SYMBOL: cc<= -SYMBOL: cc= -SYMBOL: cc> -SYMBOL: cc>= -SYMBOL: cc/= - -: negate-cc ( cc -- cc' ) - H{ - { cc< cc>= } - { cc<= cc> } - { cc> cc<= } - { cc>= cc< } - { cc= cc/= } - { cc/= cc= } - } at ; - -: evaluate-cc ( result cc -- ? ) - H{ - { cc< { +lt+ } } - { cc<= { +lt+ +eq+ } } - { cc= { +eq+ } } - { cc>= { +eq+ +gt+ } } - { cc> { +gt+ } } - { cc/= { +lt+ +gt+ } } - } at memq? ; - -TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ; +! Conditionals +TUPLE: ##conditional-branch < insn src1 src2 cc ; INSN: ##compare-branch < ##conditional-branch ; -INSN: ##compare-imm-branch { src1 vreg } { src2 integer } cc ; +INSN: ##compare-imm-branch src1 { src2 integer } cc ; INSN: ##compare < ##binary cc temp ; INSN: ##compare-imm < ##binary-imm cc temp ; @@ -217,7 +198,13 @@ INSN: ##compare-imm < ##binary-imm cc temp ; INSN: ##compare-float-branch < ##conditional-branch ; INSN: ##compare-float < ##binary cc temp ; -INSN: ##gc { temp1 vreg } { temp2 vreg } live-registers live-spill-slots ; +! Overflowing arithmetic +TUPLE: ##fixnum-overflow < insn dst src1 src2 ; +INSN: ##fixnum-add < ##fixnum-overflow ; +INSN: ##fixnum-sub < ##fixnum-overflow ; +INSN: ##fixnum-mul < ##fixnum-overflow ; + +INSN: ##gc temp1 temp2 data-values tagged-values uninitialized-locs ; ! Instructions used by machine IR only. INSN: _prologue stack-frame ; @@ -226,23 +213,104 @@ INSN: _epilogue stack-frame ; INSN: _label id ; INSN: _branch label ; +INSN: _loop-entry ; INSN: _dispatch src temp ; INSN: _dispatch-label label ; -TUPLE: _conditional-branch < insn label { src1 vreg } { src2 vreg } cc ; +TUPLE: _conditional-branch < insn label src1 src2 cc ; INSN: _compare-branch < _conditional-branch ; -INSN: _compare-imm-branch label { src1 vreg } { src2 integer } cc ; +INSN: _compare-imm-branch label src1 { src2 integer } cc ; INSN: _compare-float-branch < _conditional-branch ; +! Overflowing arithmetic +TUPLE: _fixnum-overflow < insn label dst src1 src2 ; +INSN: _fixnum-add < _fixnum-overflow ; +INSN: _fixnum-sub < _fixnum-overflow ; +INSN: _fixnum-mul < _fixnum-overflow ; + TUPLE: spill-slot n ; C: spill-slot -INSN: _gc { temp1 vreg } { temp2 vreg } gc-roots gc-root-count gc-root-size ; +INSN: _gc temp1 temp2 data-values tagged-values uninitialized-locs ; ! These instructions operate on machine registers and not ! virtual registers -INSN: _spill src class n ; -INSN: _reload dst class n ; -INSN: _spill-counts counts ; +INSN: _spill src rep n ; +INSN: _reload dst rep n ; +INSN: _spill-area-size n ; + +! Instructions that use vregs +UNION: vreg-insn + ##flushable + ##write-barrier + ##dispatch + ##effect + ##fixnum-overflow + ##conditional-branch + ##compare-imm-branch + ##phi + ##gc + _conditional-branch + _compare-imm-branch + _dispatch ; + +! Instructions that kill all live vregs but cannot trigger GC +UNION: partial-sync-insn + ##unary-float-function + ##binary-float-function ; + +! Instructions that kill all live vregs +UNION: kill-vreg-insn + ##call + ##prologue + ##epilogue + ##alien-invoke + ##alien-indirect + ##alien-callback ; + +! Instructions that output floats +UNION: output-float-insn + ##add-float + ##sub-float + ##mul-float + ##div-float + ##min-float + ##max-float + ##sqrt + ##unary-float-function + ##binary-float-function + ##integer>float + ##unbox-float + ##alien-float + ##alien-double ; + +! Instructions that take floats as inputs +UNION: input-float-insn + ##add-float + ##sub-float + ##mul-float + ##div-float + ##min-float + ##max-float + ##sqrt + ##unary-float-function + ##binary-float-function + ##float>integer + ##box-float + ##set-alien-float + ##set-alien-double + ##compare-float + ##compare-float-branch ; + +! Smackdown +INTERSECTION: ##unary-float ##unary input-float-insn ; +INTERSECTION: ##binary-float ##binary input-float-insn ; + +! Instructions that have complex expansions and require that the +! output registers are not equal to any of the input registers +UNION: def-is-use-insn + ##integer>bignum + ##bignum>integer + ##unbox-any-c-ptr ; \ No newline at end of file diff --git a/basis/compiler/cfg/instructions/syntax/syntax.factor b/basis/compiler/cfg/instructions/syntax/syntax.factor index e8f8641e7d..ab1c9599e5 100644 --- a/basis/compiler/cfg/instructions/syntax/syntax.factor +++ b/basis/compiler/cfg/instructions/syntax/syntax.factor @@ -11,12 +11,12 @@ IN: compiler.cfg.instructions.syntax "insn" "compiler.cfg.instructions" lookup ; : insn-effect ( word -- effect ) - boa-effect in>> 2 head* f ; + boa-effect in>> but-last f ; SYNTAX: INSN: - parse-tuple-definition { "regs" "insn#" } append + parse-tuple-definition "insn#" suffix [ dup tuple eq? [ drop insn-word ] when ] dip [ define-tuple-class ] [ 2drop save-location ] - [ 2drop [ ] [ '[ f f _ boa , ] ] [ insn-effect ] tri define-inline ] + [ 2drop [ ] [ '[ f _ boa , ] ] [ insn-effect ] tri define-inline ] 3tri ; diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor index 42e23c29c9..c2faf27f03 100644 --- a/basis/compiler/cfg/intrinsics/alien/alien.factor +++ b/basis/compiler/cfg/intrinsics/alien/alien.factor @@ -1,12 +1,25 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences alien math classes.algebra -fry locals combinators cpu.architecture -compiler.tree.propagation.info -compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions -compiler.cfg.utilities ; +USING: accessors kernel sequences alien math classes.algebra fry +locals combinators combinators.short-circuit cpu.architecture +compiler.tree.propagation.info compiler.cfg.hats +compiler.cfg.stacks compiler.cfg.instructions +compiler.cfg.utilities compiler.cfg.builder.blocks ; IN: compiler.cfg.intrinsics.alien +: emit-? ( node -- ? ) + node-input-infos { + [ first class>> fixnum class<= ] + [ second class>> c-ptr class<= ] + } 1&& ; + +: emit- ( node -- ) + dup emit-? [ + [ 2inputs [ ^^untag-fixnum ] dip ] dip + node-input-infos second class>> + ^^box-displaced-alien ds-push + ] [ emit-primitive ] if ; + : (prepare-alien-accessor-imm) ( class offset -- offset-vreg ) ds-drop [ ds-pop swap ^^unbox-c-ptr ] dip ^^add-imm ; @@ -54,7 +67,7 @@ IN: compiler.cfg.intrinsics.alien inline-alien ; inline : inline-alien-float-setter ( node quot -- ) - '[ ds-pop ^^unbox-float @ ] + '[ ds-pop @ ] [ float inline-alien-setter? ] inline-alien ; inline @@ -91,18 +104,18 @@ IN: compiler.cfg.intrinsics.alien : emit-alien-cell-setter ( node -- ) [ ##set-alien-cell ] inline-alien-cell-setter ; -: emit-alien-float-getter ( node reg-class -- ) +: emit-alien-float-getter ( node rep -- ) '[ _ { - { single-float-regs [ ^^alien-float ] } - { double-float-regs [ ^^alien-double ] } - } case ^^box-float + { single-float-rep [ ^^alien-float ] } + { double-float-rep [ ^^alien-double ] } + } case ] inline-alien-getter ; -: emit-alien-float-setter ( node reg-class -- ) +: emit-alien-float-setter ( node rep -- ) '[ _ { - { single-float-regs [ ##set-alien-float ] } - { double-float-regs [ ##set-alien-double ] } + { single-float-rep [ ##set-alien-float ] } + { double-float-rep [ ##set-alien-double ] } } case ] inline-alien-float-setter ; diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor index 7b407c3ee4..d4aa2750c0 100644 --- a/basis/compiler/cfg/intrinsics/allot/allot.factor +++ b/basis/compiler/cfg/intrinsics/allot/allot.factor @@ -1,18 +1,18 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.order sequences accessors arrays byte-arrays layouts classes.tuple.private fry locals compiler.tree.propagation.info compiler.cfg.hats compiler.cfg.instructions compiler.cfg.stacks -compiler.cfg.utilities ; +compiler.cfg.utilities compiler.cfg.builder.blocks ; IN: compiler.cfg.intrinsics.allot : ##set-slots ( regs obj class -- ) - '[ _ swap 1+ _ tag-number ##set-slot-imm ] each-index ; + '[ _ swap 1 + _ tag-number ##set-slot-imm ] each-index ; : emit-simple-allot ( node -- ) [ in-d>> length ] [ node-output-infos first class>> ] bi - [ drop ds-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri + [ drop ds-load ] [ [ 1 + cells ] dip ^^allot ] [ nip ] 2tri [ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ; : tuple-slot-regs ( layout -- vregs ) diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index cb5f2e926d..d4b9db58c8 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -1,14 +1,15 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: sequences accessors layouts kernel math namespaces -combinators fry locals +USING: sequences accessors layouts kernel math math.intervals +namespaces combinators fry arrays compiler.tree.propagation.info compiler.cfg.hats compiler.cfg.stacks -compiler.cfg.iterator compiler.cfg.instructions compiler.cfg.utilities -compiler.cfg.registers ; +compiler.cfg.builder.blocks +compiler.cfg.registers +compiler.cfg.comparisons ; IN: compiler.cfg.intrinsics.fixnum : emit-both-fixnums? ( -- ) @@ -18,60 +19,42 @@ IN: compiler.cfg.intrinsics.fixnum 0 cc= ^^compare-imm ds-push ; -: (emit-fixnum-imm-op) ( infos insn -- dst ) - ds-drop - [ ds-pop ] - [ second literal>> [ tag-fixnum ] [ \ f tag-number ] if* ] - [ ] - tri* - call ; inline +: tag-literal ( n -- tagged ) + literal>> [ tag-fixnum ] [ \ f tag-number ] if* ; -: (emit-fixnum-op) ( insn -- dst ) - [ 2inputs ] dip call ; inline +: emit-fixnum-op ( insn -- ) + [ 2inputs ] dip call ds-push ; inline -:: emit-fixnum-op ( node insn imm-insn -- ) - [let | infos [ node node-input-infos ] | - infos second value-info-small-tagged? - [ infos imm-insn (emit-fixnum-imm-op) ] - [ insn (emit-fixnum-op) ] - if - ds-push - ] ; inline +: emit-fixnum-left-shift ( -- ) + [ ^^untag-fixnum ^^shl ] emit-fixnum-op ; + +: emit-fixnum-right-shift ( -- ) + [ ^^untag-fixnum ^^neg ^^sar dup tag-mask get ^^and-imm ^^xor ] emit-fixnum-op ; + +: emit-fixnum-shift-general ( -- ) + ds-peek 0 cc> ##compare-imm-branch + [ emit-fixnum-left-shift ] with-branch + [ emit-fixnum-right-shift ] with-branch + 2array emit-conditional ; : emit-fixnum-shift-fast ( node -- ) - dup node-input-infos dup second value-info-small-fixnum? [ - nip - [ ds-drop ds-pop ] dip - second literal>> dup sgn { - { -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] } - { 0 [ drop ] } - { 1 [ ^^shl-imm ] } - } case - ds-push - ] [ drop emit-primitive ] if ; - + node-input-infos second interval>> { + { [ dup 0 [a,inf] interval-subset? ] [ drop emit-fixnum-left-shift ] } + { [ 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) ( -- dst ) - 2inputs ^^untag-fixnum ^^mul ; +: emit-fixnum*fast ( -- ) + 2inputs ^^untag-fixnum ^^mul ds-push ; -: (emit-fixnum*fast-imm) ( infos -- dst ) - ds-drop - [ ds-pop ] [ second literal>> ] bi* ^^mul-imm ; - -: emit-fixnum*fast ( node -- ) - node-input-infos - dup second value-info-small-fixnum? - [ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if - ds-push ; - -: emit-fixnum-comparison ( node cc -- ) - [ ^^compare ] [ ^^compare-imm ] bi-curry - emit-fixnum-op ; +: emit-fixnum-comparison ( cc -- ) + '[ _ ^^compare ] emit-fixnum-op ; : emit-bignum>fixnum ( -- ) ds-pop ^^bignum>integer ^^tag-fixnum ds-push ; @@ -79,15 +62,30 @@ IN: compiler.cfg.intrinsics.fixnum : emit-fixnum>bignum ( -- ) ds-pop ^^untag-fixnum ^^integer>bignum ds-push ; -: emit-fixnum-overflow-op ( quot quot-tail -- next ) - [ 2inputs 1 ##inc-d ] 2dip - tail-call? [ - ##epilogue - nip call - stop-iterating - ] [ - drop call - ##branch - begin-basic-block - iterate-next - ] if ; inline +: emit-no-overflow-case ( dst -- final-bb ) + [ ds-drop ds-drop ds-push ] with-branch ; + +: emit-overflow-case ( word -- final-bb ) + [ ##call -1 adjust-d ] with-branch ; + +: emit-fixnum-overflow-op ( quot word -- ) + ! Inputs to the final instruction need to be copied because + ! of loc>vreg sync + [ [ (2inputs) [ ^^copy ] bi@ ] dip call ] dip + [ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array + emit-conditional ; inline + +: fixnum+overflow ( x y -- z ) [ >bignum ] bi@ + ; + +: fixnum-overflow ( x y -- z ) [ >bignum ] bi@ - ; + +: fixnum*overflow ( x y -- z ) [ >bignum ] bi@ * ; + +: emit-fixnum+ ( -- ) + [ ^^fixnum-add ] \ fixnum+overflow emit-fixnum-overflow-op ; + +: emit-fixnum- ( -- ) + [ ^^fixnum-sub ] \ fixnum-overflow emit-fixnum-overflow-op ; + +: emit-fixnum* ( -- ) + [ ^^untag-fixnum ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ; \ No newline at end of file diff --git a/basis/compiler/cfg/intrinsics/float/float.factor b/basis/compiler/cfg/intrinsics/float/float.factor index 84a0bc9ca0..fd4ca53d6c 100644 --- a/basis/compiler/cfg/intrinsics/float/float.factor +++ b/basis/compiler/cfg/intrinsics/float/float.factor @@ -1,19 +1,26 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions compiler.cfg.utilities ; IN: compiler.cfg.intrinsics.float : emit-float-op ( insn -- ) - [ 2inputs [ ^^unbox-float ] bi@ ] dip call ^^box-float - ds-push ; inline + [ 2inputs ] dip call ds-push ; inline : emit-float-comparison ( cc -- ) - [ 2inputs [ ^^unbox-float ] bi@ ] dip ^^compare-float - ds-push ; inline + [ 2inputs ] dip ^^compare-float ds-push ; inline : emit-float>fixnum ( -- ) - ds-pop ^^unbox-float ^^float>integer ^^tag-fixnum ds-push ; + ds-pop ^^float>integer ^^tag-fixnum ds-push ; : emit-fixnum>float ( -- ) - ds-pop ^^untag-fixnum ^^integer>float ^^box-float ds-push ; + ds-pop ^^untag-fixnum ^^integer>float ds-push ; + +: emit-fsqrt ( -- ) + ds-pop ^^sqrt ds-push ; + +: emit-unary-float-function ( func -- ) + [ ds-pop ] dip ^^unary-float-function ds-push ; + +: emit-binary-float-function ( func -- ) + [ 2inputs ] dip ^^binary-float-function ds-push ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index ec819f9440..920def14c1 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: words sequences kernel combinators cpu.architecture +USING: words sequences kernel combinators cpu.architecture assocs compiler.cfg.hats compiler.cfg.instructions compiler.cfg.intrinsics.alien @@ -9,7 +9,9 @@ compiler.cfg.intrinsics.fixnum compiler.cfg.intrinsics.float compiler.cfg.intrinsics.slots compiler.cfg.intrinsics.misc -compiler.cfg.iterator ; +compiler.cfg.comparisons ; +QUALIFIED: alien +QUALIFIED: alien.accessors QUALIFIED: kernel QUALIFIED: arrays QUALIFIED: byte-arrays @@ -19,142 +21,126 @@ QUALIFIED: strings.private QUALIFIED: classes.tuple.private QUALIFIED: math.private QUALIFIED: math.integers.private -QUALIFIED: alien.accessors +QUALIFIED: math.floats.private +QUALIFIED: math.libm IN: compiler.cfg.intrinsics +: enable-intrinsics ( alist -- ) + [ "intrinsic" set-word-prop ] assoc-each ; + { - kernel.private:tag - kernel.private:getenv - math.private:both-fixnums? - math.private:fixnum+ - math.private:fixnum- - math.private:fixnum* - math.private:fixnum+fast - math.private:fixnum-fast - math.private:fixnum-bitand - math.private:fixnum-bitor - math.private:fixnum-bitxor - math.private:fixnum-shift-fast - math.private:fixnum-bitnot - math.private:fixnum*fast - math.private:fixnum< - math.private:fixnum<= - math.private:fixnum>= - math.private:fixnum> - math.private:bignum>fixnum - math.private:fixnum>bignum - kernel:eq? - slots.private:slot - slots.private:set-slot - strings.private:string-nth - strings.private:set-string-nth-fast - classes.tuple.private: - arrays: - byte-arrays: - byte-arrays:(byte-array) - kernel: - alien.accessors:alien-unsigned-1 - alien.accessors:set-alien-unsigned-1 - alien.accessors:alien-signed-1 - alien.accessors:set-alien-signed-1 - alien.accessors:alien-unsigned-2 - alien.accessors:set-alien-unsigned-2 - alien.accessors:alien-signed-2 - alien.accessors:set-alien-signed-2 - alien.accessors:alien-cell - alien.accessors:set-alien-cell -} [ t "intrinsic" set-word-prop ] each + { kernel.private:tag [ drop emit-tag ] } + { kernel.private:getenv [ emit-getenv ] } + { math.private:both-fixnums? [ drop emit-both-fixnums? ] } + { 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-shift-fast [ emit-fixnum-shift-fast ] } + { math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] } + { 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 ] } + { slots.private:slot [ emit-slot ] } + { slots.private:set-slot [ emit-set-slot ] } + { strings.private:string-nth [ drop emit-string-nth ] } + { strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast ] } + { classes.tuple.private: [ emit- ] } + { arrays: [ emit- ] } + { byte-arrays: [ emit- ] } + { byte-arrays:(byte-array) [ emit-(byte-array) ] } + { kernel: [ emit-simple-allot ] } + { alien: [ emit- ] } + { alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] } + { alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] } + { alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] } + { alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] } + { alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] } + { alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] } + { alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] } + { alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] } + { alien.accessors:alien-cell [ emit-alien-cell-getter ] } + { alien.accessors:set-alien-cell [ emit-alien-cell-setter ] } +} enable-intrinsics : enable-alien-4-intrinsics ( -- ) { - alien.accessors:alien-unsigned-4 - alien.accessors:set-alien-unsigned-4 - alien.accessors:alien-signed-4 - alien.accessors:set-alien-signed-4 - } [ t "intrinsic" set-word-prop ] each ; + { 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 ] } + } enable-intrinsics ; : enable-float-intrinsics ( -- ) { - math.private:float+ - math.private:float- - math.private:float* - math.private:float/f - math.private:fixnum>float - math.private:float>fixnum - math.private:float< - math.private:float<= - math.private:float> - math.private:float>= - math.private:float= - alien.accessors:alien-float - alien.accessors:set-alien-float - alien.accessors:alien-double - alien.accessors:set-alien-double - } [ t "intrinsic" set-word-prop ] each ; + { 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 cc< emit-float-comparison ] } + { math.private:float<= [ drop cc<= emit-float-comparison ] } + { math.private:float>= [ drop cc>= emit-float-comparison ] } + { math.private:float> [ drop cc> emit-float-comparison ] } + { math.private:float= [ drop cc= emit-float-comparison ] } + { math.private:float>fixnum [ drop emit-float>fixnum ] } + { math.private:fixnum>float [ drop emit-fixnum>float ] } + { alien.accessors:alien-float [ single-float-rep emit-alien-float-getter ] } + { alien.accessors:set-alien-float [ single-float-rep emit-alien-float-setter ] } + { alien.accessors:alien-double [ double-float-rep emit-alien-float-getter ] } + { alien.accessors:set-alien-double [ double-float-rep emit-alien-float-setter ] } + } enable-intrinsics ; + +: enable-fsqrt ( -- ) + { + { math.libm:fsqrt [ drop emit-fsqrt ] } + } 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 ] } + } enable-intrinsics ; + +: enable-float-functions ( -- ) + { + { math.libm:facos [ drop "acos" emit-unary-float-function ] } + { math.libm:fasin [ drop "asin" emit-unary-float-function ] } + { math.libm:fatan [ drop "atan" emit-unary-float-function ] } + { math.libm:fatan2 [ drop "atan2" emit-binary-float-function ] } + { math.libm:fcos [ drop "cos" emit-unary-float-function ] } + { math.libm:fsin [ drop "sin" emit-unary-float-function ] } + { math.libm:ftan [ drop "tan" emit-unary-float-function ] } + { math.libm:fcosh [ drop "cosh" emit-unary-float-function ] } + { math.libm:fsinh [ drop "sinh" emit-unary-float-function ] } + { math.libm:ftanh [ drop "tanh" emit-unary-float-function ] } + { math.libm:fexp [ drop "exp" emit-unary-float-function ] } + { math.libm:flog [ drop "log" emit-unary-float-function ] } + { math.libm:fpow [ drop "pow" emit-binary-float-function ] } + { math.libm:facosh [ drop "acosh" emit-unary-float-function ] } + { math.libm:fasinh [ drop "asinh" emit-unary-float-function ] } + { math.libm:fatanh [ drop "atanh" emit-unary-float-function ] } + { math.libm:fsqrt [ drop "sqrt" emit-unary-float-function ] } + { math.floats.private:float-min [ drop "fmin" emit-binary-float-function ] } + { math.floats.private:float-max [ drop "fmax" emit-binary-float-function ] } + } enable-intrinsics ; + +: enable-min/max ( -- ) + { + { math.integers.private:fixnum-min [ drop [ ^^min ] emit-fixnum-op ] } + { math.integers.private:fixnum-max [ drop [ ^^max ] emit-fixnum-op ] } + } enable-intrinsics ; : enable-fixnum-log2 ( -- ) - \ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ; - -: emit-intrinsic ( node word -- node/f ) { - { \ kernel.private:tag [ drop emit-tag iterate-next ] } - { \ kernel.private:getenv [ emit-getenv iterate-next ] } - { \ math.private:both-fixnums? [ drop emit-both-fixnums? iterate-next ] } - { \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] } - { \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] } - { \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] [ i i ##fixnum-mul-tail ] emit-fixnum-overflow-op ] } - { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op iterate-next ] } - { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op iterate-next ] } - { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op iterate-next ] } - { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op iterate-next ] } - { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op iterate-next ] } - { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast iterate-next ] } - { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot iterate-next ] } - { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 iterate-next ] } - { \ math.private:fixnum*fast [ emit-fixnum*fast iterate-next ] } - { \ math.private:fixnum< [ cc< emit-fixnum-comparison iterate-next ] } - { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison iterate-next ] } - { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison iterate-next ] } - { \ math.private:fixnum> [ cc> emit-fixnum-comparison iterate-next ] } - { \ kernel:eq? [ cc= emit-fixnum-comparison iterate-next ] } - { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum iterate-next ] } - { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum iterate-next ] } - { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op iterate-next ] } - { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op iterate-next ] } - { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op iterate-next ] } - { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op iterate-next ] } - { \ math.private:float< [ drop cc< emit-float-comparison iterate-next ] } - { \ math.private:float<= [ drop cc<= emit-float-comparison iterate-next ] } - { \ math.private:float>= [ drop cc>= emit-float-comparison iterate-next ] } - { \ math.private:float> [ drop cc> emit-float-comparison iterate-next ] } - { \ math.private:float= [ drop cc= emit-float-comparison iterate-next ] } - { \ math.private:float>fixnum [ drop emit-float>fixnum iterate-next ] } - { \ math.private:fixnum>float [ drop emit-fixnum>float iterate-next ] } - { \ slots.private:slot [ emit-slot iterate-next ] } - { \ slots.private:set-slot [ emit-set-slot iterate-next ] } - { \ strings.private:string-nth [ drop emit-string-nth iterate-next ] } - { \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast iterate-next ] } - { \ classes.tuple.private: [ emit- iterate-next ] } - { \ arrays: [ emit- iterate-next ] } - { \ byte-arrays: [ emit- iterate-next ] } - { \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] } - { \ kernel: [ emit-simple-allot iterate-next ] } - { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter iterate-next ] } - { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter iterate-next ] } - { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter iterate-next ] } - { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter iterate-next ] } - { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter iterate-next ] } - { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter iterate-next ] } - { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter iterate-next ] } - { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter iterate-next ] } - { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter iterate-next ] } - { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter iterate-next ] } - { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter iterate-next ] } - { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter iterate-next ] } - { \ alien.accessors:alien-cell [ emit-alien-cell-getter iterate-next ] } - { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter iterate-next ] } - { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter iterate-next ] } - { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter iterate-next ] } - { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter iterate-next ] } - { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter iterate-next ] } - } case ; + { math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] } + } enable-intrinsics ; + +: emit-intrinsic ( node word -- ) + "intrinsic" word-prop call( node -- ) ; diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor index 0cc6e6f5d0..79e56c08ad 100644 --- a/basis/compiler/cfg/intrinsics/slots/slots.factor +++ b/basis/compiler/cfg/intrinsics/slots/slots.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: layouts namespaces kernel accessors sequences -classes.algebra compiler.tree.propagation.info -compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions -compiler.cfg.utilities ; +USING: layouts namespaces kernel accessors sequences classes.algebra +compiler.tree.propagation.info compiler.cfg.stacks compiler.cfg.hats +compiler.cfg.registers compiler.cfg.instructions +compiler.cfg.utilities compiler.cfg.builder.blocks ; IN: compiler.cfg.intrinsics.slots : value-tag ( info -- n ) class>> class-tag ; inline @@ -45,7 +45,7 @@ IN: compiler.cfg.intrinsics.slots dup third value-info-small-fixnum? [ (emit-set-slot-imm) ] [ (emit-set-slot) ] if ] [ first class>> immediate class<= ] bi - [ drop ] [ i i ##write-barrier ] if + [ drop ] [ next-vreg next-vreg ##write-barrier ] if ] [ drop emit-primitive ] if ; : emit-string-nth ( -- ) @@ -53,4 +53,4 @@ IN: compiler.cfg.intrinsics.slots : emit-set-string-nth-fast ( -- ) 3inputs [ ^^untag-fixnum ] [ ^^untag-fixnum ] [ ] tri* - swap i ##set-string-nth-fast ; + swap next-vreg ##set-string-nth-fast ; diff --git a/basis/compiler/cfg/iterator/iterator.factor b/basis/compiler/cfg/iterator/iterator.factor deleted file mode 100644 index eb7f71ad60..0000000000 --- a/basis/compiler/cfg/iterator/iterator.factor +++ /dev/null @@ -1,45 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: namespaces sequences kernel compiler.tree ; -IN: compiler.cfg.iterator - -SYMBOL: node-stack - -: >node ( cursor -- ) node-stack get push ; -: node> ( -- cursor ) node-stack get pop ; -: node@ ( -- cursor ) node-stack get last ; -: current-node ( -- node ) node@ first ; -: iterate-next ( -- cursor ) node@ rest-slice ; -: skip-next ( -- next ) node> rest-slice [ first ] [ >node ] bi ; - -: iterate-nodes ( cursor quot: ( -- ) -- ) - over empty? [ - 2drop - ] [ - [ swap >node call node> drop ] keep iterate-nodes - ] if ; inline recursive - -DEFER: (tail-call?) - -: tail-phi? ( cursor -- ? ) - [ first #phi? ] [ rest-slice (tail-call?) ] bi and ; - -: (tail-call?) ( cursor -- ? ) - [ t ] [ - [ - first - [ #return? ] - [ #return-recursive? ] - [ #terminate? ] tri or or - ] [ tail-phi? ] bi or - ] if-empty ; - -: tail-call? ( -- ? ) - node-stack get [ - rest-slice - [ t ] [ (tail-call?) ] if-empty - ] all? ; - -: terminate-call? ( -- ? ) - node-stack get last - rest-slice [ f ] [ first #terminate? ] if-empty ; diff --git a/basis/compiler/cfg/iterator/summary.txt b/basis/compiler/cfg/iterator/summary.txt deleted file mode 100644 index b5afb479bd..0000000000 --- a/basis/compiler/cfg/iterator/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Utility for iterating for high-level IR diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index 7b56bd6150..c23867ffe2 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -1,324 +1,81 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces sequences math math.order kernel assocs -accessors vectors fry heaps cpu.architecture sorting locals -combinators compiler.cfg.registers -compiler.cfg.linear-scan.live-intervals hints ; +USING: accessors assocs heaps kernel namespaces sequences fry math +math.order combinators arrays sorting compiler.utilities locals +compiler.cfg.linear-scan.live-intervals +compiler.cfg.linear-scan.allocation.spilling +compiler.cfg.linear-scan.allocation.splitting +compiler.cfg.linear-scan.allocation.state ; IN: compiler.cfg.linear-scan.allocation -! Mapping from register classes to sequences of machine registers -SYMBOL: free-registers +: active-positions ( new assoc -- ) + [ vreg>> active-intervals-for ] dip + '[ [ 0 ] dip reg>> _ add-use-position ] each ; -: free-registers-for ( vreg -- seq ) - reg-class>> free-registers get at ; +: inactive-positions ( new assoc -- ) + [ [ vreg>> inactive-intervals-for ] keep ] dip + '[ + [ _ relevant-ranges intersect-live-ranges 1/0. or ] [ reg>> ] bi + _ add-use-position + ] each ; -: deallocate-register ( live-interval -- ) - [ reg>> ] [ vreg>> ] bi free-registers-for push ; +: register-status ( new -- free-pos ) + dup free-positions + [ inactive-positions ] [ active-positions ] [ nip ] 2tri + >alist alist-max ; -! Vector of active live intervals -SYMBOL: active-intervals - -: active-intervals-for ( vreg -- seq ) - reg-class>> active-intervals get at ; - -: add-active ( live-interval -- ) - dup vreg>> active-intervals-for push ; - -: delete-active ( live-interval -- ) - dup vreg>> active-intervals-for delq ; - -! Vector of inactive live intervals -SYMBOL: inactive-intervals - -: inactive-intervals-for ( vreg -- seq ) - reg-class>> inactive-intervals get at ; - -: add-inactive ( live-interval -- ) - dup vreg>> inactive-intervals-for push ; - -! Vector of handled live intervals -SYMBOL: handled-intervals - -: add-handled ( live-interval -- ) - handled-intervals get push ; - -: finished? ( n live-interval -- ? ) end>> swap < ; - -: finish ( n live-interval -- keep? ) - nip [ deallocate-register ] [ add-handled ] bi f ; - -: activate ( n live-interval -- keep? ) - nip add-active f ; - -: deactivate ( n live-interval -- keep? ) - nip add-inactive f ; - -: don't-change ( n live-interval -- keep? ) 2drop t ; - -! Moving intervals between active and inactive sets -: process-intervals ( n symbol quots -- ) - ! symbol stores an alist mapping register classes to vectors - [ get values ] dip '[ [ _ cond ] with filter-here ] with each ; inline - -: covers? ( insn# live-interval -- ? ) - ranges>> [ [ from>> ] [ to>> ] bi between? ] with any? ; - -: deactivate-intervals ( n -- ) - ! Any active intervals which have ended are moved to handled - ! Any active intervals which cover the current position - ! are moved to inactive - active-intervals { - { [ 2dup finished? ] [ finish ] } - { [ 2dup covers? not ] [ deactivate ] } - [ don't-change ] - } process-intervals ; - -: activate-intervals ( n -- ) - ! Any inactive intervals which have ended are moved to handled - ! Any inactive intervals which do not cover the current position - ! are moved to active - inactive-intervals { - { [ 2dup finished? ] [ finish ] } - { [ 2dup covers? ] [ activate ] } - [ don't-change ] - } process-intervals ; - -! Minheap of live intervals which still need a register allocation -SYMBOL: unhandled-intervals - -! Start index of current live interval. We ensure that all -! live intervals added to the unhandled set have a start index -! strictly greater than ths one. This ensures that we can catch -! infinite loop situations. -SYMBOL: progress - -: check-progress ( live-interval -- ) - start>> progress get <= [ "No progress" throw ] when ; inline - -: add-unhandled ( live-interval -- ) - [ check-progress ] - [ dup start>> unhandled-intervals get heap-push ] - bi ; - -: init-unhandled ( live-intervals -- ) - [ [ start>> ] keep ] { } map>assoc - unhandled-intervals get heap-push-all ; - -! Coalescing -: active-interval ( vreg -- live-interval ) - dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ; - -: coalesce? ( live-interval -- ? ) - [ start>> ] [ copy-from>> active-interval ] bi - dup [ end>> = ] [ 2drop f ] if ; - -: coalesce ( live-interval -- ) - dup copy-from>> active-interval - [ [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ] - [ reg>> >>reg drop ] - 2bi ; - -! Splitting -: split-range ( live-range n -- before after ) - [ [ from>> ] dip ] - [ 1 + swap to>> ] - 2bi ; - -: split-last-range? ( last n -- ? ) - swap to>> <= ; - -: split-last-range ( before after last n -- before' after' ) - split-range [ [ but-last ] dip suffix ] [ prefix ] bi-curry* bi* ; - -: split-ranges ( live-ranges n -- before after ) - [ '[ from>> _ <= ] partition ] - [ - pick empty? [ drop ] [ - [ over last ] dip 2dup split-last-range? - [ split-last-range ] [ 2drop ] if - ] if - ] bi ; - -: split-uses ( uses n -- before after ) - '[ _ <= ] partition ; - -: record-split ( live-interval before after -- ) - [ >>split-before ] [ >>split-after ] bi* drop ; inline - -: check-split ( live-interval -- ) - [ end>> ] [ start>> ] bi - 0 = - [ "BUG: splitting atomic interval" throw ] when ; inline - -: split-before ( before -- before' ) - [ [ ranges>> last ] [ uses>> last ] bi >>to drop ] - [ compute-start/end ] - [ ] - tri ; inline - -: split-after ( after -- after' ) - [ [ ranges>> first ] [ uses>> first ] bi >>from drop ] - [ compute-start/end ] - [ ] - tri ; inline - -:: split-interval ( live-interval n -- before after ) - live-interval check-split - live-interval clone :> before - live-interval clone f >>copy-from f >>reg :> after - live-interval uses>> n split-uses before after [ (>>uses) ] bi-curry@ bi* - live-interval ranges>> n split-ranges before after [ (>>ranges) ] bi-curry@ bi* - live-interval before after record-split - before split-before - after split-after ; - -HINTS: split-interval live-interval object ; - -! Spilling -SYMBOL: spill-counts - -: next-spill-location ( reg-class -- n ) - spill-counts get [ dup 1+ ] change-at ; - -: find-use ( live-interval n quot -- i elt ) - [ uses>> ] 2dip curry find ; inline - -: interval-to-spill ( active-intervals current -- live-interval ) - #! We spill the interval with the most distant use location. - start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc - [ ] [ [ [ second ] bi@ > ] most ] map-reduce first ; - -: assign-spill ( before after -- before after ) - #! If it has been spilled already, reuse spill location. - over reload-from>> - [ over vreg>> reg-class>> next-spill-location ] unless* - [ >>spill-to ] [ >>reload-from ] bi-curry bi* ; - -: split-and-spill ( new existing -- before after ) - swap start>> split-interval assign-spill ; - -: reuse-register ( new existing -- ) - reg>> >>reg add-active ; - -: spill-existing ( new existing -- ) - #! Our new interval will be used before the active interval - #! with the most distant use location. Spill the existing - #! interval, then process the new interval and the tail end - #! of the existing interval again. - [ reuse-register ] - [ nip delete-active ] - [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2tri ; - -: spill-new ( new existing -- ) - #! Our new interval will be used after the active interval - #! with the most distant use location. Split the new - #! interval, then process both parts of the new interval - #! again. - [ dup split-and-spill add-unhandled ] dip spill-existing ; - -: spill-existing? ( new existing -- ? ) - #! Test if 'new' will be used before 'existing'. - over start>> '[ _ [ > ] find-use nip -1 or ] bi@ < ; - -: assign-blocked-register ( new -- ) - [ dup vreg>> active-intervals-for ] keep interval-to-spill - 2dup spill-existing? [ spill-existing ] [ spill-new ] if ; - -: assign-free-register ( new registers -- ) - pop >>reg add-active ; - -: relevant-ranges ( new inactive -- new' inactive' ) - ! Slice off all ranges of 'inactive' that precede the start of 'new' - [ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ; - -: intersect-live-range ( range1 range2 -- n/f ) - 2dup [ from>> ] bi@ > [ swap ] when - 2dup [ to>> ] [ from>> ] bi* >= [ nip from>> ] [ 2drop f ] if ; - -: intersect-live-ranges ( ranges1 ranges2 -- n ) - { - { [ over empty? ] [ 2drop 1/0. ] } - { [ dup empty? ] [ 2drop 1/0. ] } - [ - 2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [ - drop - 2dup [ first from>> ] bi@ < - [ [ rest-slice ] dip ] [ rest-slice ] if - intersect-live-ranges - ] if - ] - } cond ; - -: intersect-inactive ( new inactive -- n ) - relevant-ranges intersect-live-ranges ; - -: intersecting-inactive ( new -- live-intervals ) - dup vreg>> inactive-intervals-for - [ tuck intersect-inactive ] with { } map>assoc ; - -: fits-in-hole ( new pair -- ) - first reuse-register ; - -: split-before-use ( new pair -- before after ) - ! Find optimal split position - ! Insert move instruction - second split-interval ; - -: assign-inactive-register ( new live-intervals -- ) - ! If there is an interval which is inactive for the entire lifetime - ! if the new interval, reuse its vreg. Otherwise, split new so that - ! the first half fits. - sort-values last - 2dup [ end>> ] [ second ] bi* < [ - fits-in-hole - ] [ - [ split-before-use ] keep - '[ _ fits-in-hole ] [ add-unhandled ] bi* - ] if ; +: no-free-registers? ( result -- ? ) + second 0 = ; inline : assign-register ( new -- ) - dup coalesce? [ coalesce ] [ - dup vreg>> free-registers-for [ - dup intersecting-inactive - [ assign-blocked-register ] - [ assign-inactive-register ] - if-empty - ] [ assign-free-register ] - if-empty - ] if ; + dup register-status { + { [ dup no-free-registers? ] [ drop assign-blocked-register ] } + { [ 2dup register-available? ] [ register-available ] } + [ drop assign-blocked-register ] + } cond ; -! Main loop -CONSTANT: reg-classes { int-regs double-float-regs } +: handle-sync-point ( n -- ) + [ active-intervals get values ] dip + [ '[ [ _ spill ] each ] each ] + [ drop [ delete-all ] each ] + 2bi ; -: reg-class-assoc ( quot -- assoc ) - [ reg-classes ] dip { } map>assoc ; inline - -: init-allocator ( registers -- ) - [ reverse >vector ] assoc-map free-registers set - [ 0 ] reg-class-assoc spill-counts set - unhandled-intervals set - [ V{ } clone ] reg-class-assoc active-intervals set - [ V{ } clone ] reg-class-assoc inactive-intervals set - V{ } clone handled-intervals set - -1 progress set ; - -: handle-interval ( live-interval -- ) - [ - start>> +:: handle-progress ( n sync? -- ) + n { [ progress set ] [ deactivate-intervals ] - [ activate-intervals ] tri - ] [ assign-register ] bi ; + [ sync? [ handle-sync-point ] [ drop ] if ] + [ activate-intervals ] + } cleave ; + +GENERIC: handle ( obj -- ) + +M: live-interval handle ( live-interval -- ) + [ start>> f handle-progress ] [ assign-register ] bi ; + +M: sync-point handle ( sync-point -- ) + n>> t handle-progress ; + +: smallest-heap ( heap1 heap2 -- heap ) + ! If heap1 and heap2 have the same key, favors heap1. + [ [ heap-peek nip ] bi@ <= ] most ; : (allocate-registers) ( -- ) - unhandled-intervals get [ handle-interval ] slurp-heap ; + { + { [ 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 ; : finish-allocation ( -- ) - ! Sanity check: all live intervals should've been processed active-intervals inactive-intervals [ get values [ handled-intervals get push-all ] each ] bi@ ; -: allocate-registers ( live-intervals machine-registers -- live-intervals ) - #! This modifies the input live-intervals. +: allocate-registers ( live-intervals sync-point machine-registers -- live-intervals ) init-allocator init-unhandled (allocate-registers) diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor new file mode 100644 index 0000000000..11874a567f --- /dev/null +++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor @@ -0,0 +1,144 @@ +! Copyright (C) 2009 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 +combinators.short-circuit compiler.utilities +compiler.cfg.linear-scan.allocation.state +compiler.cfg.linear-scan.allocation.splitting +compiler.cfg.linear-scan.live-intervals ; +IN: compiler.cfg.linear-scan.allocation.spilling + +ERROR: bad-live-ranges interval ; + +: check-ranges ( live-interval -- ) + check-allocation? get [ + dup ranges>> [ [ from>> ] [ to>> ] bi <= ] all? + [ drop ] [ bad-live-ranges ] if + ] [ drop ] if ; + +: trim-before-ranges ( live-interval -- ) + [ ranges>> ] [ uses>> last 1 + ] bi + [ '[ from>> _ <= ] filter-here ] + [ swap last (>>to) ] + 2bi ; + +: trim-after-ranges ( live-interval -- ) + [ ranges>> ] [ uses>> first ] bi + [ '[ to>> _ >= ] filter-here ] + [ swap first (>>from) ] + 2bi ; + +: assign-spill ( live-interval -- ) + dup vreg>> vreg-spill-slot >>spill-to drop ; + +: spill-before ( before -- before/f ) + ! If the interval does not have any usages before the spill location, + ! then it is the second child of an interval that was split. We reload + ! the value and let the resolve pass insert a split later. + dup uses>> empty? [ drop f ] [ + { + [ ] + [ assign-spill ] + [ trim-before-ranges ] + [ compute-start/end ] + [ check-ranges ] + } cleave + ] if ; + +: assign-reload ( live-interval -- ) + dup vreg>> vreg-spill-slot >>reload-from drop ; + +: spill-after ( after -- after/f ) + ! If the interval has no more usages after the spill location, + ! then it is the first child of an interval that was split. We + ! spill the value and let the resolve pass insert a reload later. + dup uses>> empty? [ drop f ] [ + { + [ ] + [ assign-reload ] + [ trim-after-ranges ] + [ compute-start/end ] + [ check-ranges ] + } cleave + ] if ; + +: split-for-spill ( live-interval n -- before after ) + split-interval [ spill-before ] [ spill-after ] bi* ; + +: find-use-position ( live-interval new -- n ) + [ uses>> ] [ start>> '[ _ >= ] ] bi* find nip 1/0. or ; + +: 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 + find-use-positions ; + +: inactive-positions ( new assoc -- ) + [ + [ vreg>> inactive-intervals-for ] keep + [ '[ _ intervals-intersect? ] filter ] keep + ] dip + find-use-positions ; + +: spill-status ( new -- use-pos ) + H{ } clone + [ inactive-positions ] [ active-positions ] [ nip ] 2tri + >alist alist-max ; + +: spill-new? ( new pair -- ? ) + [ uses>> first ] [ second ] bi* > ; + +: spill-new ( new pair -- ) + drop spill-after add-unhandled ; + +: spill ( live-interval n -- ) + split-for-spill + [ [ add-handled ] when* ] + [ [ add-unhandled ] when* ] bi* ; + +:: spill-intersecting-active ( new reg -- ) + ! 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 + '[ _ delete-nth 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 [ + dup reg>> reg = [ + dup new intervals-intersect? [ + new start>> spill f + ] [ drop t ] if + ] [ drop t ] if + ] filter-here ; + +: spill-intersecting ( new reg -- ) + ! Split and spill all active and inactive intervals + ! which intersect 'new' and use 'reg'. + [ spill-intersecting-active ] + [ spill-intersecting-inactive ] + 2bi ; + +: spill-available ( new pair -- ) + ! A register would become fully available if all + ! active and inactive intervals using it were split + ! and spilled. + [ first spill-intersecting ] [ register-available ] 2bi ; + +: spill-partially-available ( new pair -- ) + ! A register would be available for part of the new + ! interval's lifetime if all active and inactive intervals + ! using that register were split and spilled. + [ second 1 - split-for-spill [ add-unhandled ] when* ] keep + '[ _ spill-available ] when* ; + +: assign-blocked-register ( new -- ) + dup spill-status { + { [ 2dup spill-new? ] [ spill-new ] } + { [ 2dup register-available? ] [ spill-available ] } + [ spill-partially-available ] + } cond ; \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor new file mode 100644 index 0000000000..1a2b0f2f2b --- /dev/null +++ b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor @@ -0,0 +1,59 @@ +! Copyright (C) 2009 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 +compiler.cfg.linear-scan.allocation.state +compiler.cfg.linear-scan.live-intervals ; +IN: compiler.cfg.linear-scan.allocation.splitting + +: split-range ( live-range n -- before after ) + [ [ from>> ] dip ] + [ 1 + swap to>> ] + 2bi ; + +: split-last-range? ( last n -- ? ) + swap to>> <= ; + +: split-last-range ( before after last n -- before' after' ) + split-range [ [ but-last ] dip suffix ] [ prefix ] bi-curry* bi* ; + +: split-ranges ( live-ranges n -- before after ) + [ '[ from>> _ <= ] partition ] + [ + [ over last ] dip 2dup split-last-range? + [ split-last-range ] [ 2drop ] if + ] bi ; + +: split-uses ( uses n -- before after ) + '[ _ <= ] partition ; + +ERROR: splitting-too-early ; + +ERROR: splitting-too-late ; + +ERROR: splitting-atomic-interval ; + +: check-split ( live-interval n -- ) + check-allocation? get [ + [ [ start>> ] dip > [ splitting-too-early ] when ] + [ [ end>> ] dip <= [ splitting-too-late ] when ] + [ drop [ end>> ] [ start>> ] bi = [ splitting-atomic-interval ] when ] + 2tri + ] [ 2drop ] if ; inline + +: split-before ( before -- before' ) + f >>spill-to ; inline + +: split-after ( after -- after' ) + f >>reg f >>reload-from ; inline + +:: split-interval ( live-interval n -- before after ) + live-interval n check-split + live-interval clone :> before + live-interval clone :> after + live-interval uses>> n split-uses before after [ (>>uses) ] bi-curry@ bi* + live-interval ranges>> n split-ranges before after [ (>>ranges) ] bi-curry@ bi* + before split-before + after split-after ; + +HINTS: split-interval live-interval object ; diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor new file mode 100644 index 0000000000..a311f97b66 --- /dev/null +++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor @@ -0,0 +1,158 @@ +! 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 +compiler.cfg compiler.cfg.registers +compiler.cfg.linear-scan.live-intervals ; +IN: compiler.cfg.linear-scan.allocation.state + +! Start index of current live interval. We ensure that all +! live intervals added to the unhandled set have a start index +! strictly greater than this one. This ensures that we can catch +! infinite loop situations. We also ensure that all live +! intervals added to the handled set have an end index strictly +! smaller than this one. This helps catch bugs. +SYMBOL: progress + +: check-unhandled ( live-interval -- ) + start>> progress get <= [ "check-unhandled" throw ] when ; inline + +: check-handled ( live-interval -- ) + end>> progress get > [ "check-handled" throw ] when ; inline + +! Mapping from register classes to sequences of machine registers +SYMBOL: registers + +! Vector of active live intervals +SYMBOL: active-intervals + +: active-intervals-for ( vreg -- seq ) + rep-of reg-class-of active-intervals get at ; + +: add-active ( live-interval -- ) + dup vreg>> active-intervals-for push ; + +: delete-active ( live-interval -- ) + dup vreg>> active-intervals-for delq ; + +: assign-free-register ( new registers -- ) + pop >>reg add-active ; + +! Vector of inactive live intervals +SYMBOL: inactive-intervals + +: inactive-intervals-for ( vreg -- seq ) + rep-of reg-class-of inactive-intervals get at ; + +: add-inactive ( live-interval -- ) + dup vreg>> inactive-intervals-for push ; + +: delete-inactive ( live-interval -- ) + dup vreg>> inactive-intervals-for delq ; + +! Vector of handled live intervals +SYMBOL: handled-intervals + +: add-handled ( live-interval -- ) + [ check-handled ] [ handled-intervals get push ] bi ; + +: finished? ( n live-interval -- ? ) end>> swap < ; + +: finish ( n live-interval -- keep? ) + nip add-handled f ; + +SYMBOL: check-allocation? + +ERROR: register-already-used live-interval ; + +: check-activate ( live-interval -- ) + check-allocation? get [ + dup [ reg>> ] [ vreg>> active-intervals-for [ reg>> ] map ] bi member? + [ register-already-used ] [ drop ] if + ] [ drop ] if ; + +: activate ( n live-interval -- keep? ) + dup check-activate + nip add-active f ; + +: deactivate ( n live-interval -- keep? ) + nip add-inactive f ; + +: don't-change ( n live-interval -- keep? ) 2drop t ; + +! Moving intervals between active and inactive sets +: process-intervals ( n symbol quots -- ) + ! symbol stores an alist mapping register classes to vectors + [ get values ] dip '[ [ _ cond ] with filter-here ] with each ; inline + +: deactivate-intervals ( n -- ) + ! Any active intervals which have ended are moved to handled + ! Any active intervals which cover the current position + ! are moved to inactive + active-intervals { + { [ 2dup finished? ] [ finish ] } + { [ 2dup covers? not ] [ deactivate ] } + [ don't-change ] + } process-intervals ; + +: activate-intervals ( n -- ) + ! Any inactive intervals which have ended are moved to handled + ! Any inactive intervals which do not cover the current position + ! are moved to active + inactive-intervals { + { [ 2dup finished? ] [ finish ] } + { [ 2dup covers? ] [ activate ] } + [ don't-change ] + } process-intervals ; + +! Minheap of live intervals which still need a register allocation +SYMBOL: unhandled-intervals + +: add-unhandled ( live-interval -- ) + [ check-unhandled ] + [ dup start>> unhandled-intervals get heap-push ] + bi ; + +: reg-class-assoc ( quot -- assoc ) + [ reg-classes ] dip { } map>assoc ; inline + +: next-spill-slot ( rep -- n ) + rep-size cfg get + [ swap [ align dup ] [ + ] bi ] change-spill-area-size drop ; + +! Minheap of sync points which still need to be processed +SYMBOL: unhandled-sync-points + +! Mapping from vregs to spill slots +SYMBOL: spill-slots + +: vreg-spill-slot ( vreg -- n ) + spill-slots get [ rep-of next-spill-slot ] cache ; + +: init-allocator ( registers -- ) + registers set + unhandled-intervals set + unhandled-sync-points set + [ V{ } clone ] reg-class-assoc active-intervals set + [ V{ } clone ] reg-class-assoc inactive-intervals set + V{ } clone handled-intervals set + cfg get 0 >>spill-area-size drop + H{ } clone spill-slots set + -1 progress set ; + +: init-unhandled ( live-intervals sync-points -- ) + [ [ [ start>> ] keep ] { } map>assoc unhandled-intervals get heap-push-all ] + [ [ [ n>> ] keep ] { } map>assoc unhandled-sync-points get heap-push-all ] + bi* ; + +! A utility used by register-status and spill-status words +: free-positions ( new -- assoc ) + vreg>> rep-of reg-class-of registers get at [ 1/0. ] H{ } map>assoc ; + +: add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ; + +: register-available? ( new result -- ? ) + [ end>> ] [ second ] bi* < ; inline + +: register-available ( new result -- ) + first >>reg add-active ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor b/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor deleted file mode 100644 index 13c1783711..0000000000 --- a/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -USING: compiler.cfg.linear-scan.assignment tools.test ; -IN: compiler.cfg.linear-scan.assignment.tests - - diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 6fcd6e7570..03df2d9747 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -1,26 +1,46 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel math assocs namespaces sequences heaps -fry make combinators sets +fry make combinators sets locals arrays cpu.architecture +compiler.cfg compiler.cfg.def-use +compiler.cfg.liveness compiler.cfg.registers compiler.cfg.instructions +compiler.cfg.renaming.functor +compiler.cfg.linearization.order compiler.cfg.linear-scan.allocation +compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.live-intervals ; IN: compiler.cfg.linear-scan.assignment -! A vector of live intervals. There is linear searching involved -! but since we never have too many machine registers (around 30 -! at most) and we probably won't have that many live at any one -! time anyway, it is not a problem to check each element. -TUPLE: active-intervals seq ; +! This contains both active and inactive intervals; any interval +! such that start <= insn# <= end is in this set. +SYMBOL: pending-interval-heap +SYMBOL: pending-interval-assoc -: add-active ( live-interval -- ) - active-intervals get seq>> push ; +: add-pending ( live-interval -- ) + [ dup end>> pending-interval-heap get heap-push ] + [ [ reg>> ] [ vreg>> ] bi pending-interval-assoc get set-at ] + bi ; -: lookup-register ( vreg -- reg ) - active-intervals get seq>> [ vreg>> = ] with find nip reg>> ; +: remove-pending ( live-interval -- ) + vreg>> pending-interval-assoc get delete-at ; + +: (vreg>reg) ( vreg pending -- reg ) + ! If a live vreg is not in the pending set, then it must + ! have been spilled. + ?at [ spill-slots get at ] unless ; + +: vreg>reg ( vreg -- reg ) + pending-interval-assoc get (vreg>reg) ; + +: vregs>regs ( vregs -- assoc ) + dup assoc-empty? [ + pending-interval-assoc get + '[ _ (vreg>reg) ] assoc-map + ] unless ; ! Minheap of live intervals which still need a register allocation SYMBOL: unhandled-intervals @@ -31,100 +51,136 @@ SYMBOL: unhandled-intervals : init-unhandled ( live-intervals -- ) [ add-unhandled ] each ; -! Mapping spill slots to vregs -SYMBOL: spill-slots +! Mapping from basic blocks to values which are live at the start +SYMBOL: register-live-ins -: spill-slots-for ( vreg -- assoc ) - reg-class>> spill-slots get at ; +! Mapping from basic blocks to values which are live at the end +SYMBOL: register-live-outs -: record-spill ( live-interval -- ) - [ dup spill-to>> ] [ vreg>> spill-slots-for ] bi - 2dup key? [ "BUG: Already spilled" throw ] [ set-at ] if ; +: init-assignment ( live-intervals -- ) + pending-interval-heap set + H{ } clone pending-interval-assoc set + unhandled-intervals set + H{ } clone register-live-ins set + H{ } clone register-live-outs set + init-unhandled ; : insert-spill ( live-interval -- ) - [ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri _spill ; + [ reg>> ] [ vreg>> rep-of ] [ spill-to>> ] tri _spill ; : handle-spill ( live-interval -- ) - dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ; + dup spill-to>> [ insert-spill ] [ drop ] if ; + +: expire-interval ( live-interval -- ) + [ remove-pending ] [ handle-spill ] bi ; + +: (expire-old-intervals) ( n heap -- ) + dup heap-empty? [ 2drop ] [ + 2dup heap-peek nip <= [ 2drop ] [ + dup heap-pop drop expire-interval + (expire-old-intervals) + ] if + ] if ; : expire-old-intervals ( n -- ) - active-intervals get - [ swap '[ end>> _ = ] partition ] change-seq drop - [ handle-spill ] each ; - -: record-reload ( live-interval -- ) - [ reload-from>> ] [ vreg>> spill-slots-for ] bi - 2dup key? [ delete-at ] [ "BUG: Already reloaded" throw ] if ; + pending-interval-heap get (expire-old-intervals) ; : insert-reload ( live-interval -- ) - [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ; + [ reg>> ] [ vreg>> rep-of ] [ reload-from>> ] tri _reload ; : handle-reload ( live-interval -- ) - dup reload-from>> [ [ record-reload ] [ insert-reload ] bi ] [ drop ] if ; + dup reload-from>> [ insert-reload ] [ drop ] if ; -: activate-new-intervals ( n -- ) - #! Any live intervals which start on the current instruction - #! are added to the active set. - unhandled-intervals get dup heap-empty? [ 2drop ] [ - 2dup heap-peek drop start>> = [ - heap-pop drop - [ add-active ] [ handle-reload ] bi - activate-new-intervals +: activate-interval ( live-interval -- ) + [ add-pending ] [ handle-reload ] bi ; + +: (activate-new-intervals) ( n heap -- ) + dup heap-empty? [ 2drop ] [ + 2dup heap-peek nip = [ + dup heap-pop drop activate-interval + (activate-new-intervals) ] [ 2drop ] if ] if ; -GENERIC: assign-before ( insn -- ) +: activate-new-intervals ( n -- ) + unhandled-intervals get (activate-new-intervals) ; -GENERIC: assign-after ( insn -- ) +: prepare-insn ( n -- ) + [ expire-old-intervals ] [ activate-new-intervals ] bi ; -: all-vregs ( insn -- vregs ) - [ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ; +GENERIC: assign-registers-in-insn ( insn -- ) -M: vreg-insn assign-before - active-intervals get seq>> over all-vregs '[ vreg>> _ member? ] filter - [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc - >>regs drop ; +RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ] -M: insn assign-before drop ; +M: vreg-insn assign-registers-in-insn + [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ; -: compute-live-registers ( -- regs ) - active-intervals get seq>> [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ; +! TODO: needs tagged-rep -: compute-live-spill-slots ( -- spill-slots ) - spill-slots get values [ values ] map concat - [ [ vreg>> ] [ reload-from>> ] bi ] { } map>assoc ; +: 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 ; -M: ##gc assign-after - compute-live-registers >>live-registers - compute-live-spill-slots >>live-spill-slots - drop ; +: spill-on-gc? ( vreg reg -- ? ) + [ rep-of int-rep? not ] [ spill-slot? not ] bi* and ; -M: insn assign-after drop ; - -: ( -- obj ) - V{ } clone active-intervals boa ; - -: init-assignment ( live-intervals -- ) - active-intervals set - unhandled-intervals set - [ H{ } clone ] reg-class-assoc spill-slots set - init-unhandled ; - -: assign-registers-in-block ( bb -- ) +: 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 [ vreg-spill-slot ] [ rep-of ] bi 3array , ] [ 2drop ] if + ] assoc-each + ] { } make ; + +M: ##gc assign-registers-in-insn + ! Since ##gc is always the first instruction in a block, the set of + ! values live at the ##gc is just live-in. + dup call-next-method + basic-block get register-live-ins get at + [ trace-on-gc >>tagged-values ] [ spill-on-gc >>data-values ] bi + drop ; + +M: insn assign-registers-in-insn drop ; + +: begin-block ( bb -- ) + dup basic-block set + dup block-from activate-new-intervals + [ 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 ; + +ERROR: bad-vreg vreg ; + +: vreg-at-start ( vreg bb -- state ) + register-live-ins get at ?at [ bad-vreg ] unless ; + +: vreg-at-end ( vreg bb -- state ) + register-live-outs get at ?at [ bad-vreg ] unless ; + +:: assign-registers-in-block ( bb -- ) + bb [ + [ + bb begin-block [ { - [ insn#>> activate-new-intervals ] - [ assign-before ] + [ insn#>> 1 - prepare-insn ] + [ insn#>> prepare-insn ] + [ assign-registers-in-insn ] [ , ] - [ insn#>> expire-old-intervals ] - [ assign-after ] } cleave ] each + bb end-block ] V{ } make ] change-instructions drop ; -: assign-registers ( rpo live-intervals -- ) - init-assignment - [ assign-registers-in-block ] each ; +: assign-registers ( live-intervals cfg -- ) + [ init-assignment ] dip + linearization-order [ assign-registers-in-block ] each ; diff --git a/basis/compiler/cfg/linear-scan/debugger/debugger.factor b/basis/compiler/cfg/linear-scan/debugger/debugger.factor index dad87b62ae..fa248dd4e8 100644 --- a/basis/compiler/cfg/linear-scan/debugger/debugger.factor +++ b/basis/compiler/cfg/linear-scan/debugger/debugger.factor @@ -1,26 +1,17 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel sequences sets arrays math strings fry -prettyprint compiler.cfg.linear-scan.live-intervals -compiler.cfg.linear-scan.allocation ; +namespaces prettyprint compiler.cfg.linear-scan.live-intervals +compiler.cfg.linear-scan.allocation compiler.cfg assocs ; IN: compiler.cfg.linear-scan.debugger -: check-assigned ( live-intervals -- ) - [ - reg>> - [ "Not all intervals have registers" throw ] unless - ] each ; - -: split-children ( live-interval -- seq ) - dup split-before>> [ - [ split-before>> ] [ split-after>> ] bi - [ split-children ] bi@ - append - ] [ 1array ] if ; - : check-linear-scan ( live-intervals machine-registers -- ) - [ [ clone ] map ] dip allocate-registers - [ split-children ] map concat check-assigned ; + [ + [ clone ] map dup [ [ vreg>> ] keep ] H{ } map>assoc + live-intervals set + f + ] dip + allocate-registers drop ; : picture ( uses -- str ) dup last 1 + CHAR: space @@ -28,9 +19,8 @@ IN: compiler.cfg.linear-scan.debugger : interval-picture ( interval -- str ) [ uses>> picture ] - [ copy-from>> unparse ] [ vreg>> unparse ] - tri 3array ; + bi 2array ; : live-intervals. ( seq -- ) [ interval-picture ] map simple-table. ; diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index ccfc4a1ff7..062c62adab 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -1,17 +1,30 @@ IN: compiler.cfg.linear-scan.tests USING: tools.test random sorting sequences sets hashtables assocs -kernel fry arrays splitting namespaces math accessors vectors -math.order grouping +kernel fry arrays splitting namespaces math accessors vectors locals +math.order grouping strings strings.private classes layouts cpu.architecture compiler.cfg compiler.cfg.optimizer compiler.cfg.instructions compiler.cfg.registers +compiler.cfg.predecessors +compiler.cfg.rpo +compiler.cfg.linearization +compiler.cfg.debugger +compiler.cfg.def-use +compiler.cfg.comparisons compiler.cfg.linear-scan +compiler.cfg.linear-scan.numbering compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.allocation +compiler.cfg.linear-scan.allocation.state +compiler.cfg.linear-scan.allocation.splitting +compiler.cfg.linear-scan.allocation.spilling compiler.cfg.linear-scan.debugger ; +check-allocation? on +check-numbering? on + [ { T{ live-range f 1 10 } T{ live-range f 15 15 } } { T{ live-range f 16 20 } } @@ -53,11 +66,8 @@ compiler.cfg.linear-scan.debugger ; ] unit-test [ - { } - { T{ live-range f 1 10 } } -] [ { T{ live-range f 1 10 } } 0 split-ranges -] unit-test +] must-fail [ { T{ live-range f 0 0 } } @@ -66,175 +76,187 @@ compiler.cfg.linear-scan.debugger ; { T{ live-range f 0 5 } } 0 split-ranges ] unit-test -[ 7 ] [ - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 2 } } } - { start 0 } - { end 10 } - { uses V{ 0 1 3 7 10 } } - } - 4 [ >= ] find-use nip -] unit-test +cfg new 0 >>spill-area-size cfg set +H{ } spill-slots set -[ 4 ] [ - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 2 } } } - { start 0 } - { end 10 } - { uses V{ 0 1 3 4 10 } } - } - 4 [ >= ] find-use nip -] unit-test - -[ f ] [ - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 2 } } } - { start 0 } - { end 10 } - { uses V{ 0 1 3 4 10 } } - } - 100 [ >= ] find-use nip -] unit-test +H{ + { 1 single-float-rep } + { 2 single-float-rep } + { 3 single-float-rep } +} representations set [ T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { vreg 1 } { start 0 } - { end 1 } + { end 2 } { uses V{ 0 1 } } - { ranges V{ T{ live-range f 0 1 } } } + { ranges V{ T{ live-range f 0 2 } } } + { spill-to 0 } } T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { vreg 1 } { start 5 } { end 5 } { uses V{ 5 } } { ranges V{ T{ live-range f 5 5 } } } + { reload-from 0 } } ] [ T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { vreg 1 } { start 0 } { end 5 } { uses V{ 0 1 5 } } { ranges V{ T{ live-range f 0 5 } } } - } 2 split-interval + } 2 split-for-spill ] unit-test [ T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 0 } - { end 0 } - { uses V{ 0 } } - { ranges V{ T{ live-range f 0 0 } } } + { vreg 2 } + { start 0 } + { end 1 } + { uses V{ 0 } } + { ranges V{ T{ live-range f 0 1 } } } + { spill-to 4 } } T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 1 } - { end 5 } - { uses V{ 1 5 } } - { ranges V{ T{ live-range f 1 5 } } } + { vreg 2 } + { start 1 } + { end 5 } + { uses V{ 1 5 } } + { ranges V{ T{ live-range f 1 5 } } } + { reload-from 4 } } ] [ T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 0 } - { end 5 } - { uses V{ 0 1 5 } } - { ranges V{ T{ live-range f 0 5 } } } - } 0 split-interval + { vreg 2 } + { start 0 } + { end 5 } + { uses V{ 0 1 5 } } + { ranges V{ T{ live-range f 0 5 } } } + } 0 split-for-spill ] unit-test [ T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 3 } - { end 10 } - { uses V{ 3 10 } } + { vreg 3 } + { start 0 } + { end 1 } + { uses V{ 0 } } + { ranges V{ T{ live-range f 0 1 } } } + { spill-to 8 } + } + T{ live-interval + { vreg 3 } + { start 20 } + { end 30 } + { uses V{ 20 30 } } + { ranges V{ T{ live-range f 20 30 } } } + { reload-from 8 } } ] [ + T{ live-interval + { vreg 3 } + { start 0 } + { end 30 } + { uses V{ 0 20 30 } } + { ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } } + } 10 split-for-spill +] unit-test + +H{ + { 1 int-rep } + { 2 int-rep } + { 3 int-rep } +} representations set + +[ { - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 1 } - { end 15 } - { uses V{ 1 3 7 10 15 } } - } - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 3 } - { end 8 } - { uses V{ 3 4 8 } } - } - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 3 } - { end 10 } - { uses V{ 3 10 } } - } + 3 + 10 } +] [ + H{ + { int-regs + V{ + T{ live-interval + { vreg 1 } + { reg 1 } + { start 1 } + { end 15 } + { uses V{ 1 3 7 10 15 } } + } + T{ live-interval + { vreg 2 } + { reg 2 } + { start 3 } + { end 8 } + { uses V{ 3 4 8 } } + } + T{ live-interval + { vreg 3 } + { reg 3 } + { start 3 } + { end 10 } + { uses V{ 3 10 } } + } + } + } + } active-intervals set + H{ } inactive-intervals set T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { vreg 1 } { start 5 } { end 5 } { uses V{ 5 } } } - interval-to-spill + spill-status ] unit-test -[ t ] [ - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 5 } - { end 15 } - { uses V{ 5 10 15 } } +[ + { + 1 + 1/0. } +] [ + H{ + { int-regs + V{ + T{ live-interval + { vreg 1 } + { reg 1 } + { start 1 } + { end 15 } + { uses V{ 1 } } + } + T{ live-interval + { vreg 2 } + { reg 2 } + { start 3 } + { end 8 } + { uses V{ 3 8 } } + } + } + } + } active-intervals set + H{ } inactive-intervals set T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 1 } - { end 20 } - { uses V{ 1 20 } } - } - spill-existing? -] unit-test - -[ f ] [ - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 5 } - { end 15 } - { uses V{ 5 10 15 } } - } - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 1 } - { end 20 } - { uses V{ 1 7 20 } } - } - spill-existing? -] unit-test - -[ t ] [ - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { vreg 3 } { start 5 } { end 5 } { uses V{ 5 } } } - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 1 } - { end 20 } - { uses V{ 1 7 20 } } - } - spill-existing? + spill-status ] unit-test +H{ { 1 int-rep } { 2 int-rep } } representations set + [ ] [ { T{ live-interval - { vreg T{ vreg { n 1 } { reg-class int-regs } } } + { vreg 1 } { start 0 } { end 100 } { uses V{ 0 100 } } @@ -248,14 +270,14 @@ compiler.cfg.linear-scan.debugger ; [ ] [ { T{ live-interval - { vreg T{ vreg { n 1 } { reg-class int-regs } } } + { vreg 1 } { start 0 } { end 10 } { uses V{ 0 10 } } { ranges V{ T{ live-range f 0 10 } } } } T{ live-interval - { vreg T{ vreg { n 2 } { reg-class int-regs } } } + { vreg 2 } { start 11 } { end 20 } { uses V{ 11 20 } } @@ -269,14 +291,14 @@ compiler.cfg.linear-scan.debugger ; [ ] [ { T{ live-interval - { vreg T{ vreg { n 1 } { reg-class int-regs } } } + { vreg 1 } { start 0 } { end 100 } { uses V{ 0 100 } } { ranges V{ T{ live-range f 0 100 } } } } T{ live-interval - { vreg T{ vreg { n 2 } { reg-class int-regs } } } + { vreg 2 } { start 30 } { end 60 } { uses V{ 30 60 } } @@ -290,14 +312,14 @@ compiler.cfg.linear-scan.debugger ; [ ] [ { T{ live-interval - { vreg T{ vreg { n 1 } { reg-class int-regs } } } + { vreg 1 } { start 0 } { end 100 } { uses V{ 0 100 } } { ranges V{ T{ live-range f 0 100 } } } } T{ live-interval - { vreg T{ vreg { n 2 } { reg-class int-regs } } } + { vreg 2 } { start 30 } { end 200 } { uses V{ 30 200 } } @@ -311,14 +333,14 @@ compiler.cfg.linear-scan.debugger ; [ { T{ live-interval - { vreg T{ vreg { n 1 } { reg-class int-regs } } } + { vreg 1 } { start 0 } { end 100 } { uses V{ 0 100 } } { ranges V{ T{ live-range f 0 100 } } } } T{ live-interval - { vreg T{ vreg { n 2 } { reg-class int-regs } } } + { vreg 2 } { start 30 } { end 100 } { uses V{ 30 100 } } @@ -329,991 +351,82 @@ compiler.cfg.linear-scan.debugger ; check-linear-scan ] must-fail -SYMBOL: available - -SYMBOL: taken - -SYMBOL: max-registers - -SYMBOL: max-insns - -SYMBOL: max-uses - -: not-taken ( -- n ) - available get keys dup empty? [ "Oops" throw ] when - random - dup taken get nth 1 + max-registers get = [ - dup available get delete-at - ] [ - dup taken get [ 1 + ] change-nth - ] if ; - -: random-live-intervals ( num-intervals max-uses max-registers max-insns -- seq ) - [ - max-insns set - max-registers set - max-uses set - max-insns get [ 0 ] replicate taken set - max-insns get [ dup ] H{ } map>assoc available set - [ - \ live-interval new - swap int-regs swap vreg boa >>vreg - max-uses get random 2 max [ not-taken ] replicate natural-sort - [ >>uses ] [ first >>start ] bi - dup uses>> last >>end - dup [ start>> ] [ end>> ] bi 1vector >>ranges - ] map - ] with-scope ; - -: random-test ( num-intervals max-uses max-registers max-insns -- ) - over [ random-live-intervals ] dip int-regs associate check-linear-scan ; - -[ ] [ 30 2 1 60 random-test ] unit-test -[ ] [ 60 2 2 60 random-test ] unit-test -[ ] [ 80 2 3 200 random-test ] unit-test -[ ] [ 70 2 5 30 random-test ] unit-test -[ ] [ 60 2 6 30 random-test ] unit-test -[ ] [ 1 2 10 10 random-test ] unit-test - -[ ] [ 10 4 2 60 random-test ] unit-test -[ ] [ 10 20 2 400 random-test ] unit-test -[ ] [ 10 20 4 300 random-test ] unit-test - -USING: math.private compiler.cfg.debugger ; - -[ ] [ - [ float+ float>fixnum 3 fixnum*fast ] - test-cfg first optimize-cfg linear-scan drop -] unit-test - -: fake-live-ranges ( seq -- seq' ) - [ - clone dup [ start>> ] [ end>> ] bi 1vector >>ranges - ] map ; - -! Coalescing interacted badly with splitting -[ ] [ - { - T{ live-interval - { vreg V int-regs 70 } - { start 14 } - { end 17 } - { uses V{ 14 15 16 17 } } - { copy-from V int-regs 67 } - } - T{ live-interval - { vreg V int-regs 67 } - { start 13 } - { end 14 } - { uses V{ 13 14 } } - } - T{ live-interval - { vreg V int-regs 30 } - { start 4 } - { end 18 } - { uses V{ 4 12 16 17 18 } } - } - T{ live-interval - { vreg V int-regs 27 } - { start 3 } - { end 13 } - { uses V{ 3 7 13 } } - } - T{ live-interval - { vreg V int-regs 59 } - { start 10 } - { end 18 } - { uses V{ 10 11 12 18 } } - { copy-from V int-regs 56 } - } - T{ live-interval - { vreg V int-regs 60 } - { start 12 } - { end 17 } - { uses V{ 12 17 } } - } - T{ live-interval - { vreg V int-regs 56 } - { start 9 } - { end 10 } - { uses V{ 9 10 } } - } - } fake-live-ranges - { { int-regs { 0 1 2 3 } } } - allocate-registers drop -] unit-test +! Problem with spilling intervals with no more usages after the spill location +H{ + { 1 int-rep } + { 2 int-rep } + { 3 int-rep } + { 4 int-rep } + { 5 int-rep } +} representations set [ ] [ { T{ live-interval - { vreg V int-regs 3687168 } - { start 106 } - { end 112 } - { uses V{ 106 112 } } + { vreg 1 } + { start 0 } + { end 20 } + { uses V{ 0 10 20 } } + { ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } } } T{ live-interval - { vreg V int-regs 3687169 } - { start 107 } - { end 113 } - { uses V{ 107 113 } } + { vreg 2 } + { start 0 } + { end 20 } + { uses V{ 0 10 20 } } + { ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } } } T{ live-interval - { vreg V int-regs 3687727 } - { start 190 } - { end 198 } - { uses V{ 190 195 198 } } + { vreg 3 } + { start 4 } + { end 8 } + { uses V{ 6 } } + { ranges V{ T{ live-range f 4 8 } } } } T{ live-interval - { vreg V int-regs 3686445 } - { start 43 } - { end 44 } - { uses V{ 43 44 } } + { vreg 4 } + { start 4 } + { end 8 } + { uses V{ 8 } } + { ranges V{ T{ live-range f 4 8 } } } } + + ! This guy will invoke the 'spill partially available' code path T{ live-interval - { vreg V int-regs 3686195 } - { start 5 } - { end 11 } - { uses V{ 5 11 } } + { vreg 5 } + { start 4 } + { end 8 } + { uses V{ 8 } } + { ranges V{ T{ live-range f 4 8 } } } } - T{ live-interval - { vreg V int-regs 3686449 } - { start 44 } - { end 56 } - { uses V{ 44 45 45 46 56 } } - { copy-from V int-regs 3686445 } - } - T{ live-interval - { vreg V int-regs 3686198 } - { start 8 } - { end 10 } - { uses V{ 8 9 10 } } - } - T{ live-interval - { vreg V int-regs 3686454 } - { start 46 } - { end 49 } - { uses V{ 46 47 47 49 } } - { copy-from V int-regs 3686449 } - } - T{ live-interval - { vreg V int-regs 3686196 } - { start 6 } - { end 12 } - { uses V{ 6 12 } } - } - T{ live-interval - { vreg V int-regs 3686197 } - { start 7 } - { end 14 } - { uses V{ 7 13 14 } } - } - T{ live-interval - { vreg V int-regs 3686455 } - { start 48 } - { end 51 } - { uses V{ 48 51 } } - } - T{ live-interval - { vreg V int-regs 3686463 } - { start 52 } - { end 53 } - { uses V{ 52 53 } } - } - T{ live-interval - { vreg V int-regs 3686460 } - { start 49 } - { end 52 } - { uses V{ 49 50 50 52 } } - { copy-from V int-regs 3686454 } - } - T{ live-interval - { vreg V int-regs 3686461 } - { start 51 } - { end 71 } - { uses V{ 51 52 64 68 71 } } - } - T{ live-interval - { vreg V int-regs 3686464 } - { start 53 } - { end 54 } - { uses V{ 53 54 } } - } - T{ live-interval - { vreg V int-regs 3686465 } - { start 54 } - { end 76 } - { uses V{ 54 55 55 76 } } - { copy-from V int-regs 3686464 } - } - T{ live-interval - { vreg V int-regs 3686470 } - { start 58 } - { end 60 } - { uses V{ 58 59 59 60 } } - { copy-from V int-regs 3686469 } - } - T{ live-interval - { vreg V int-regs 3686469 } - { start 56 } - { end 58 } - { uses V{ 56 57 57 58 } } - { copy-from V int-regs 3686449 } - } - T{ live-interval - { vreg V int-regs 3686473 } - { start 60 } - { end 62 } - { uses V{ 60 61 61 62 } } - { copy-from V int-regs 3686470 } - } - T{ live-interval - { vreg V int-regs 3686479 } - { start 62 } - { end 64 } - { uses V{ 62 63 63 64 } } - { copy-from V int-regs 3686473 } - } - T{ live-interval - { vreg V int-regs 3686735 } - { start 78 } - { end 96 } - { uses V{ 78 79 79 96 } } - { copy-from V int-regs 3686372 } - } - T{ live-interval - { vreg V int-regs 3686482 } - { start 64 } - { end 65 } - { uses V{ 64 65 } } - } - T{ live-interval - { vreg V int-regs 3686483 } - { start 65 } - { end 66 } - { uses V{ 65 66 } } - } - T{ live-interval - { vreg V int-regs 3687510 } - { start 168 } - { end 171 } - { uses V{ 168 171 } } - } - T{ live-interval - { vreg V int-regs 3687511 } - { start 169 } - { end 176 } - { uses V{ 169 176 } } - } - T{ live-interval - { vreg V int-regs 3686484 } - { start 66 } - { end 75 } - { uses V{ 66 67 67 75 } } - { copy-from V int-regs 3686483 } - } - T{ live-interval - { vreg V int-regs 3687509 } - { start 162 } - { end 163 } - { uses V{ 162 163 } } - } - T{ live-interval - { vreg V int-regs 3686491 } - { start 68 } - { end 69 } - { uses V{ 68 69 } } - } - T{ live-interval - { vreg V int-regs 3687512 } - { start 170 } - { end 178 } - { uses V{ 170 177 178 } } - } - T{ live-interval - { vreg V int-regs 3687515 } - { start 172 } - { end 173 } - { uses V{ 172 173 } } - } - T{ live-interval - { vreg V int-regs 3686492 } - { start 69 } - { end 74 } - { uses V{ 69 70 70 74 } } - { copy-from V int-regs 3686491 } - } - T{ live-interval - { vreg V int-regs 3687778 } - { start 202 } - { end 208 } - { uses V{ 202 208 } } - } - T{ live-interval - { vreg V int-regs 3686499 } - { start 71 } - { end 72 } - { uses V{ 71 72 } } - } - T{ live-interval - { vreg V int-regs 3687520 } - { start 174 } - { end 175 } - { uses V{ 174 175 } } - } - T{ live-interval - { vreg V int-regs 3687779 } - { start 203 } - { end 209 } - { uses V{ 203 209 } } - } - T{ live-interval - { vreg V int-regs 3687782 } - { start 206 } - { end 207 } - { uses V{ 206 207 } } - } - T{ live-interval - { vreg V int-regs 3686503 } - { start 74 } - { end 75 } - { uses V{ 74 75 } } - } - T{ live-interval - { vreg V int-regs 3686500 } - { start 72 } - { end 74 } - { uses V{ 72 73 73 74 } } - { copy-from V int-regs 3686499 } - } - T{ live-interval - { vreg V int-regs 3687780 } - { start 204 } - { end 210 } - { uses V{ 204 210 } } - } - T{ live-interval - { vreg V int-regs 3686506 } - { start 75 } - { end 76 } - { uses V{ 75 76 } } - } - T{ live-interval - { vreg V int-regs 3687530 } - { start 185 } - { end 192 } - { uses V{ 185 192 } } - } - T{ live-interval - { vreg V int-regs 3687528 } - { start 183 } - { end 198 } - { uses V{ 183 198 } } - } - T{ live-interval - { vreg V int-regs 3687529 } - { start 184 } - { end 197 } - { uses V{ 184 197 } } - } - T{ live-interval - { vreg V int-regs 3687781 } - { start 205 } - { end 211 } - { uses V{ 205 211 } } - } - T{ live-interval - { vreg V int-regs 3687535 } - { start 187 } - { end 194 } - { uses V{ 187 194 } } - } - T{ live-interval - { vreg V int-regs 3686252 } - { start 9 } - { end 17 } - { uses V{ 9 15 17 } } - } - T{ live-interval - { vreg V int-regs 3686509 } - { start 76 } - { end 90 } - { uses V{ 76 87 90 } } - } - T{ live-interval - { vreg V int-regs 3687532 } - { start 186 } - { end 196 } - { uses V{ 186 196 } } - } - T{ live-interval - { vreg V int-regs 3687538 } - { start 188 } - { end 193 } - { uses V{ 188 193 } } - } - T{ live-interval - { vreg V int-regs 3687827 } - { start 217 } - { end 219 } - { uses V{ 217 219 } } - } - T{ live-interval - { vreg V int-regs 3687825 } - { start 215 } - { end 218 } - { uses V{ 215 216 218 } } - } - T{ live-interval - { vreg V int-regs 3687831 } - { start 218 } - { end 219 } - { uses V{ 218 219 } } - } - T{ live-interval - { vreg V int-regs 3686296 } - { start 16 } - { end 18 } - { uses V{ 16 18 } } - } - T{ live-interval - { vreg V int-regs 3686302 } - { start 29 } - { end 31 } - { uses V{ 29 31 } } - } - T{ live-interval - { vreg V int-regs 3687838 } - { start 231 } - { end 232 } - { uses V{ 231 232 } } - } - T{ live-interval - { vreg V int-regs 3686300 } - { start 26 } - { end 27 } - { uses V{ 26 27 } } - } - T{ live-interval - { vreg V int-regs 3686301 } - { start 27 } - { end 30 } - { uses V{ 27 28 28 30 } } - { copy-from V int-regs 3686300 } - } - T{ live-interval - { vreg V int-regs 3686306 } - { start 37 } - { end 93 } - { uses V{ 37 82 93 } } - } - T{ live-interval - { vreg V int-regs 3686307 } - { start 38 } - { end 88 } - { uses V{ 38 85 88 } } - } - T{ live-interval - { vreg V int-regs 3687837 } - { start 222 } - { end 223 } - { uses V{ 222 223 } } - } - T{ live-interval - { vreg V int-regs 3686305 } - { start 36 } - { end 81 } - { uses V{ 36 42 77 81 } } - } - T{ live-interval - { vreg V int-regs 3686310 } - { start 39 } - { end 95 } - { uses V{ 39 84 95 } } - } - T{ live-interval - { vreg V int-regs 3687836 } - { start 227 } - { end 228 } - { uses V{ 227 228 } } - } - T{ live-interval - { vreg V int-regs 3687839 } - { start 239 } - { end 246 } - { uses V{ 239 245 246 } } - } - T{ live-interval - { vreg V int-regs 3687841 } - { start 240 } - { end 241 } - { uses V{ 240 241 } } - } - T{ live-interval - { vreg V int-regs 3687845 } - { start 241 } - { end 243 } - { uses V{ 241 243 } } - } - T{ live-interval - { vreg V int-regs 3686315 } - { start 40 } - { end 94 } - { uses V{ 40 83 94 } } - } - T{ live-interval - { vreg V int-regs 3687846 } - { start 242 } - { end 245 } - { uses V{ 242 245 } } - } - T{ live-interval - { vreg V int-regs 3687849 } - { start 243 } - { end 245 } - { uses V{ 243 244 244 245 } } - { copy-from V int-regs 3687845 } - } - T{ live-interval - { vreg V int-regs 3687850 } - { start 245 } - { end 245 } - { uses V{ 245 } } - } - T{ live-interval - { vreg V int-regs 3687851 } - { start 246 } - { end 246 } - { uses V{ 246 } } - } - T{ live-interval - { vreg V int-regs 3687852 } - { start 246 } - { end 246 } - { uses V{ 246 } } - } - T{ live-interval - { vreg V int-regs 3687853 } - { start 247 } - { end 248 } - { uses V{ 247 248 } } - } - T{ live-interval - { vreg V int-regs 3687854 } - { start 249 } - { end 250 } - { uses V{ 249 250 } } - } - T{ live-interval - { vreg V int-regs 3687855 } - { start 258 } - { end 259 } - { uses V{ 258 259 } } - } - T{ live-interval - { vreg V int-regs 3687080 } - { start 280 } - { end 285 } - { uses V{ 280 285 } } - } - T{ live-interval - { vreg V int-regs 3687081 } - { start 281 } - { end 286 } - { uses V{ 281 286 } } - } - T{ live-interval - { vreg V int-regs 3687082 } - { start 282 } - { end 287 } - { uses V{ 282 287 } } - } - T{ live-interval - { vreg V int-regs 3687083 } - { start 283 } - { end 288 } - { uses V{ 283 288 } } - } - T{ live-interval - { vreg V int-regs 3687085 } - { start 284 } - { end 299 } - { uses V{ 284 285 286 287 288 296 299 } } - } - T{ live-interval - { vreg V int-regs 3687086 } - { start 284 } - { end 284 } - { uses V{ 284 } } - } - T{ live-interval - { vreg V int-regs 3687087 } - { start 289 } - { end 293 } - { uses V{ 289 293 } } - } - T{ live-interval - { vreg V int-regs 3687088 } - { start 290 } - { end 294 } - { uses V{ 290 294 } } - } - T{ live-interval - { vreg V int-regs 3687089 } - { start 291 } - { end 297 } - { uses V{ 291 297 } } - } - T{ live-interval - { vreg V int-regs 3687090 } - { start 292 } - { end 298 } - { uses V{ 292 298 } } - } - T{ live-interval - { vreg V int-regs 3687363 } - { start 118 } - { end 119 } - { uses V{ 118 119 } } - } - T{ live-interval - { vreg V int-regs 3686599 } - { start 77 } - { end 89 } - { uses V{ 77 86 89 } } - } - T{ live-interval - { vreg V int-regs 3687370 } - { start 131 } - { end 132 } - { uses V{ 131 132 } } - } - T{ live-interval - { vreg V int-regs 3687371 } - { start 138 } - { end 143 } - { uses V{ 138 143 } } - } - T{ live-interval - { vreg V int-regs 3687368 } - { start 127 } - { end 128 } - { uses V{ 127 128 } } - } - T{ live-interval - { vreg V int-regs 3687369 } - { start 122 } - { end 123 } - { uses V{ 122 123 } } - } - T{ live-interval - { vreg V int-regs 3687373 } - { start 139 } - { end 140 } - { uses V{ 139 140 } } - } - T{ live-interval - { vreg V int-regs 3686352 } - { start 41 } - { end 91 } - { uses V{ 41 43 79 91 } } - } - T{ live-interval - { vreg V int-regs 3687377 } - { start 140 } - { end 141 } - { uses V{ 140 141 } } - } - T{ live-interval - { vreg V int-regs 3687382 } - { start 143 } - { end 143 } - { uses V{ 143 } } - } - T{ live-interval - { vreg V int-regs 3687383 } - { start 144 } - { end 161 } - { uses V{ 144 159 161 } } - } - T{ live-interval - { vreg V int-regs 3687380 } - { start 141 } - { end 143 } - { uses V{ 141 142 142 143 } } - { copy-from V int-regs 3687377 } - } - T{ live-interval - { vreg V int-regs 3687381 } - { start 143 } - { end 160 } - { uses V{ 143 160 } } - } - T{ live-interval - { vreg V int-regs 3687384 } - { start 145 } - { end 158 } - { uses V{ 145 158 } } - } - T{ live-interval - { vreg V int-regs 3687385 } - { start 146 } - { end 157 } - { uses V{ 146 157 } } - } - T{ live-interval - { vreg V int-regs 3687640 } - { start 189 } - { end 191 } - { uses V{ 189 191 } } - } - T{ live-interval - { vreg V int-regs 3687388 } - { start 147 } - { end 152 } - { uses V{ 147 152 } } - } - T{ live-interval - { vreg V int-regs 3687393 } - { start 148 } - { end 153 } - { uses V{ 148 153 } } - } - T{ live-interval - { vreg V int-regs 3687398 } - { start 149 } - { end 154 } - { uses V{ 149 154 } } - } - T{ live-interval - { vreg V int-regs 3686372 } - { start 42 } - { end 92 } - { uses V{ 42 45 78 80 92 } } - } - T{ live-interval - { vreg V int-regs 3687140 } - { start 293 } - { end 295 } - { uses V{ 293 294 294 295 } } - { copy-from V int-regs 3687087 } - } - T{ live-interval - { vreg V int-regs 3687403 } - { start 150 } - { end 155 } - { uses V{ 150 155 } } - } - T{ live-interval - { vreg V int-regs 3687150 } - { start 304 } - { end 306 } - { uses V{ 304 306 } } - } - T{ live-interval - { vreg V int-regs 3687151 } - { start 305 } - { end 307 } - { uses V{ 305 307 } } - } - T{ live-interval - { vreg V int-regs 3687408 } - { start 151 } - { end 156 } - { uses V{ 151 156 } } - } - T{ live-interval - { vreg V int-regs 3687153 } - { start 312 } - { end 313 } - { uses V{ 312 313 } } - } - T{ live-interval - { vreg V int-regs 3686902 } - { start 267 } - { end 272 } - { uses V{ 267 272 } } - } - T{ live-interval - { vreg V int-regs 3686903 } - { start 268 } - { end 273 } - { uses V{ 268 273 } } - } - T{ live-interval - { vreg V int-regs 3686900 } - { start 265 } - { end 270 } - { uses V{ 265 270 } } - } - T{ live-interval - { vreg V int-regs 3686901 } - { start 266 } - { end 271 } - { uses V{ 266 271 } } - } - T{ live-interval - { vreg V int-regs 3687162 } - { start 100 } - { end 119 } - { uses V{ 100 114 117 119 } } - } - T{ live-interval - { vreg V int-regs 3687163 } - { start 101 } - { end 118 } - { uses V{ 101 115 116 118 } } - } - T{ live-interval - { vreg V int-regs 3686904 } - { start 269 } - { end 274 } - { uses V{ 269 274 } } - } - T{ live-interval - { vreg V int-regs 3687166 } - { start 104 } - { end 110 } - { uses V{ 104 110 } } - } - T{ live-interval - { vreg V int-regs 3687167 } - { start 105 } - { end 111 } - { uses V{ 105 111 } } - } - T{ live-interval - { vreg V int-regs 3687164 } - { start 102 } - { end 108 } - { uses V{ 102 108 } } - } - T{ live-interval - { vreg V int-regs 3687165 } - { start 103 } - { end 109 } - { uses V{ 103 109 } } - } - } fake-live-ranges - { { int-regs { 0 1 2 3 4 } } } - allocate-registers drop + } + H{ { int-regs { "A" "B" } } } + check-linear-scan ] unit-test -! A reduction of the above +! Test spill-new code path + [ ] [ { T{ live-interval - { vreg V int-regs 6449 } - { start 44 } - { end 56 } - { uses V{ 44 45 46 56 } } + { vreg 1 } + { start 0 } + { end 10 } + { uses V{ 0 6 10 } } + { ranges V{ T{ live-range f 0 10 } } } } - T{ live-interval - { vreg V int-regs 6454 } - { start 46 } - { end 49 } - { uses V{ 46 47 49 } } - } - T{ live-interval - { vreg V int-regs 6455 } - { start 48 } - { end 51 } - { uses V{ 48 51 } } - } - T{ live-interval - { vreg V int-regs 6460 } - { start 49 } - { end 52 } - { uses V{ 49 50 52 } } - } - T{ live-interval - { vreg V int-regs 6461 } - { start 51 } - { end 71 } - { uses V{ 51 52 64 68 71 } } - } - T{ live-interval - { vreg V int-regs 6464 } - { start 53 } - { end 54 } - { uses V{ 53 54 } } - } - T{ live-interval - { vreg V int-regs 6470 } - { start 58 } - { end 60 } - { uses V{ 58 59 60 } } - } - T{ live-interval - { vreg V int-regs 6469 } - { start 56 } - { end 58 } - { uses V{ 56 57 58 } } - } - T{ live-interval - { vreg V int-regs 6473 } - { start 60 } - { end 62 } - { uses V{ 60 61 62 } } - } - T{ live-interval - { vreg V int-regs 6479 } - { start 62 } - { end 64 } - { uses V{ 62 63 64 } } - } - T{ live-interval - { vreg V int-regs 6735 } - { start 78 } - { end 96 } - { uses V{ 78 79 96 } } - { copy-from V int-regs 6372 } - } - T{ live-interval - { vreg V int-regs 6483 } - { start 65 } - { end 66 } - { uses V{ 65 66 } } - } - T{ live-interval - { vreg V int-regs 7845 } - { start 91 } - { end 93 } - { uses V{ 91 93 } } - } - T{ live-interval - { vreg V int-regs 6372 } - { start 42 } - { end 92 } - { uses V{ 42 45 78 80 92 } } - } - } fake-live-ranges - { { int-regs { 0 1 2 3 } } } - allocate-registers drop -] unit-test -! Spill slot liveness was computed incorrectly, leading to a FEP -! early in bootstrap on x86-32 -[ t ] [ - T{ basic-block - { instructions - V{ - T{ ##gc f V int-regs 6 V int-regs 7 } - T{ ##peek f V int-regs 0 D 0 } - T{ ##peek f V int-regs 1 D 1 } - T{ ##peek f V int-regs 2 D 2 } - T{ ##peek f V int-regs 3 D 3 } - T{ ##peek f V int-regs 4 D 4 } - T{ ##peek f V int-regs 5 D 5 } - T{ ##replace f V int-regs 0 D 1 } - T{ ##replace f V int-regs 1 D 2 } - T{ ##replace f V int-regs 2 D 3 } - T{ ##replace f V int-regs 3 D 4 } - T{ ##replace f V int-regs 4 D 5 } - T{ ##replace f V int-regs 5 D 0 } - } - } - } dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan) - instructions>> first live-spill-slots>> empty? + ! This guy will invoke the 'spill new' code path + T{ live-interval + { vreg 5 } + { start 2 } + { end 8 } + { uses V{ 8 } } + { ranges V{ T{ live-range f 2 8 } } } + } + } + H{ { int-regs { "A" } } } + check-linear-scan ] unit-test [ f ] [ @@ -1360,6 +473,20 @@ USING: math.private compiler.cfg.debugger ; intersect-live-ranges ] unit-test +[ f ] [ + { + T{ live-range f 0 10 } + T{ live-range f 20 30 } + T{ live-range f 40 50 } + } + { + T{ live-range f 11 15 } + T{ live-range f 31 36 } + T{ live-range f 51 55 } + } + intersect-live-ranges +] unit-test + [ 5 ] [ T{ live-interval { start 0 } @@ -1373,5 +500,991 @@ USING: math.private compiler.cfg.debugger ; { uses { 5 10 } } { ranges V{ T{ live-range f 5 10 } } } } - intersect-inactive -] unit-test \ No newline at end of file + relevant-ranges intersect-live-ranges +] unit-test + +! register-status had problems because it used map>assoc where the sequence +! had multiple keys +H{ + { 1 int-rep } + { 2 int-rep } + { 3 int-rep } + { 4 int-rep } +} representations set + +[ { 0 10 } ] [ + H{ { int-regs { 0 1 } } } registers set + H{ + { int-regs + { + T{ live-interval + { vreg 1 } + { start 0 } + { end 20 } + { reg 0 } + { ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } } + { uses V{ 0 2 10 20 } } + } + + T{ live-interval + { vreg 2 } + { start 4 } + { end 40 } + { reg 0 } + { ranges V{ T{ live-range f 4 6 } T{ live-range f 30 40 } } } + { uses V{ 4 6 30 40 } } + } + } + } + } inactive-intervals set + H{ + { int-regs + { + T{ live-interval + { vreg 3 } + { start 0 } + { end 40 } + { reg 1 } + { ranges V{ T{ live-range f 0 40 } } } + { uses V{ 0 40 } } + } + } + } + } active-intervals set + + T{ live-interval + { vreg 4 } + { start 8 } + { end 10 } + { ranges V{ T{ live-range f 8 10 } } } + { uses V{ 8 10 } } + } + register-status +] unit-test + +:: test-linear-scan-on-cfg ( regs -- ) + [ + cfg new 0 get >>entry + dup cfg set + dup fake-representations + dup { { int-regs regs } } (linear-scan) + flatten-cfg 1array mr. + ] with-scope ; + +! Bug in live spill slots calculation + +V{ T{ ##prologue } T{ ##branch } } 0 test-bb + +V{ + T{ ##peek + { dst 703128 } + { loc D 1 } + } + T{ ##peek + { dst 703129 } + { loc D 0 } + } + T{ ##copy + { dst 703134 } + { src 703128 } + } + T{ ##copy + { dst 703135 } + { src 703129 } + } + T{ ##compare-imm-branch + { src1 703128 } + { src2 5 } + { cc cc/= } + } +} 1 test-bb + +V{ + T{ ##copy + { dst 703134 } + { src 703129 } + } + T{ ##copy + { dst 703135 } + { src 703128 } + } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##replace + { src 703134 } + { loc D 0 } + } + T{ ##replace + { src 703135 } + { loc D 1 } + } + T{ ##epilogue } + T{ ##return } +} 3 test-bb + +0 1 edge +1 { 2 3 } edges +2 3 edge + +! Bug in inactive interval handling +! [ rot dup [ -rot ] when ] +V{ T{ ##prologue } T{ ##branch } } 0 test-bb + +V{ + T{ ##peek + { dst 689473 } + { loc D 2 } + } + T{ ##peek + { dst 689474 } + { loc D 1 } + } + T{ ##peek + { dst 689475 } + { loc D 0 } + } + T{ ##compare-imm-branch + { src1 689473 } + { src2 5 } + { cc cc/= } + } +} 1 test-bb + +V{ + T{ ##copy + { dst 689481 } + { src 689475 } + { rep int-rep } + } + T{ ##copy + { dst 689482 } + { src 689474 } + { rep int-rep } + } + T{ ##copy + { dst 689483 } + { src 689473 } + { rep int-rep } + } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##copy + { dst 689481 } + { src 689473 } + { rep int-rep } + } + T{ ##copy + { dst 689482 } + { src 689475 } + { rep int-rep } + } + T{ ##copy + { dst 689483 } + { src 689474 } + { rep int-rep } + } + T{ ##branch } +} 3 test-bb + +V{ + T{ ##replace + { src 689481 } + { loc D 0 } + } + T{ ##replace + { src 689482 } + { loc D 1 } + } + T{ ##replace + { src 689483 } + { loc D 2 } + } + T{ ##epilogue } + T{ ##return } +} 4 test-bb + +test-diamond + +[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test + +! Similar to the above +! [ swap dup [ rot ] when ] + +T{ basic-block + { id 201537 } + { number 0 } + { instructions V{ T{ ##prologue } T{ ##branch } } } +} 0 set + +V{ + T{ ##peek + { dst 689600 } + { loc D 1 } + } + T{ ##peek + { dst 689601 } + { loc D 0 } + } + T{ ##compare-imm-branch + { src1 689600 } + { src2 5 } + { cc cc/= } + } +} 1 test-bb + +V{ + T{ ##peek + { dst 689604 } + { loc D 2 } + } + T{ ##copy + { dst 689607 } + { src 689604 } + } + T{ ##copy + { dst 689608 } + { src 689600 } + { rep int-rep } + } + T{ ##copy + { dst 689610 } + { src 689601 } + { rep int-rep } + } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##peek + { dst 689609 } + { loc D 2 } + } + T{ ##copy + { dst 689607 } + { src 689600 } + { rep int-rep } + } + T{ ##copy + { dst 689608 } + { src 689601 } + { rep int-rep } + } + T{ ##copy + { dst 689610 } + { src 689609 } + { rep int-rep } + } + T{ ##branch } +} 3 test-bb + +V{ + T{ ##replace + { src 689607 } + { loc D 0 } + } + T{ ##replace + { src 689608 } + { loc D 1 } + } + T{ ##replace + { src 689610 } + { loc D 2 } + } + T{ ##epilogue } + T{ ##return } +} 4 test-bb + +test-diamond + +[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test + +! compute-live-registers was inaccurate since it didn't take +! lifetime holes into account + +V{ T{ ##prologue } T{ ##branch } } 0 test-bb + +V{ + T{ ##peek + { dst 0 } + { loc D 0 } + } + T{ ##compare-imm-branch + { src1 0 } + { src2 5 } + { cc cc/= } + } +} 1 test-bb + +V{ + T{ ##peek + { dst 1 } + { loc D 1 } + } + T{ ##copy + { dst 2 } + { src 1 } + { rep int-rep } + } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##peek + { dst 3 } + { loc D 2 } + } + T{ ##copy + { dst 2 } + { src 3 } + { rep int-rep } + } + T{ ##branch } +} 3 test-bb + +V{ + T{ ##replace + { src 2 } + { loc D 0 } + } + T{ ##return } +} 4 test-bb + +test-diamond + +[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test + +! Inactive interval handling: splitting active interval +! if it fits in lifetime hole only partially + +V{ T{ ##peek f 3 R 1 } T{ ##branch } } 0 test-bb + +V{ + T{ ##peek f 2 R 0 } + T{ ##compare-imm-branch f 2 5 cc= } +} 1 test-bb + +V{ + T{ ##peek f 0 D 0 } + T{ ##branch } +} 2 test-bb + + +V{ + T{ ##peek f 1 D 1 } + T{ ##peek f 0 D 0 } + T{ ##replace f 1 D 2 } + T{ ##branch } +} 3 test-bb + +V{ + T{ ##replace f 3 R 2 } + T{ ##replace f 0 D 0 } + T{ ##return } +} 4 test-bb + +test-diamond + +[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test + +! Not until splitting is finished +! [ _copy ] [ 3 get instructions>> second class ] unit-test + +! Resolve pass; make sure the spilling is done correctly +V{ T{ ##peek f 3 R 1 } T{ ##branch } } 0 test-bb + +V{ + T{ ##peek f 2 R 0 } + T{ ##compare-imm-branch f 2 5 cc= } +} 1 test-bb + +V{ + T{ ##branch } +} 2 test-bb + +V{ + T{ ##replace f 3 R 1 } + T{ ##peek f 1 D 1 } + T{ ##peek f 0 D 0 } + T{ ##replace f 1 D 2 } + T{ ##replace f 0 D 2 } + T{ ##branch } +} 3 test-bb + +V{ + T{ ##replace f 3 R 2 } + T{ ##return } +} 4 test-bb + +test-diamond + +[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test + +[ _spill ] [ 2 get successors>> first instructions>> first class ] unit-test + +[ _spill ] [ 3 get instructions>> second class ] unit-test + +[ f ] [ 3 get instructions>> [ _reload? ] any? ] unit-test + +[ _reload ] [ 4 get instructions>> first class ] unit-test + +! Resolve pass +V{ + T{ ##branch } +} 0 test-bb + +V{ + T{ ##peek f 0 D 0 } + T{ ##compare-imm-branch f 0 5 cc= } +} 1 test-bb + +V{ + T{ ##replace f 0 D 0 } + T{ ##peek f 1 D 0 } + T{ ##peek f 2 D 0 } + T{ ##replace f 1 D 0 } + T{ ##replace f 2 D 0 } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##branch } +} 3 test-bb + +V{ + T{ ##peek f 1 D 0 } + T{ ##compare-imm-branch f 1 5 cc= } +} 4 test-bb + +V{ + T{ ##replace f 0 D 0 } + T{ ##return } +} 5 test-bb + +V{ + T{ ##replace f 0 D 0 } + T{ ##return } +} 6 test-bb + +0 1 edge +1 { 2 3 } edges +2 4 edge +3 4 edge +4 { 5 6 } edges + +[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test + +[ t ] [ 2 get instructions>> [ _spill? ] any? ] unit-test + +[ t ] [ 3 get predecessors>> first instructions>> [ _spill? ] any? ] unit-test + +[ t ] [ 5 get instructions>> [ _reload? ] any? ] unit-test + +! A more complicated failure case with resolve that came up after the above +! got fixed +V{ T{ ##branch } } 0 test-bb +V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##peek f 2 D 2 } + T{ ##peek f 3 D 3 } + T{ ##peek f 4 D 0 } + T{ ##branch } +} 1 test-bb +V{ T{ ##branch } } 2 test-bb +V{ T{ ##branch } } 3 test-bb +V{ + + T{ ##replace f 1 D 1 } + T{ ##replace f 2 D 2 } + T{ ##replace f 3 D 3 } + T{ ##replace f 4 D 4 } + T{ ##replace f 0 D 0 } + T{ ##branch } +} 4 test-bb +V{ T{ ##replace f 0 D 0 } T{ ##branch } } 5 test-bb +V{ T{ ##return } } 6 test-bb +V{ T{ ##branch } } 7 test-bb +V{ + T{ ##replace f 1 D 1 } + T{ ##replace f 2 D 2 } + T{ ##replace f 3 D 3 } + T{ ##peek f 5 D 1 } + T{ ##peek f 6 D 2 } + T{ ##peek f 7 D 3 } + T{ ##peek f 8 D 4 } + T{ ##replace f 5 D 1 } + T{ ##replace f 6 D 2 } + T{ ##replace f 7 D 3 } + T{ ##replace f 8 D 4 } + T{ ##branch } +} 8 test-bb +V{ + T{ ##replace f 1 D 1 } + T{ ##replace f 2 D 2 } + T{ ##replace f 3 D 3 } + T{ ##return } +} 9 test-bb + +0 1 edge +1 { 2 7 } edges +7 8 edge +8 9 edge +2 { 3 5 } edges +3 4 edge +4 9 edge +5 6 edge + +[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test + +[ _spill ] [ 1 get instructions>> second class ] unit-test +[ _reload ] [ 4 get instructions>> 4 swap nth class ] unit-test +[ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ n>> cell / ] map ] unit-test +[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> cell / ] map ] unit-test + +! Resolve pass should insert this +[ _reload ] [ 5 get predecessors>> first instructions>> first class ] unit-test + +! Some random bug +V{ + T{ ##peek f 1 D 1 } + T{ ##peek f 2 D 2 } + T{ ##replace f 1 D 1 } + T{ ##replace f 2 D 2 } + T{ ##peek f 3 D 0 } + T{ ##peek f 0 D 0 } + T{ ##branch } +} 0 test-bb + +V{ T{ ##branch } } 1 test-bb + +V{ + T{ ##peek f 1 D 1 } + T{ ##peek f 2 D 2 } + T{ ##replace f 3 D 3 } + T{ ##replace f 1 D 1 } + T{ ##replace f 2 D 2 } + T{ ##replace f 0 D 3 } + T{ ##branch } +} 2 test-bb + +V{ T{ ##branch } } 3 test-bb + +V{ + T{ ##return } +} 4 test-bb + +test-diamond + +[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test + +! Spilling an interval immediately after its activated; +! and the interval does not have a use at the activation point +V{ + T{ ##peek f 1 D 1 } + T{ ##peek f 2 D 2 } + T{ ##replace f 1 D 1 } + T{ ##replace f 2 D 2 } + T{ ##peek f 0 D 0 } + T{ ##branch } +} 0 test-bb + +V{ T{ ##branch } } 1 test-bb + +V{ + T{ ##peek f 1 D 1 } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##replace f 1 D 1 } + T{ ##peek f 2 D 2 } + T{ ##replace f 2 D 2 } + T{ ##branch } +} 3 test-bb + +V{ T{ ##branch } } 4 test-bb + +V{ + T{ ##replace f 0 D 0 } + T{ ##return } +} 5 test-bb + +0 1 edge +1 { 2 4 } edges +4 5 edge +2 3 edge +3 5 edge + +[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test + +! Reduction of push-all regression, x86-32 +V{ T{ ##prologue } T{ ##branch } } 0 test-bb + +V{ + T{ ##load-immediate { dst 61 } } + T{ ##peek { dst 62 } { loc D 0 } } + T{ ##peek { dst 64 } { loc D 1 } } + T{ ##slot-imm + { dst 69 } + { obj 64 } + { slot 1 } + { tag 2 } + } + T{ ##copy { dst 79 } { src 69 } { rep int-rep } } + T{ ##slot-imm + { dst 85 } + { obj 62 } + { slot 2 } + { tag 7 } + } + T{ ##compare-branch + { src1 69 } + { src2 85 } + { cc cc> } + } +} 1 test-bb + +V{ + T{ ##slot-imm + { dst 97 } + { obj 62 } + { slot 2 } + { tag 7 } + } + T{ ##replace { src 79 } { loc D 3 } } + T{ ##replace { src 62 } { loc D 4 } } + T{ ##replace { src 79 } { loc D 1 } } + T{ ##replace { src 62 } { loc D 2 } } + T{ ##replace { src 61 } { loc D 5 } } + T{ ##replace { src 62 } { loc R 0 } } + T{ ##replace { src 69 } { loc R 1 } } + T{ ##replace { src 97 } { loc D 0 } } + T{ ##call { word resize-array } } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##peek { dst 98 } { loc R 0 } } + T{ ##peek { dst 100 } { loc D 0 } } + T{ ##set-slot-imm + { src 100 } + { obj 98 } + { slot 2 } + { tag 7 } + } + T{ ##peek { dst 108 } { loc D 2 } } + T{ ##peek { dst 110 } { loc D 3 } } + T{ ##peek { dst 112 } { loc D 0 } } + T{ ##peek { dst 114 } { loc D 1 } } + T{ ##peek { dst 116 } { loc D 4 } } + T{ ##peek { dst 119 } { loc R 0 } } + T{ ##copy { dst 109 } { src 108 } { rep int-rep } } + T{ ##copy { dst 111 } { src 110 } { rep int-rep } } + T{ ##copy { dst 113 } { src 112 } { rep int-rep } } + T{ ##copy { dst 115 } { src 114 } { rep int-rep } } + T{ ##copy { dst 117 } { src 116 } { rep int-rep } } + T{ ##copy { dst 120 } { src 119 } { rep int-rep } } + T{ ##branch } +} 3 test-bb + +V{ + T{ ##copy { dst 109 } { src 62 } { rep int-rep } } + T{ ##copy { dst 111 } { src 61 } { rep int-rep } } + T{ ##copy { dst 113 } { src 62 } { rep int-rep } } + T{ ##copy { dst 115 } { src 79 } { rep int-rep } } + T{ ##copy { dst 117 } { src 64 } { rep int-rep } } + T{ ##copy { dst 120 } { src 69 } { rep int-rep } } + T{ ##branch } +} 4 test-bb + +V{ + T{ ##replace { src 120 } { loc D 0 } } + T{ ##replace { src 109 } { loc D 3 } } + T{ ##replace { src 111 } { loc D 4 } } + T{ ##replace { src 113 } { loc D 1 } } + T{ ##replace { src 115 } { loc D 2 } } + T{ ##replace { src 117 } { loc D 5 } } + T{ ##epilogue } + T{ ##return } +} 5 test-bb + +0 1 edge +1 { 2 4 } edges +2 3 edge +3 5 edge +4 5 edge + +[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test + +! Another reduction of push-all +V{ T{ ##prologue } T{ ##branch } } 0 test-bb + +V{ + T{ ##peek { dst 85 } { loc D 0 } } + T{ ##slot-imm + { dst 89 } + { obj 85 } + { slot 3 } + { tag 7 } + } + T{ ##peek { dst 91 } { loc D 1 } } + T{ ##slot-imm + { dst 96 } + { obj 91 } + { slot 1 } + { tag 2 } + } + T{ ##add + { dst 109 } + { src1 89 } + { src2 96 } + } + T{ ##slot-imm + { dst 115 } + { obj 85 } + { slot 2 } + { tag 7 } + } + T{ ##slot-imm + { dst 118 } + { obj 115 } + { slot 1 } + { tag 2 } + } + T{ ##compare-branch + { src1 109 } + { src2 118 } + { cc cc> } + } +} 1 test-bb + +V{ + T{ ##add-imm + { dst 128 } + { src1 109 } + { src2 8 } + } + T{ ##load-immediate { dst 129 } { val 24 } } + T{ ##inc-d { n 4 } } + T{ ##inc-r { n 1 } } + T{ ##replace { src 109 } { loc D 2 } } + T{ ##replace { src 85 } { loc D 3 } } + T{ ##replace { src 128 } { loc D 0 } } + T{ ##replace { src 85 } { loc D 1 } } + T{ ##replace { src 89 } { loc D 4 } } + T{ ##replace { src 96 } { loc R 0 } } + T{ ##replace { src 129 } { loc R 0 } } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##peek { dst 134 } { loc D 1 } } + T{ ##slot-imm + { dst 140 } + { obj 134 } + { slot 2 } + { tag 7 } + } + T{ ##inc-d { n 1 } } + T{ ##inc-r { n 1 } } + T{ ##replace { src 140 } { loc D 0 } } + T{ ##replace { src 134 } { loc R 0 } } + T{ ##call { word resize-array } } + T{ ##branch } +} 3 test-bb + +V{ + T{ ##peek { dst 141 } { loc R 0 } } + T{ ##peek { dst 143 } { loc D 0 } } + T{ ##set-slot-imm + { src 143 } + { obj 141 } + { slot 2 } + { tag 7 } + } + T{ ##write-barrier + { src 141 } + { card# 145 } + { table 146 } + } + T{ ##inc-d { n -1 } } + T{ ##inc-r { n -1 } } + T{ ##peek { dst 156 } { loc D 2 } } + T{ ##peek { dst 158 } { loc D 3 } } + T{ ##peek { dst 160 } { loc D 0 } } + T{ ##peek { dst 162 } { loc D 1 } } + T{ ##peek { dst 164 } { loc D 4 } } + T{ ##peek { dst 167 } { loc R 0 } } + T{ ##copy { dst 157 } { src 156 } { rep int-rep } } + T{ ##copy { dst 159 } { src 158 } { rep int-rep } } + T{ ##copy { dst 161 } { src 160 } { rep int-rep } } + T{ ##copy { dst 163 } { src 162 } { rep int-rep } } + T{ ##copy { dst 165 } { src 164 } { rep int-rep } } + T{ ##copy { dst 168 } { src 167 } { rep int-rep } } + T{ ##branch } +} 4 test-bb + +V{ + T{ ##inc-d { n 3 } } + T{ ##inc-r { n 1 } } + T{ ##copy { dst 157 } { src 85 } } + T{ ##copy { dst 159 } { src 89 } } + T{ ##copy { dst 161 } { src 85 } } + T{ ##copy { dst 163 } { src 109 } } + T{ ##copy { dst 165 } { src 91 } } + T{ ##copy { dst 168 } { src 96 } } + T{ ##branch } +} 5 test-bb + +V{ + T{ ##set-slot-imm + { src 163 } + { obj 161 } + { slot 3 } + { tag 7 } + } + T{ ##inc-d { n 1 } } + T{ ##inc-r { n -1 } } + T{ ##replace { src 168 } { loc D 0 } } + T{ ##replace { src 157 } { loc D 3 } } + T{ ##replace { src 159 } { loc D 4 } } + T{ ##replace { src 161 } { loc D 1 } } + T{ ##replace { src 163 } { loc D 2 } } + T{ ##replace { src 165 } { loc D 5 } } + T{ ##epilogue } + T{ ##return } +} 6 test-bb + +0 1 edge +1 { 2 5 } edges +2 3 edge +3 4 edge +4 6 edge +5 6 edge + +[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test + +! Fencepost error in assignment pass +V{ T{ ##branch } } 0 test-bb + +V{ + T{ ##peek f 0 D 0 } + T{ ##compare-imm-branch f 0 5 cc= } +} 1 test-bb + +V{ T{ ##branch } } 2 test-bb + +V{ + T{ ##peek f 1 D 0 } + T{ ##peek f 2 D 0 } + T{ ##replace f 1 D 0 } + T{ ##replace f 2 D 0 } + T{ ##branch } +} 3 test-bb + +V{ + T{ ##replace f 0 D 0 } + T{ ##return } +} 4 test-bb + +test-diamond + +[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test + +[ 0 ] [ 1 get instructions>> [ _spill? ] count ] unit-test + +[ 1 ] [ 2 get instructions>> [ _spill? ] count ] unit-test + +[ 1 ] [ 3 get predecessors>> first instructions>> [ _spill? ] count ] unit-test + +[ 1 ] [ 4 get instructions>> [ _reload? ] count ] unit-test + +! Another test case for fencepost error in assignment pass +V{ T{ ##branch } } 0 test-bb + +V{ + T{ ##peek f 0 D 0 } + T{ ##compare-imm-branch f 0 5 cc= } +} 1 test-bb + +V{ + T{ ##peek f 1 D 0 } + T{ ##peek f 2 D 0 } + T{ ##replace f 1 D 0 } + T{ ##replace f 2 D 0 } + T{ ##replace f 0 D 0 } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##branch } +} 3 test-bb + +V{ + T{ ##replace f 0 D 0 } + T{ ##return } +} 4 test-bb + +test-diamond + +[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test + +[ 0 ] [ 1 get instructions>> [ _spill? ] count ] unit-test + +[ 1 ] [ 2 get instructions>> [ _spill? ] count ] unit-test + +[ 1 ] [ 2 get instructions>> [ _reload? ] count ] unit-test + +[ 0 ] [ 3 get instructions>> [ _spill? ] count ] unit-test + +[ 0 ] [ 4 get instructions>> [ _reload? ] count ] unit-test + +V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##replace f 1 D 1 } + T{ ##branch } +} 0 test-bb + +V{ + T{ ##gc f 2 3 } + T{ ##branch } +} 1 test-bb + +V{ + T{ ##replace f 0 D 0 } + T{ ##return } +} 2 test-bb + +0 1 edge +1 2 edge + +[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test + +[ { 3 } ] [ 1 get instructions>> first tagged-values>> ] unit-test + +V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##compare-imm-branch f 1 5 cc= } +} 0 test-bb + +V{ + T{ ##gc f 2 3 } + T{ ##replace f 0 D 0 } + T{ ##return } +} 1 test-bb + +V{ + T{ ##return } +} 2 test-bb + +0 { 1 2 } edges + +[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test + +[ { 3 } ] [ 1 get instructions>> first tagged-values>> ] unit-test diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor index ffa356bfc2..5e723f098a 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan.factor @@ -1,14 +1,18 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors namespaces make +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 compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.allocation -compiler.cfg.linear-scan.assignment ; +compiler.cfg.linear-scan.allocation.state +compiler.cfg.linear-scan.assignment +compiler.cfg.linear-scan.resolve ; IN: compiler.cfg.linear-scan ! References: @@ -25,15 +29,13 @@ 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 -: (linear-scan) ( rpo machine-registers -- ) - [ - dup number-instructions - dup compute-live-intervals - ] dip - allocate-registers assign-registers ; +:: (linear-scan) ( cfg machine-registers -- ) + cfg compute-live-sets + cfg number-instructions + cfg compute-live-intervals machine-registers allocate-registers + cfg assign-registers + cfg resolve-data-flow + cfg check-numbering ; : linear-scan ( cfg -- cfg' ) - [ - dup reverse-post-order machine-registers (linear-scan) - spill-counts get >>spill-counts - ] with-scope ; + dup machine-registers (linear-scan) ; diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 546443b289..75dda9b475 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces kernel assocs accessors sequences math math.order fry -binary-search compiler.cfg.instructions compiler.cfg.registers -compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ; +combinators binary-search compiler.cfg.instructions compiler.cfg.registers +compiler.cfg.def-use compiler.cfg.liveness compiler.cfg.linearization.order +compiler.cfg ; IN: compiler.cfg.linear-scan.live-intervals TUPLE: live-range from to ; @@ -11,15 +12,30 @@ C: live-range TUPLE: live-interval vreg -reg spill-to reload-from split-before split-after -start end ranges uses -copy-from ; +reg spill-to reload-from +start end ranges uses ; -ERROR: dead-value-error vreg ; +GENERIC: covers? ( insn# obj -- ? ) + +M: f covers? 2drop f ; + +M: live-range covers? [ from>> ] [ to>> ] bi between? ; + +M: live-interval covers? ( insn# live-interval -- ? ) + ranges>> + dup length 4 <= [ + [ covers? ] with any? + ] [ + [ drop ] [ [ from>> <=> ] with search nip ] 2bi + covers? + ] if ; + +: add-new-range ( from to live-interval -- ) + [ ] dip ranges>> push ; : shorten-range ( n live-interval -- ) dup ranges>> empty? - [ vreg>> dead-value-error ] [ ranges>> last (>>from) ] if ; + [ dupd add-new-range ] [ ranges>> last (>>from) ] if ; : extend-range ( from to live-range -- ) ranges>> last @@ -27,9 +43,6 @@ ERROR: dead-value-error vreg ; [ min ] change-from drop ; -: add-new-range ( from to live-interval -- ) - [ ] dip ranges>> push ; - : extend-range? ( to live-interval -- ? ) ranges>> [ drop f ] [ last from>> >= ] if-empty ; @@ -37,8 +50,18 @@ ERROR: dead-value-error vreg ; 2dup extend-range? [ extend-range ] [ add-new-range ] if ; -: add-use ( n live-interval -- ) - uses>> push ; +GENERIC: operands-in-registers? ( insn -- ? ) + +M: vreg-insn operands-in-registers? drop t ; + +M: partial-sync-insn operands-in-registers? drop f ; + +: add-def ( insn live-interval -- ) + [ insn#>> ] [ uses>> ] bi* push ; + +: add-use ( insn live-interval -- ) + ! Every use is a potential def, no SSA here baby! + over operands-in-registers? [ add-def ] [ 2drop ] if ; : ( vreg -- live-interval ) \ live-interval new @@ -46,84 +69,122 @@ ERROR: dead-value-error vreg ; V{ } clone >>ranges swap >>vreg ; -: block-from ( -- n ) - basic-block get instructions>> first insn#>> ; +: block-from ( bb -- n ) instructions>> first insn#>> 1 - ; -: block-to ( -- n ) - basic-block get instructions>> last insn#>> ; +: block-to ( bb -- n ) instructions>> last insn#>> ; M: live-interval hashcode* nip [ start>> ] [ end>> 1000 * ] bi + ; -M: live-interval clone - call-next-method [ clone ] change-uses ; - ! Mapping from vreg to live-interval SYMBOL: live-intervals -: live-interval ( vreg live-intervals -- live-interval ) - [ ] cache ; +: live-interval ( vreg -- live-interval ) + live-intervals get [ ] cache ; GENERIC: compute-live-intervals* ( insn -- ) M: insn compute-live-intervals* drop ; -: handle-output ( n vreg live-intervals -- ) +: handle-output ( insn vreg -- ) live-interval - [ add-use ] [ shorten-range ] 2bi ; + [ [ insn#>> ] dip shorten-range ] [ add-def ] 2bi ; -: handle-input ( n vreg live-intervals -- ) +: handle-input ( insn vreg -- ) live-interval - [ [ block-from ] 2dip add-range ] [ add-use ] 2bi ; + [ [ [ basic-block get block-from ] dip insn#>> ] dip add-range ] [ add-use ] 2bi ; -: handle-temp ( n vreg live-intervals -- ) +: handle-temp ( insn vreg -- ) live-interval - [ dupd add-range ] [ add-use ] 2bi ; + [ [ insn#>> dup ] dip add-range ] [ add-use ] 2bi ; M: vreg-insn compute-live-intervals* - dup insn#>> - live-intervals get - [ [ defs-vregs ] 2dip '[ [ _ ] dip _ handle-output ] each ] - [ [ uses-vregs ] 2dip '[ [ _ ] dip _ handle-input ] each ] - [ [ temp-vregs ] 2dip '[ [ _ ] dip _ handle-temp ] each ] - 3tri ; - -: record-copy ( insn -- ) - [ dst>> live-intervals get at ] [ src>> ] bi >>copy-from drop ; - -M: ##copy compute-live-intervals* - [ call-next-method ] [ record-copy ] bi ; - -M: ##copy-float compute-live-intervals* - [ call-next-method ] [ record-copy ] bi ; + [ dup defs-vreg [ handle-output ] with when* ] + [ dup uses-vregs [ handle-input ] with each ] + [ dup temp-vregs [ handle-temp ] with each ] + tri ; : handle-live-out ( bb -- ) - live-out keys block-from block-to live-intervals get '[ - [ _ _ ] dip _ live-interval add-range - ] each ; + [ block-from ] [ block-to ] [ live-out keys ] tri + [ live-interval add-range ] with with each ; + +! A location where all registers have to be spilled +TUPLE: sync-point n ; + +C: sync-point + +! Sequence of sync points +SYMBOL: sync-points + +GENERIC: compute-sync-points* ( insn -- ) + +M: partial-sync-insn compute-sync-points* + insn#>> sync-points get push ; + +M: insn compute-sync-points* drop ; : compute-live-intervals-step ( bb -- ) [ basic-block set ] [ handle-live-out ] - [ instructions>> [ compute-live-intervals* ] each ] tri ; + [ + instructions>> [ + [ compute-live-intervals* ] + [ compute-sync-points* ] + bi + ] each + ] tri ; +: init-live-intervals ( -- ) + H{ } clone live-intervals set + V{ } clone sync-points set ; + : compute-start/end ( live-interval -- ) dup ranges>> [ first from>> ] [ last to>> ] bi - 2dup > [ "BUG: start > end" throw ] when [ >>start ] [ >>end ] bi* drop ; -: finish-live-intervals ( live-intervals -- ) +ERROR: bad-live-interval live-interval ; + +: check-start ( live-interval -- ) + dup start>> -1 = [ bad-live-interval ] [ drop ] if ; + +: finish-live-intervals ( live-intervals -- seq ) ! Since live intervals are computed in a backward order, we have ! to reverse some sequences, and compute the start and end. - [ - [ ranges>> reverse-here ] - [ uses>> reverse-here ] - [ compute-start/end ] - tri + values dup [ + { + [ ranges>> reverse-here ] + [ uses>> reverse-here ] + [ compute-start/end ] + [ check-start ] + } cleave ] each ; -: compute-live-intervals ( rpo -- live-intervals ) - H{ } clone [ - live-intervals set - [ compute-live-intervals-step ] each - ] keep values dup finish-live-intervals ; +: compute-live-intervals ( cfg -- live-intervals sync-points ) + init-live-intervals + linearization-order [ compute-live-intervals-step ] each + live-intervals get finish-live-intervals + sync-points get ; + +: relevant-ranges ( interval1 interval2 -- ranges1 ranges2 ) + [ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ; + +: intersect-live-range ( range1 range2 -- n/f ) + 2dup [ from>> ] bi@ > [ swap ] when + 2dup [ to>> ] [ from>> ] bi* >= [ nip from>> ] [ 2drop f ] if ; + +: intersect-live-ranges ( ranges1 ranges2 -- n ) + { + { [ over empty? ] [ 2drop f ] } + { [ dup empty? ] [ 2drop f ] } + [ + 2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [ + drop + 2dup [ first from>> ] bi@ < + [ [ rest-slice ] dip ] [ rest-slice ] if + intersect-live-ranges + ] if + ] + } cond ; + +: intervals-intersect? ( interval1 interval2 -- ? ) + relevant-ranges intersect-live-ranges >boolean ; inline \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/numbering/numbering.factor b/basis/compiler/cfg/linear-scan/numbering/numbering.factor index 6734f6a359..6fd97c64da 100644 --- a/basis/compiler/cfg/linear-scan/numbering/numbering.factor +++ b/basis/compiler/cfg/linear-scan/numbering/numbering.factor @@ -1,11 +1,24 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors math sequences ; +USING: kernel accessors math sequences grouping namespaces +compiler.cfg.linearization.order ; IN: compiler.cfg.linear-scan.numbering : number-instructions ( rpo -- ) - [ 0 ] dip [ + linearization-order 0 [ instructions>> [ [ (>>insn#) ] [ drop 2 + ] 2bi ] each - ] each drop ; \ No newline at end of file + ] reduce drop ; + +SYMBOL: check-numbering? + +ERROR: bad-numbering bb ; + +: check-block-numbering ( bb -- ) + dup instructions>> [ insn#>> ] map sift [ <= ] monotonic? + [ drop ] [ bad-numbering ] if ; + +: check-numbering ( cfg -- ) + check-numbering? get + [ linearization-order [ check-block-numbering ] each ] [ drop ] if ; \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor new file mode 100644 index 0000000000..47c1f0ae76 --- /dev/null +++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor @@ -0,0 +1,67 @@ +USING: compiler.cfg.linear-scan.resolve tools.test kernel namespaces +accessors +compiler.cfg +compiler.cfg.instructions cpu.architecture make sequences +compiler.cfg.linear-scan.allocation.state ; +IN: compiler.cfg.linear-scan.resolve.tests + +[ + { + { { T{ spill-slot f 0 } int-rep } { 1 int-rep } } + } +] [ + [ + 0 1 int-rep add-mapping + ] { } make +] unit-test + +[ + { + T{ _reload { dst 1 } { rep int-rep } { n 0 } } + } +] [ + [ + { T{ spill-slot f 0 } int-rep } { 1 int-rep } >insn + ] { } make +] unit-test + +[ + { + T{ _spill { src 1 } { rep int-rep } { n 0 } } + } +] [ + [ + { 1 int-rep } { T{ spill-slot f 0 } int-rep } >insn + ] { } make +] unit-test + +[ + { + T{ ##copy { src 1 } { dst 2 } { rep int-rep } } + } +] [ + [ + { 1 int-rep } { 2 int-rep } >insn + ] { } make +] 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 } } } + mapping-instructions { + { + T{ _spill { src 0 } { rep int-rep } { n 8 } } + T{ ##copy { dst 0 } { src 1 } { rep int-rep } } + T{ _reload { dst 1 } { rep int-rep } { n 8 } } + } + { + T{ _spill { src 1 } { rep int-rep } { n 8 } } + T{ ##copy { dst 1 } { src 0 } { rep int-rep } } + T{ _reload { dst 0 } { rep int-rep } { n 8 } } + } + } member? +] unit-test diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor new file mode 100644 index 0000000000..15dff23448 --- /dev/null +++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor @@ -0,0 +1,82 @@ +! Copyright (C) 2009 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 +compiler.cfg +compiler.cfg.rpo +compiler.cfg.liveness +compiler.cfg.registers +compiler.cfg.utilities +compiler.cfg.instructions +compiler.cfg.predecessors +compiler.cfg.parallel-copy +compiler.cfg.linear-scan.assignment +compiler.cfg.linear-scan.allocation.state ; +IN: compiler.cfg.linear-scan.resolve + +SYMBOL: spill-temps + +: spill-temp ( rep -- n ) + spill-temps get [ next-spill-slot ] cache ; + +: add-mapping ( from to rep -- ) + '[ _ 2array ] bi@ 2array , ; + +:: resolve-value-data-flow ( bb to vreg -- ) + vreg bb vreg-at-end + vreg to vreg-at-start + 2dup = [ 2drop ] [ vreg 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 + ] if ; + +: memory->register ( from to -- ) + swap [ first2 ] [ first n>> ] bi* _reload ; + +: register->memory ( from to -- ) + [ first2 ] [ first n>> ] bi* _spill ; + +: temp->register ( from to -- ) + nip [ first ] [ second ] [ second spill-temp ] tri _reload ; + +: register->temp ( from to -- ) + drop [ first2 ] [ second spill-temp ] bi _spill ; + +: register->register ( from to -- ) + swap [ first ] [ first2 ] bi* ##copy ; + +SYMBOL: temp + +: >insn ( from to -- ) + { + { [ over temp eq? ] [ temp->register ] } + { [ dup temp eq? ] [ register->temp ] } + { [ over first spill-slot? ] [ memory->register ] } + { [ dup first spill-slot? ] [ register->memory ] } + [ register->register ] + } cond ; + +: mapping-instructions ( alist -- insns ) + [ swap ] H{ } assoc-map-as + [ temp [ swap >insn ] parallel-mapping ] { } make ; + +: perform-mappings ( bb to mappings -- ) + dup empty? [ 3drop ] [ + mapping-instructions insert-simple-basic-block + cfg get cfg-changed drop + ] if ; + +: resolve-edge-data-flow ( bb to -- ) + 2dup compute-mappings perform-mappings ; + +: resolve-block-data-flow ( bb -- ) + dup successors>> [ resolve-edge-data-flow ] with each ; + +: resolve-data-flow ( cfg -- ) + needs-predecessors + + H{ } clone spill-temps set + [ resolve-block-data-flow ] each-basic-block ; diff --git a/basis/compiler/cfg/linearization/linearization-tests.factor b/basis/compiler/cfg/linearization/linearization-tests.factor deleted file mode 100644 index fe8b4fd0c0..0000000000 --- a/basis/compiler/cfg/linearization/linearization-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: compiler.cfg.linearization.tests -USING: compiler.cfg.linearization tools.test ; - - diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index 9e222f1832..32df6233bd 100755 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -1,131 +1,110 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math accessors sequences namespaces make -combinators assocs arrays locals cpu.architecture +combinators assocs arrays locals layouts hashtables +cpu.architecture compiler.cfg -compiler.cfg.rpo -compiler.cfg.liveness +compiler.cfg.comparisons compiler.cfg.stack-frame -compiler.cfg.instructions ; +compiler.cfg.instructions +compiler.cfg.utilities +compiler.cfg.linearization.order ; IN: compiler.cfg.linearization +hashtable numbers set ; + ! Convert CFG IR to machine IR. GENERIC: linearize-insn ( basic-block insn -- ) : linearize-basic-block ( bb -- ) - [ number>> _label ] + [ 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 RPO, then we - #! don't need to branch. - [ number>> ] bi@ 1 - = ; inline + ! If our successor immediately follows us in linearization + ! order then we don't need to branch. + [ block-number ] bi@ 1 - = ; inline -: branch-to-branch? ( successor -- ? ) - #! A branch to a block containing just a jump return is cloned. - instructions>> dup length 2 = [ - [ first ##epilogue? ] - [ second [ ##return? ] [ ##jump? ] bi or ] bi and - ] [ drop f ] if ; - -: emit-branch ( basic-block successor -- ) - { - { [ 2dup useless-branch? ] [ 2drop ] } - { [ dup branch-to-branch? ] [ nip linearize-basic-block ] } - [ nip number>> _branch ] - } cond ; +: emit-branch ( bb successor -- ) + 2dup useless-branch? [ 2drop ] [ nip block-number _branch ] if ; M: ##branch linearize-insn drop dup successors>> first emit-branch ; -: (binary-conditional) ( basic-block insn -- basic-block successor1 successor2 src1 src2 cc ) - [ dup successors>> first2 ] +: successors ( bb -- first second ) successors>> first2 ; inline + +: (binary-conditional) ( bb insn -- bb successor1 successor2 src1 src2 cc ) + [ dup successors ] [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline -: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc ) +: binary-conditional ( bb insn -- bb successor label2 src1 src2 cc ) [ (binary-conditional) ] [ drop dup successors>> second useless-branch? ] 2bi - [ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ; - -: with-regs ( insn quot -- ) - over regs>> [ call ] dip building get last (>>regs) ; inline + [ [ swap block-number ] 3dip ] [ [ block-number ] 3dip negate-cc ] if ; M: ##compare-branch linearize-insn - [ binary-conditional _compare-branch ] with-regs emit-branch ; + binary-conditional _compare-branch emit-branch ; M: ##compare-imm-branch linearize-insn - [ binary-conditional _compare-imm-branch ] with-regs emit-branch ; + binary-conditional _compare-imm-branch emit-branch ; M: ##compare-float-branch linearize-insn - [ binary-conditional _compare-float-branch ] with-regs emit-branch ; + binary-conditional _compare-float-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 ] with-regs ] - [ successors>> [ number>> _dispatch-label ] each ] + [ [ src>> ] [ temp>> ] bi _dispatch ] + [ successors>> [ block-number _dispatch-label ] each ] bi* ; -: gc-root-registers ( n live-registers -- n ) - [ - [ second 2array , ] - [ first reg-class>> reg-size + ] - 2bi - ] each ; - -: gc-root-spill-slots ( n live-spill-slots -- n ) - [ - dup first reg-class>> int-regs eq? [ - [ second 2array , ] - [ first reg-class>> reg-size + ] - 2bi - ] [ drop ] if - ] each ; - -: oop-registers ( regs -- regs' ) - [ first reg-class>> int-regs eq? ] filter ; - -: data-registers ( regs -- regs' ) - [ first reg-class>> double-float-regs eq? ] filter ; - -:: compute-gc-roots ( live-registers live-spill-slots -- alist ) - [ - 0 - ! we put float registers last; the GC doesn't actually scan them - live-registers oop-registers gc-root-registers - live-spill-slots gc-root-spill-slots - live-registers data-registers gc-root-registers - drop - ] { } make ; - -: count-gc-roots ( live-registers live-spill-slots -- n ) - ! Size of GC root area, minus the float registers - [ oop-registers length ] bi@ + ; +: gc-root-offsets ( registers -- alist ) + ! Outputs a sequence of { offset register/spill-slot } pairs + [ length iota [ cell * ] map ] keep zip ; M: ##gc linearize-insn nip - [ + { [ temp1>> ] [ temp2>> ] - [ - [ live-registers>> ] [ live-spill-slots>> ] bi - [ compute-gc-roots ] - [ count-gc-roots ] - [ gc-roots-size ] - 2tri - ] tri - _gc - ] with-regs ; + [ data-values>> ] + [ tagged-values>> gc-root-offsets ] + [ uninitialized-locs>> ] + } cleave + _gc ; : linearize-basic-blocks ( cfg -- insns ) [ - [ [ linearize-basic-block ] each-basic-block ] - [ spill-counts>> _spill-counts ] - bi + [ + 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 ; diff --git a/basis/compiler/cfg/linearization/order/order.factor b/basis/compiler/cfg/linearization/order/order.factor new file mode 100644 index 0000000000..703db8e516 --- /dev/null +++ b/basis/compiler/cfg/linearization/order/order.factor @@ -0,0 +1,77 @@ +! 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 sets compiler.cfg.rpo compiler.cfg.utilities +compiler.cfg.loop-detection ; +IN: compiler.cfg.linearization.order + +! This is RPO except loops are rotated. Based on SBCL's src/compiler/control.lisp + + work-list set + H{ } clone visited set + entry>> add-to-work-list ; + +: (find-alternate-loop-head) ( bb -- bb' ) + dup { + [ predecessor visited? not ] + [ predecessors>> length 1 = ] + [ predecessor successors>> length 1 = ] + [ [ number>> ] [ predecessor number>> ] bi > ] + } 1&& [ predecessor (find-alternate-loop-head) ] when ; + +: find-back-edge ( bb -- pred ) + [ predecessors>> ] keep '[ _ back-edge? ] find nip ; + +: find-alternate-loop-head ( bb -- bb' ) + dup find-back-edge dup visited? [ drop ] [ + nip (find-alternate-loop-head) + ] if ; + +: predecessors-ready? ( bb -- ? ) + [ predecessors>> ] keep '[ + _ 2dup back-edge? + [ 2drop t ] [ drop visited? ] if + ] all? ; + +: process-successor ( bb -- ) + dup predecessors-ready? [ + dup loop-entry? [ find-alternate-loop-head ] when + add-to-work-list + ] [ drop ] if ; + +: sorted-successors ( bb -- seq ) + successors>> [ loop-nesting-at ] sort-with ; + +: process-block ( bb -- ) + [ , ] + [ visited get conjoin ] + [ sorted-successors [ process-successor ] each ] + tri ; + +: (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 + + dup linear-order>> [ ] [ + dup (linearization-order) + >>linear-order linear-order>> + ] ?if ; \ No newline at end of file diff --git a/basis/compiler/cfg/liveness/liveness-tests.factor b/basis/compiler/cfg/liveness/liveness-tests.factor new file mode 100644 index 0000000000..e4f5144e1f --- /dev/null +++ b/basis/compiler/cfg/liveness/liveness-tests.factor @@ -0,0 +1,61 @@ +USING: compiler.cfg.liveness compiler.cfg.debugger +compiler.cfg.instructions compiler.cfg.predecessors +compiler.cfg.registers compiler.cfg cpu.architecture +accessors namespaces sequences kernel tools.test vectors ; +IN: compiler.cfg.liveness.tests + +: test-liveness ( -- ) + cfg new 1 get >>entry + compute-live-sets ; + +! Sanity check... + +V{ + T{ ##peek f 0 D 0 } + T{ ##replace f 0 D 0 } + T{ ##replace f 1 D 1 } + T{ ##peek f 1 D 1 } + T{ ##branch } +} 1 test-bb + +V{ + T{ ##replace f 2 D 0 } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##replace f 3 D 0 } + T{ ##return } +} 3 test-bb + +1 { 2 3 } edges + +test-liveness + +[ + H{ + { 1 1 } + { 2 2 } + { 3 3 } + } +] +[ 1 get live-in ] +unit-test + +! Tricky case; defs must be killed before uses + +V{ + T{ ##peek f 0 D 0 } + T{ ##branch } +} 1 test-bb + +V{ + T{ ##add-imm f 0 0 10 } + T{ ##return } +} 2 test-bb + +1 2 edge + +test-liveness + +[ H{ { 0 0 } } ] [ 2 get live-in ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor index 6c40bb3782..a10b48cc0c 100644 --- a/basis/compiler/cfg/liveness/liveness.factor +++ b/basis/compiler/cfg/liveness/liveness.factor @@ -1,78 +1,31 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces deques accessors sets sequences assocs fry -dlists compiler.cfg.def-use compiler.cfg.instructions -compiler.cfg.rpo ; +USING: kernel accessors assocs sequences sets +compiler.cfg.def-use compiler.cfg.dataflow-analysis +compiler.cfg.instructions ; IN: compiler.cfg.liveness -! This is a backward dataflow analysis. See http://en.wikipedia.org/wiki/Liveness_analysis +! See http://en.wikipedia.org/wiki/Liveness_analysis +! Do not run after SSA construction -! Assoc mapping basic blocks to sets of vregs -SYMBOL: live-ins +BACKWARD-ANALYSIS: live -: live-in ( basic-block -- set ) live-ins get at ; +GENERIC: insn-liveness ( live-set insn -- ) -! Assoc mapping basic blocks to sequences of sets of vregs; each sequence -! is in conrrespondence with a predecessor -SYMBOL: phi-live-ins +: kill-defs ( live-set insn -- live-set ) + defs-vreg [ over delete-at ] when* ; -: phi-live-in ( predecessor basic-block -- set ) - [ predecessors>> index ] keep phi-live-ins get at - dup [ nth ] [ 2drop f ] if ; +: gen-uses ( live-set insn -- live-set ) + dup ##phi? [ drop ] [ uses-vregs [ over conjoin ] each ] if ; -! Assoc mapping basic blocks to sets of vregs -SYMBOL: live-outs +: transfer-liveness ( live-set instructions -- live-set' ) + [ clone ] [ ] bi* [ [ kill-defs ] [ gen-uses ] bi ] each ; -: live-out ( basic-block -- set ) live-outs get at ; +: local-live-in ( instructions -- live-set ) + [ H{ } ] dip transfer-liveness keys ; -SYMBOL: work-list +M: live-analysis transfer-set + drop instructions>> transfer-liveness ; -: add-to-work-list ( basic-blocks -- ) - work-list get '[ _ push-front ] each ; - -: map-unique ( seq quot -- assoc ) - map concat unique ; inline - -: gen-set ( instructions -- seq ) - [ ##phi? not ] filter [ uses-vregs ] map-unique ; - -: kill-set ( instructions -- seq ) - [ [ defs-vregs ] [ temp-vregs ] bi append ] map-unique ; - -: compute-live-in ( basic-block -- live-in ) - dup instructions>> - [ [ live-out ] [ gen-set ] bi* assoc-union ] - [ nip kill-set ] - 2bi assoc-diff ; - -: compute-phi-live-in ( basic-block -- phi-live-in ) - instructions>> [ ##phi? ] filter - [ f ] [ [ inputs>> ] map flip [ unique ] map ] if-empty ; - -: update-live-in ( basic-block -- changed? ) - [ [ compute-live-in ] keep live-ins get maybe-set-at ] - [ [ compute-phi-live-in ] keep phi-live-ins get maybe-set-at ] - bi and ; - -: compute-live-out ( basic-block -- live-out ) - [ successors>> [ live-in ] map ] - [ dup successors>> [ phi-live-in ] with map ] bi - append assoc-combine ; - -: update-live-out ( basic-block -- changed? ) - [ compute-live-out ] keep - live-outs get maybe-set-at ; - -: liveness-step ( basic-block -- ) - dup update-live-out [ - dup update-live-in - [ predecessors>> add-to-work-list ] [ drop ] if - ] [ drop ] if ; - -: compute-liveness ( cfg -- cfg' ) - work-list set - H{ } clone live-ins set - H{ } clone phi-live-ins set - H{ } clone live-outs set - dup post-order add-to-work-list - work-list get [ liveness-step ] slurp-deque ; +M: live-analysis join-sets + 2drop assoc-combine ; diff --git a/basis/compiler/cfg/liveness/ssa/ssa.factor b/basis/compiler/cfg/liveness/ssa/ssa.factor new file mode 100644 index 0000000000..81263c8e9a --- /dev/null +++ b/basis/compiler/cfg/liveness/ssa/ssa.factor @@ -0,0 +1,62 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces deques accessors sets sequences assocs fry +hashtables dlists compiler.cfg.def-use compiler.cfg.instructions +compiler.cfg.rpo compiler.cfg.liveness compiler.cfg.utilities +compiler.cfg.predecessors ; +IN: compiler.cfg.liveness.ssa + +! TODO: merge with compiler.cfg.liveness + +! Assoc mapping basic blocks to sequences of sets of vregs; each sequence +! is in correspondence with a predecessor +SYMBOL: phi-live-ins + +: phi-live-in ( predecessor basic-block -- set ) phi-live-ins get at at ; + +SYMBOL: work-list + +: add-to-work-list ( basic-blocks -- ) + work-list get '[ _ push-front ] each ; + +: compute-live-in ( basic-block -- live-in ) + [ live-out ] keep instructions>> transfer-liveness ; + +: compute-phi-live-in ( basic-block -- phi-live-in ) + H{ } clone [ + '[ inputs>> [ swap _ conjoin-at ] assoc-each ] each-phi + ] keep ; + +: update-live-in ( basic-block -- changed? ) + [ [ compute-live-in ] keep live-ins get maybe-set-at ] + [ [ compute-phi-live-in ] keep phi-live-ins get maybe-set-at ] + bi or ; + +: compute-live-out ( basic-block -- live-out ) + [ successors>> [ live-in ] map ] + [ dup successors>> [ phi-live-in ] with map ] bi + append assoc-combine ; + +: update-live-out ( basic-block -- changed? ) + [ compute-live-out ] keep + live-outs get maybe-set-at ; + +: liveness-step ( basic-block -- ) + dup update-live-out [ + dup update-live-in + [ predecessors>> add-to-work-list ] [ drop ] if + ] [ drop ] if ; + +: compute-ssa-live-sets ( cfg -- cfg' ) + needs-predecessors + + work-list set + H{ } clone live-ins set + H{ } clone phi-live-ins set + H{ } clone live-outs set + dup post-order add-to-work-list + work-list get [ liveness-step ] slurp-deque ; + +: live-in? ( vreg bb -- ? ) live-in key? ; + +: live-out? ( vreg bb -- ? ) live-out key? ; \ No newline at end of file diff --git a/basis/compiler/cfg/local/local.factor b/basis/compiler/cfg/local/local.factor deleted file mode 100644 index 5d78397998..0000000000 --- a/basis/compiler/cfg/local/local.factor +++ /dev/null @@ -1,10 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: fry accessors kernel assocs compiler.cfg.liveness compiler.cfg.rpo ; -IN: compiler.cfg.local - -: optimize-basic-block ( bb init-quot insn-quot -- ) - [ '[ live-in keys @ ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline - -: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' ) - [ dup ] 2dip '[ _ _ optimize-basic-block ] each-basic-block ; inline \ No newline at end of file diff --git a/basis/compiler/cfg/loop-detection/loop-detection-tests.factor b/basis/compiler/cfg/loop-detection/loop-detection-tests.factor new file mode 100644 index 0000000000..80203c65e4 --- /dev/null +++ b/basis/compiler/cfg/loop-detection/loop-detection-tests.factor @@ -0,0 +1,20 @@ +USING: compiler.cfg compiler.cfg.loop-detection +compiler.cfg.predecessors +compiler.cfg.debugger +tools.test kernel namespaces accessors ; +IN: compiler.cfg.loop-detection.tests + +V{ } 0 test-bb +V{ } 1 test-bb +V{ } 2 test-bb + +0 { 1 2 } edges +2 0 edge + +: test-loop-detection ( -- ) cfg new 0 get >>entry needs-loops drop ; + +[ ] [ test-loop-detection ] unit-test + +[ 1 ] [ 0 get loop-nesting-at ] unit-test +[ 0 ] [ 1 get loop-nesting-at ] unit-test +[ 1 ] [ 2 get loop-nesting-at ] unit-test diff --git a/basis/compiler/cfg/loop-detection/loop-detection.factor b/basis/compiler/cfg/loop-detection/loop-detection.factor new file mode 100644 index 0000000000..73b99ee132 --- /dev/null +++ b/basis/compiler/cfg/loop-detection/loop-detection.factor @@ -0,0 +1,83 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs combinators deques dlists fry kernel +namespaces sequences sets compiler.cfg compiler.cfg.predecessors ; +IN: compiler.cfg.loop-detection + +TUPLE: natural-loop header index ends blocks ; + +SYMBOL: loops + + ( header index -- loop ) + H{ } clone H{ } clone natural-loop boa ; + +: lookup-header ( header -- loop ) + loops get [ + loops get assoc-size + ] cache ; + +SYMBOLS: visited active ; + +: record-back-edge ( from to -- ) + lookup-header ends>> conjoin ; + +DEFER: find-loop-headers + +: visit-edge ( from to -- ) + dup active get key? + [ record-back-edge ] + [ nip find-loop-headers ] + if ; + +: find-loop-headers ( bb -- ) + dup visited get key? [ drop ] [ + { + [ visited get conjoin ] + [ active get conjoin ] + [ dup successors>> [ visit-edge ] with each ] + [ active get delete-at ] + } cleave + ] if ; + +SYMBOL: work-list + +: process-loop-block ( bb loop -- ) + 2dup blocks>> key? [ 2drop ] [ + [ blocks>> conjoin ] [ + 2dup header>> eq? [ 2drop ] [ + drop predecessors>> work-list get push-all-front + ] if + ] 2bi + ] if ; + +: process-loop-ends ( loop -- ) + [ ends>> keys [ push-all-front ] [ work-list set ] [ ] tri ] keep + '[ _ process-loop-block ] slurp-deque ; + +: process-loop-headers ( -- ) + loops get values [ process-loop-ends ] each ; + +SYMBOL: loop-nesting + +: compute-loop-nesting ( -- ) + loops get H{ } clone [ + [ values ] dip '[ blocks>> values [ _ inc-at ] each ] each + ] keep loop-nesting set ; + +: detect-loops ( cfg -- cfg' ) + needs-predecessors + H{ } clone loops set + H{ } clone visited set + H{ } clone active set + H{ } clone loop-nesting set + dup entry>> find-loop-headers process-loop-headers compute-loop-nesting ; + +PRIVATE> + +: loop-nesting-at ( bb -- n ) loop-nesting get at 0 or ; + +: needs-loops ( cfg -- cfg' ) + needs-predecessors + dup loops-valid?>> [ detect-loops t >>loops-valid? ] unless ; diff --git a/basis/compiler/cfg/mr/mr.factor b/basis/compiler/cfg/mr/mr.factor index 9f6a62090c..de679cbcc2 100644 --- a/basis/compiler/cfg/mr/mr.factor +++ b/basis/compiler/cfg/mr/mr.factor @@ -1,13 +1,11 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: compiler.cfg.linearization compiler.cfg.two-operand -compiler.cfg.liveness compiler.cfg.gc-checks compiler.cfg.linear-scan -compiler.cfg.build-stack-frame compiler.cfg.rpo ; +USING: kernel namespaces accessors compiler.cfg +compiler.cfg.linearization compiler.cfg.gc-checks +compiler.cfg.linear-scan compiler.cfg.build-stack-frame ; IN: compiler.cfg.mr : build-mr ( cfg -- mr ) - convert-two-operand - compute-liveness insert-gc-checks linear-scan flatten-cfg diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor deleted file mode 100644 index b95a8c79ea..0000000000 --- a/basis/compiler/cfg/optimizer/optimizer-tests.factor +++ /dev/null @@ -1,34 +0,0 @@ -USING: arrays sequences tools.test compiler.cfg.checker compiler.cfg.debugger -compiler.cfg.def-use sets kernel kernel.private fry slots.private vectors -sequences.private math sbufs math.private slots.private strings ; -IN: compiler.cfg.optimizer.tests - -! Miscellaneous tests - -: more? ( x -- ? ) ; - -: test-case-1 ( -- ? ) f ; - -: test-case-2 ( -- ) - test-case-1 [ test-case-2 ] [ ] if ; inline recursive - -{ - [ 1array ] - [ 1 2 ? ] - [ { array } declare [ ] map ] - [ { array } declare dup 1 slot [ 1 slot ] when ] - [ [ dup more? ] [ dup ] produce ] - [ vector new over test-case-1 [ test-case-2 ] [ ] if ] - [ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ] - [ - { fixnum sbuf } declare 2dup 3 slot fixnum> [ - over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot - ] [ ] if - ] - [ [ 2 fixnum* ] when 3 ] - [ [ 2 fixnum+ ] when 3 ] - [ [ 2 fixnum- ] when 3 ] - [ 10000 [ ] times ] -} [ - [ [ ] ] dip '[ _ test-mr first check-mr ] unit-test -] each diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index 9d481ef1d2..649032b469 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -1,17 +1,20 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences accessors combinators namespaces -compiler.cfg.predecessors -compiler.cfg.useless-blocks -compiler.cfg.height -compiler.cfg.stack-analysis +compiler.cfg.tco +compiler.cfg.useless-conditionals +compiler.cfg.branch-splitting +compiler.cfg.block-joining +compiler.cfg.ssa.construction compiler.cfg.alias-analysis compiler.cfg.value-numbering +compiler.cfg.copy-prop compiler.cfg.dce compiler.cfg.write-barrier -compiler.cfg.liveness -compiler.cfg.rpo -compiler.cfg.phi-elimination +compiler.cfg.representations +compiler.cfg.two-operand +compiler.cfg.ssa.destruction +compiler.cfg.empty-blocks compiler.cfg.checker ; IN: compiler.cfg.optimizer @@ -23,17 +26,18 @@ SYMBOL: check-optimizer? ] when ; : optimize-cfg ( cfg -- cfg' ) - [ - compute-predecessors - delete-useless-blocks - delete-useless-conditionals - normalize-height - stack-analysis - compute-liveness - alias-analysis - value-numbering - eliminate-dead-code - eliminate-write-barriers - eliminate-phis - ?check - ] with-scope ; + optimize-tail-calls + delete-useless-conditionals + split-branches + join-blocks + construct-ssa + alias-analysis + value-numbering + copy-propagation + eliminate-dead-code + eliminate-write-barriers + select-representations + convert-two-operand + destruct-ssa + delete-empty-blocks + ?check ; diff --git a/basis/compiler/cfg/parallel-copy/parallel-copy-tests.factor b/basis/compiler/cfg/parallel-copy/parallel-copy-tests.factor new file mode 100644 index 0000000000..66cc87beff --- /dev/null +++ b/basis/compiler/cfg/parallel-copy/parallel-copy-tests.factor @@ -0,0 +1,63 @@ +USING: compiler.cfg.parallel-copy tools.test make arrays +compiler.cfg.registers namespaces compiler.cfg.instructions +cpu.architecture ; +IN: compiler.cfg.parallel-copy.tests + +SYMBOL: temp + +: test-parallel-copy ( mapping -- seq ) + 3 vreg-counter set-global + [ parallel-copy ] { } make ; + +[ + { + T{ ##copy f 4 2 any-rep } + T{ ##copy f 2 1 any-rep } + T{ ##copy f 1 4 any-rep } + } +] [ + H{ + { 1 2 } + { 2 1 } + } test-parallel-copy +] unit-test + +[ + { + T{ ##copy f 1 2 any-rep } + T{ ##copy f 3 4 any-rep } + } +] [ + H{ + { 1 2 } + { 3 4 } + } test-parallel-copy +] unit-test + +[ + { + T{ ##copy f 1 3 any-rep } + T{ ##copy f 2 1 any-rep } + } +] [ + H{ + { 1 3 } + { 2 3 } + } test-parallel-copy +] unit-test + +[ + { + T{ ##copy f 4 3 any-rep } + T{ ##copy f 3 2 any-rep } + T{ ##copy f 2 1 any-rep } + T{ ##copy f 1 4 any-rep } + } +] [ + { + { 2 1 } + { 3 2 } + { 1 3 } + { 4 3 } + } test-parallel-copy +] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/parallel-copy/parallel-copy.factor b/basis/compiler/cfg/parallel-copy/parallel-copy.factor new file mode 100644 index 0000000000..ef4bada633 --- /dev/null +++ b/basis/compiler/cfg/parallel-copy/parallel-copy.factor @@ -0,0 +1,61 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs cpu.architecture compiler.cfg.registers +compiler.cfg.instructions deques dlists fry kernel locals namespaces +sequences hashtables ; +IN: compiler.cfg.parallel-copy + +! Revisiting Out-of-SSA Translation for Correctness, Code Quality, and Efficiency +! http://hal.archives-ouvertes.fr/docs/00/34/99/25/PDF/OutSSA-RR.pdf, +! Algorithm 1 + + to-do set + ready set + [ preds set ] + [ [ nip dup ] H{ } assoc-map-as locs set ] + [ keys [ init-to-do ] [ init-ready ] bi ] tri ; + +:: process-ready ( b quot -- ) + b preds get at :> a + a locs get at :> c + b c quot call + b a locs get set-at + a c = a preds get at and [ a ready get push-front ] when ; inline + +:: process-to-do ( b quot -- ) + ! Note that we check if b = loc(b), not b = loc(pred(b)) as the + ! paper suggests. Confirmed by one of the authors at + ! http://www.reddit.com/comments/93253/some_lecture_notes_on_ssa_form/c0bco4f + b locs get at b = [ + temp get b quot call + temp get b locs get set-at + b ready get push-front + ] when ; inline + +PRIVATE> + +:: parallel-mapping ( mapping temp quot -- ) + [ + mapping temp init + to-do get [ + ready get [ + quot process-ready + ] slurp-deque + quot process-to-do + ] slurp-deque + ] with-scope ; inline + +: parallel-copy ( mapping -- ) + next-vreg [ any-rep ##copy ] parallel-mapping ; \ No newline at end of file diff --git a/basis/compiler/cfg/phi-elimination/authors.txt b/basis/compiler/cfg/phi-elimination/authors.txt deleted file mode 100644 index d4f5d6b3ae..0000000000 --- a/basis/compiler/cfg/phi-elimination/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov \ No newline at end of file diff --git a/basis/compiler/cfg/phi-elimination/phi-elimination.factor b/basis/compiler/cfg/phi-elimination/phi-elimination.factor deleted file mode 100644 index 3ebf553a45..0000000000 --- a/basis/compiler/cfg/phi-elimination/phi-elimination.factor +++ /dev/null @@ -1,21 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors compiler.cfg compiler.cfg.instructions -compiler.cfg.rpo fry kernel sequences ; -IN: compiler.cfg.phi-elimination - -: insert-copy ( predecessor input output -- ) - '[ _ _ swap ##copy ] add-instructions ; - -: eliminate-phi ( bb ##phi -- ) - [ predecessors>> ] [ [ inputs>> ] [ dst>> ] bi ] bi* - '[ _ insert-copy ] 2each ; - -: eliminate-phi-step ( bb -- ) - dup [ - [ ##phi? ] partition - [ [ eliminate-phi ] with each ] dip - ] change-instructions drop ; - -: eliminate-phis ( cfg -- cfg' ) - dup [ eliminate-phi-step ] each-basic-block ; \ No newline at end of file diff --git a/basis/compiler/cfg/predecessors/predecessors.factor b/basis/compiler/cfg/predecessors/predecessors.factor index 5be085ba5a..8ab9f316a7 100644 --- a/basis/compiler/cfg/predecessors/predecessors.factor +++ b/basis/compiler/cfg/predecessors/predecessors.factor @@ -1,10 +1,33 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors sequences compiler.cfg.rpo ; +USING: kernel accessors combinators fry sequences assocs compiler.cfg.rpo +compiler.cfg.instructions compiler.cfg.utilities ; IN: compiler.cfg.predecessors -: predecessors-step ( bb -- ) +> [ predecessors>> push ] with each ; +: update-phi ( bb ##phi -- ) + [ + swap predecessors>> + '[ drop _ memq? ] assoc-filter + ] change-inputs drop ; + +: update-phis ( bb -- ) + dup [ update-phi ] with each-phi ; + : compute-predecessors ( cfg -- cfg' ) - dup [ predecessors-step ] each-basic-block ; + { + [ [ V{ } clone >>predecessors drop ] each-basic-block ] + [ [ update-predecessors ] each-basic-block ] + [ [ update-phis ] each-basic-block ] + [ ] + } cleave ; + +PRIVATE> + +: needs-predecessors ( cfg -- cfg' ) + dup predecessors-valid?>> + [ compute-predecessors t >>predecessors-valid? ] unless ; \ No newline at end of file diff --git a/basis/compiler/cfg/registers/registers.factor b/basis/compiler/cfg/registers/registers.factor index 0882bed06e..0d518735af 100644 --- a/basis/compiler/cfg/registers/registers.factor +++ b/basis/compiler/cfg/registers/registers.factor @@ -1,14 +1,39 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors namespaces kernel arrays parser ; +USING: accessors namespaces kernel parser assocs ; IN: compiler.cfg.registers -! Virtual registers, used by CFG and machine IRs -TUPLE: vreg { reg-class read-only } { n read-only } ; +! Virtual registers, used by CFG and machine IRs, are just integers SYMBOL: vreg-counter -: next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ; -! Stack locations +: next-vreg ( -- vreg ) + ! This word cannot be called AFTER representation selection has run; + ! use next-vreg-rep in that case + \ vreg-counter counter ; + +SYMBOL: representations + +ERROR: bad-vreg vreg ; + +: rep-of ( vreg -- rep ) + ! This word cannot be called BEFORE representation selection has run; + ! use any-rep for ##copy instructions and so on + representations get ?at [ bad-vreg ] unless ; + +: set-rep-of ( rep vreg -- ) + representations get set-at ; + +: next-vreg-rep ( rep -- vreg ) + ! This word cannot be called BEFORE representation selection has run; + ! use next-vreg in that case + next-vreg [ set-rep-of ] keep ; + +! Stack locations -- 'n' is an index starting from the top of the stack +! going down. So 0 is the top of the stack, 1 is what would be the top +! of the stack after a 'drop', and so on. + +! ##inc-d and ##inc-r affect locations as follows. Location D 0 before +! an ##inc-d 1 becomes D 1 after ##inc-d 1. TUPLE: loc { n read-only } ; TUPLE: ds-loc < loc ; @@ -17,6 +42,5 @@ C: ds-loc TUPLE: rs-loc < loc ; C: rs-loc -SYNTAX: V scan-word scan-word vreg boa parsed ; SYNTAX: D scan-word parsed ; SYNTAX: R scan-word parsed ; diff --git a/basis/compiler/cfg/renaming/functor/functor.factor b/basis/compiler/cfg/renaming/functor/functor.factor new file mode 100644 index 0000000000..b307155091 --- /dev/null +++ b/basis/compiler/cfg/renaming/functor/functor.factor @@ -0,0 +1,169 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: functors assocs kernel accessors compiler.cfg.instructions +lexer parser ; +IN: compiler.cfg.renaming.functor + +FUNCTOR: define-renaming ( NAME DEF-QUOT USE-QUOT TEMP-QUOT -- ) + +rename-insn-defs DEFINES ${NAME}-insn-defs +rename-insn-uses DEFINES ${NAME}-insn-uses +rename-insn-temps DEFINES ${NAME}-insn-temps + +WHERE + +GENERIC: rename-insn-defs ( insn -- ) + +M: ##flushable rename-insn-defs + DEF-QUOT change-dst + drop ; + +M: ##fixnum-overflow rename-insn-defs + DEF-QUOT change-dst + drop ; + +M: _fixnum-overflow rename-insn-defs + DEF-QUOT change-dst + drop ; + +M: insn rename-insn-defs drop ; + +GENERIC: rename-insn-uses ( insn -- ) + +M: ##effect rename-insn-uses + USE-QUOT change-src + drop ; + +M: ##unary rename-insn-uses + USE-QUOT change-src + drop ; + +M: ##binary rename-insn-uses + USE-QUOT change-src1 + USE-QUOT change-src2 + drop ; + +M: ##binary-imm rename-insn-uses + USE-QUOT change-src1 + drop ; + +M: ##slot rename-insn-uses + USE-QUOT change-obj + USE-QUOT change-slot + drop ; + +M: ##slot-imm rename-insn-uses + USE-QUOT change-obj + drop ; + +M: ##set-slot rename-insn-uses + dup call-next-method + USE-QUOT change-obj + USE-QUOT change-slot + drop ; + +M: ##string-nth rename-insn-uses + USE-QUOT change-obj + USE-QUOT change-index + drop ; + +M: ##set-string-nth-fast rename-insn-uses + dup call-next-method + USE-QUOT change-obj + USE-QUOT change-index + drop ; + +M: ##set-slot-imm rename-insn-uses + dup call-next-method + USE-QUOT change-obj + drop ; + +M: ##alien-getter rename-insn-uses + dup call-next-method + USE-QUOT change-src + drop ; + +M: ##alien-setter rename-insn-uses + dup call-next-method + USE-QUOT change-value + drop ; + +M: ##conditional-branch rename-insn-uses + USE-QUOT change-src1 + USE-QUOT change-src2 + drop ; + +M: ##compare-imm-branch rename-insn-uses + USE-QUOT change-src1 + drop ; + +M: ##dispatch rename-insn-uses + USE-QUOT change-src + drop ; + +M: ##fixnum-overflow rename-insn-uses + USE-QUOT change-src1 + USE-QUOT change-src2 + drop ; + +M: ##phi rename-insn-uses + [ USE-QUOT assoc-map ] change-inputs + drop ; + +M: insn rename-insn-uses drop ; + +GENERIC: rename-insn-temps ( insn -- ) + +M: ##write-barrier rename-insn-temps + TEMP-QUOT change-card# + TEMP-QUOT change-table + drop ; + +M: ##unary/temp rename-insn-temps + TEMP-QUOT change-temp drop ; + +M: ##allot rename-insn-temps + TEMP-QUOT change-temp drop ; + +M: ##dispatch rename-insn-temps + TEMP-QUOT change-temp drop ; + +M: ##slot rename-insn-temps + TEMP-QUOT change-temp drop ; + +M: ##set-slot rename-insn-temps + TEMP-QUOT change-temp drop ; + +M: ##string-nth rename-insn-temps + TEMP-QUOT change-temp drop ; + +M: ##set-string-nth-fast rename-insn-temps + TEMP-QUOT change-temp drop ; + +M: ##box-displaced-alien rename-insn-temps + TEMP-QUOT change-temp1 + TEMP-QUOT change-temp2 + drop ; + +M: ##compare rename-insn-temps + TEMP-QUOT change-temp drop ; + +M: ##compare-imm rename-insn-temps + TEMP-QUOT change-temp drop ; + +M: ##compare-float rename-insn-temps + TEMP-QUOT change-temp drop ; + +M: ##gc rename-insn-temps + TEMP-QUOT change-temp1 + TEMP-QUOT change-temp2 + drop ; + +M: _dispatch rename-insn-temps + TEMP-QUOT change-temp drop ; + +M: insn rename-insn-temps drop ; + +;FUNCTOR + +SYNTAX: RENAMING: scan scan-object scan-object scan-object define-renaming ; \ No newline at end of file diff --git a/basis/compiler/cfg/renaming/renaming.factor b/basis/compiler/cfg/renaming/renaming.factor new file mode 100644 index 0000000000..92a6954786 --- /dev/null +++ b/basis/compiler/cfg/renaming/renaming.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs kernel namespaces sequences +compiler.cfg.instructions compiler.cfg.registers +compiler.cfg.renaming.functor ; +IN: compiler.cfg.renaming + +SYMBOL: renamings + +: rename-value ( vreg -- vreg' ) + renamings get ?at drop ; + +RENAMING: rename [ rename-value ] [ rename-value ] [ drop next-vreg ] diff --git a/basis/compiler/cfg/representations/preferred/preferred.factor b/basis/compiler/cfg/representations/preferred/preferred.factor new file mode 100644 index 0000000000..4b071ba5e2 --- /dev/null +++ b/basis/compiler/cfg/representations/preferred/preferred.factor @@ -0,0 +1,84 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors sequences arrays fry namespaces +cpu.architecture compiler.cfg.utilities compiler.cfg compiler.cfg.rpo +compiler.cfg.instructions compiler.cfg.def-use ; +IN: compiler.cfg.representations.preferred + +GENERIC: defs-vreg-rep ( insn -- rep/f ) +GENERIC: temp-vreg-reps ( insn -- reps ) +GENERIC: uses-vreg-reps ( insn -- reps ) + +M: ##flushable defs-vreg-rep drop int-rep ; +M: ##copy defs-vreg-rep rep>> ; +M: output-float-insn defs-vreg-rep drop double-float-rep ; +M: ##fixnum-overflow defs-vreg-rep drop int-rep ; +M: _fixnum-overflow defs-vreg-rep drop int-rep ; +M: ##phi defs-vreg-rep drop "##phi must be special-cased" throw ; +M: insn defs-vreg-rep drop f ; + +M: ##write-barrier temp-vreg-reps drop { int-rep int-rep } ; +M: ##unary/temp temp-vreg-reps drop { int-rep } ; +M: ##allot temp-vreg-reps drop { int-rep } ; +M: ##dispatch temp-vreg-reps drop { int-rep } ; +M: ##slot temp-vreg-reps drop { int-rep } ; +M: ##set-slot temp-vreg-reps drop { int-rep } ; +M: ##string-nth temp-vreg-reps drop { int-rep } ; +M: ##set-string-nth-fast temp-vreg-reps drop { int-rep } ; +M: ##box-displaced-alien temp-vreg-reps drop { int-rep int-rep } ; +M: ##compare temp-vreg-reps drop { int-rep } ; +M: ##compare-imm temp-vreg-reps drop { int-rep } ; +M: ##compare-float temp-vreg-reps drop { int-rep } ; +M: ##gc temp-vreg-reps drop { int-rep int-rep } ; +M: _dispatch temp-vreg-reps drop { int-rep } ; +M: insn temp-vreg-reps drop f ; + +M: ##copy uses-vreg-reps rep>> 1array ; +M: ##unary uses-vreg-reps drop { int-rep } ; +M: ##unary-float uses-vreg-reps drop { double-float-rep } ; +M: ##binary uses-vreg-reps drop { int-rep int-rep } ; +M: ##binary-imm uses-vreg-reps drop { int-rep } ; +M: ##binary-float uses-vreg-reps drop { double-float-rep double-float-rep } ; +M: ##effect uses-vreg-reps drop { int-rep } ; +M: ##slot uses-vreg-reps drop { int-rep int-rep } ; +M: ##slot-imm uses-vreg-reps drop { int-rep } ; +M: ##set-slot uses-vreg-reps drop { int-rep int-rep int-rep } ; +M: ##set-slot-imm uses-vreg-reps drop { int-rep int-rep } ; +M: ##string-nth uses-vreg-reps drop { int-rep int-rep } ; +M: ##set-string-nth-fast uses-vreg-reps drop { int-rep int-rep int-rep } ; +M: ##compare-branch uses-vreg-reps drop { int-rep int-rep } ; +M: ##compare-imm-branch uses-vreg-reps drop { int-rep } ; +M: ##compare-float-branch uses-vreg-reps drop { double-float-rep double-float-rep } ; +M: ##dispatch uses-vreg-reps drop { int-rep } ; +M: ##alien-getter uses-vreg-reps drop { int-rep } ; +M: ##alien-setter uses-vreg-reps drop { int-rep int-rep } ; +M: ##set-alien-float uses-vreg-reps drop { int-rep double-float-rep } ; +M: ##set-alien-double uses-vreg-reps drop { int-rep double-float-rep } ; +M: ##fixnum-overflow uses-vreg-reps drop { int-rep int-rep } ; +M: _compare-imm-branch uses-vreg-reps drop { int-rep } ; +M: _compare-branch uses-vreg-reps drop { int-rep int-rep } ; +M: _compare-float-branch uses-vreg-reps drop { double-float-rep double-float-rep } ; +M: _dispatch uses-vreg-reps drop { int-rep } ; +M: ##phi uses-vreg-reps drop "##phi must be special-cased" throw ; +M: insn uses-vreg-reps drop f ; + +: each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- ) + [ [ defs-vreg ] [ defs-vreg-rep ] bi ] dip with when* ; inline + +: each-use-rep ( insn vreg-quot: ( vreg rep -- ) -- ) + [ [ uses-vregs ] [ uses-vreg-reps ] bi ] dip 2each ; inline + +: each-temp-rep ( insn vreg-quot: ( vreg rep -- ) -- ) + [ [ temp-vregs ] [ temp-vreg-reps ] bi ] dip 2each ; inline + +: with-vreg-reps ( cfg vreg-quot: ( vreg rep -- ) -- ) + '[ + [ basic-block set ] [ + [ + _ + [ each-def-rep ] + [ each-use-rep ] + [ each-temp-rep ] 2tri + ] each-non-phi + ] bi + ] each-basic-block ; inline diff --git a/basis/compiler/cfg/representations/representations-tests.factor b/basis/compiler/cfg/representations/representations-tests.factor new file mode 100644 index 0000000000..29f0fa064f --- /dev/null +++ b/basis/compiler/cfg/representations/representations-tests.factor @@ -0,0 +1,19 @@ +USING: tools.test cpu.architecture +compiler.cfg.registers compiler.cfg.instructions +compiler.cfg.representations.preferred ; +IN: compiler.cfg.representations + +[ { double-float-rep double-float-rep } ] [ + T{ ##add-float + { dst 5 } + { src1 3 } + { src2 4 } + } uses-vreg-reps +] unit-test + +[ double-float-rep ] [ + T{ ##alien-double + { dst 5 } + { src 3 } + } defs-vreg-rep +] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/representations/representations.factor b/basis/compiler/cfg/representations/representations.factor new file mode 100644 index 0000000000..cb98eb0ae5 --- /dev/null +++ b/basis/compiler/cfg/representations/representations.factor @@ -0,0 +1,229 @@ +! Copyright (C) 2009 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: kernel fry accessors sequences assocs sets namespaces +arrays combinators make locals deques dlists +cpu.architecture compiler.utilities +compiler.cfg +compiler.cfg.rpo +compiler.cfg.registers +compiler.cfg.instructions +compiler.cfg.def-use +compiler.cfg.utilities +compiler.cfg.loop-detection +compiler.cfg.renaming.functor +compiler.cfg.representations.preferred ; +IN: compiler.cfg.representations + +! Virtual register representation selection. + +: emit-conversion ( dst src dst-rep src-rep -- ) + 2array { + { { int-rep int-rep } [ int-rep ##copy ] } + { { double-float-rep double-float-rep } [ double-float-rep ##copy ] } + { { double-float-rep int-rep } [ ##unbox-float ] } + { { int-rep double-float-rep } [ int-rep next-vreg-rep ##box-float ] } + } case ; + +assoc ] assoc-map costs set ; + +: increase-cost ( rep vreg -- ) + ! Increase cost of keeping vreg in rep, making a choice of rep less + ! likely. + [ basic-block get loop-nesting-at ] 2dip costs get at at+ ; + +: maybe-increase-cost ( possible vreg preferred -- ) + pick eq? [ 2drop ] [ increase-cost ] if ; + +: representation-cost ( vreg preferred -- ) + ! 'preferred' is a representation that the instruction can accept with no cost. + ! So, for each representation that's not preferred, increase the cost of keeping + ! the vreg in that representation. + [ drop possible ] + [ '[ _ _ maybe-increase-cost ] ] + 2bi each ; + +: compute-costs ( cfg -- costs ) + init-costs [ representation-cost ] with-vreg-reps costs get ; + +! For every vreg, compute preferred representation, that minimizes costs. +: minimize-costs ( costs -- representations ) + [ >alist alist-min first ] assoc-map ; + +: compute-representations ( cfg -- ) + [ compute-costs minimize-costs ] + [ compute-always-boxed ] + bi assoc-union + representations set ; + +! Insert conversions. This introduces new temporaries, so we need +! to rename opearands too. + +:: emit-def-conversion ( dst preferred required -- new-dst' ) + ! If an instruction defines a register with representation 'required', + ! but the register has preferred representation 'preferred', then + ! we rename the instruction's definition to a new register, which + ! becomes the input of a conversion instruction. + dst required next-vreg-rep [ preferred required emit-conversion ] keep ; + +:: emit-use-conversion ( src preferred required -- new-src' ) + ! If an instruction uses a register with representation 'required', + ! but the register has preferred representation 'preferred', then + ! we rename the instruction's input to a new register, which + ! becomes the output of a conversion instruction. + required next-vreg-rep [ src required preferred emit-conversion ] keep ; + +SYMBOLS: renaming-set needs-renaming? ; + +: init-renaming-set ( -- ) + needs-renaming? off + V{ } clone renaming-set set ; + +: no-renaming ( vreg -- ) + dup 2array renaming-set get push ; + +: record-renaming ( from to -- ) + 2array renaming-set get push needs-renaming? on ; + +:: (compute-renaming-set) ( vreg required quot: ( vreg preferred required -- ) -- ) + vreg rep-of :> preferred + preferred required eq? + [ vreg no-renaming ] + [ vreg vreg preferred required quot call record-renaming ] if ; inline + +: compute-renaming-set ( insn -- ) + ! temp vregs don't need conversions since they're always in their + ! preferred representation + init-renaming-set + [ [ [ emit-use-conversion ] (compute-renaming-set) ] each-use-rep ] + [ , ] + [ [ [ emit-def-conversion ] (compute-renaming-set) ] each-def-rep ] + tri ; + +: converted-value ( vreg -- vreg' ) + renaming-set get pop first2 [ assert= ] dip ; + +RENAMING: convert [ converted-value ] [ converted-value ] [ ] + +: perform-renaming ( insn -- ) + needs-renaming? get [ + renaming-set get reverse-here + [ convert-insn-uses ] [ convert-insn-defs ] bi + renaming-set get length 0 assert= + ] [ drop ] if ; + +GENERIC: conversions-for-insn ( insn -- ) + +SYMBOL: phi-mappings + +! compiler.cfg.cssa inserts conversions which convert phi inputs into +! the representation of the output. However, we still have to do some +! processing here, because if the only node that uses the output of +! the phi instruction is another phi instruction then this phi node's +! output won't have a representation assigned. +M: ##phi conversions-for-insn + [ , ] [ [ inputs>> values ] [ dst>> ] bi phi-mappings get set-at ] bi ; + +M: vreg-insn conversions-for-insn + [ compute-renaming-set ] [ perform-renaming ] bi ; + +M: insn conversions-for-insn , ; + +: conversions-for-block ( bb -- ) + dup kill-block? [ drop ] [ + [ + [ + [ conversions-for-insn ] each + ] V{ } make + ] change-instructions drop + ] if ; + +! If the output of a phi instruction is only used as the input to another +! phi instruction, then we want to use the same representation for both +! if possible. +SYMBOL: work-list + +: add-to-work-list ( vregs -- ) + work-list get push-all-front ; + +: rep-assigned ( vregs -- vregs' ) + representations get '[ _ key? ] filter ; + +: rep-not-assigned ( vregs -- vregs' ) + representations get '[ _ key? not ] filter ; + +: add-ready-phis ( -- ) + phi-mappings get keys rep-assigned add-to-work-list ; + +: process-phi-mapping ( dst -- ) + ! If dst = phi(src1,src2,...) and dst's representation has been + ! determined, assign that representation to each one of src1,... + ! that does not have a representation yet, and process those, too. + dup phi-mappings get at* [ + [ rep-of ] [ rep-not-assigned ] bi* + [ [ set-rep-of ] with each ] [ add-to-work-list ] bi + ] [ 2drop ] if ; + +: remaining-phi-mappings ( -- ) + phi-mappings get keys rep-not-assigned + [ [ int-rep ] dip set-rep-of ] each ; + +: process-phi-mappings ( -- ) + work-list set + add-ready-phis + work-list get [ process-phi-mapping ] slurp-deque + remaining-phi-mappings ; + +: insert-conversions ( cfg -- ) + H{ } clone phi-mappings set + [ conversions-for-block ] each-basic-block + process-phi-mappings ; + +PRIVATE> + +: select-representations ( cfg -- cfg' ) + needs-loops + + { + [ compute-possibilities ] + [ compute-representations ] + [ insert-conversions ] + [ ] + } cleave + representations get cfg get (>>reps) ; \ No newline at end of file diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor index f6a40e17d0..b6322730ee 100644 --- a/basis/compiler/cfg/rpo/rpo.factor +++ b/basis/compiler/cfg/rpo/rpo.factor @@ -33,3 +33,13 @@ SYMBOL: visited : each-basic-block ( cfg quot -- ) [ reverse-post-order ] dip each ; inline + +: optimize-basic-block ( bb quot -- ) + [ drop basic-block set ] + [ change-instructions drop ] 2bi ; inline + +: local-optimization ( cfg quot: ( insns -- insns' ) -- cfg' ) + dupd '[ _ optimize-basic-block ] each-basic-block ; inline + +: needs-post-order ( cfg -- cfg' ) + dup post-order drop ; \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/construction/construction-tests.factor b/basis/compiler/cfg/ssa/construction/construction-tests.factor new file mode 100644 index 0000000000..3d743176b1 --- /dev/null +++ b/basis/compiler/cfg/ssa/construction/construction-tests.factor @@ -0,0 +1,113 @@ +USING: accessors compiler.cfg compiler.cfg.debugger +compiler.cfg.dominance compiler.cfg.instructions +compiler.cfg.predecessors compiler.cfg.ssa.construction assocs +compiler.cfg.registers cpu.architecture kernel namespaces sequences +tools.test vectors ; +IN: compiler.cfg.ssa.construction.tests + +: reset-counters ( -- ) + ! Reset counters so that results are deterministic w.r.t. hash order + 0 vreg-counter set-global + 0 basic-block set-global ; + +reset-counters + +V{ + T{ ##load-immediate 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{ ##branch } +} 1 test-bb + +V{ + T{ ##load-immediate f 3 4 } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##replace f 3 D 0 } + T{ ##return } +} 3 test-bb + +0 { 1 2 } edges +1 3 edge +2 3 edge + +: test-ssa ( -- ) + cfg new 0 get >>entry + dup cfg set + construct-ssa + drop ; + +[ ] [ test-ssa ] unit-test + +[ + V{ + T{ ##load-immediate f 1 100 } + T{ ##add-imm f 2 1 50 } + T{ ##add-imm f 3 2 10 } + T{ ##branch } + } +] [ 0 get instructions>> ] unit-test + +[ + V{ + T{ ##load-immediate f 4 3 } + T{ ##branch } + } +] [ 1 get instructions>> ] unit-test + +[ + V{ + T{ ##load-immediate f 5 4 } + T{ ##branch } + } +] [ 2 get instructions>> ] unit-test + +: clean-up-phis ( insns -- insns' ) + [ dup ##phi? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map ; + +[ + V{ + T{ ##phi f 6 H{ { 1 4 } { 2 5 } } } + T{ ##replace f 6 D 0 } + T{ ##return } + } +] [ + 3 get instructions>> + clean-up-phis +] unit-test + +reset-counters + +V{ } 0 test-bb +V{ } 1 test-bb +V{ T{ ##peek f 0 D 0 } } 2 test-bb +V{ T{ ##peek f 0 D 0 } } 3 test-bb +V{ T{ ##replace f 0 D 0 } } 4 test-bb +V{ } 5 test-bb +V{ } 6 test-bb + +0 { 1 5 } edges +1 { 2 3 } edges +2 4 edge +3 4 edge +4 6 edge +5 6 edge + +[ ] [ test-ssa ] unit-test + +[ + V{ + T{ ##phi f 3 H{ { 2 1 } { 3 2 } } } + T{ ##replace f 3 D 0 } + } +] [ + 4 get instructions>> + clean-up-phis +] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/construction/construction.factor b/basis/compiler/cfg/ssa/construction/construction.factor new file mode 100644 index 0000000000..7662b8ab01 --- /dev/null +++ b/basis/compiler/cfg/ssa/construction/construction.factor @@ -0,0 +1,138 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces kernel accessors sequences fry assocs +sets math combinators +compiler.cfg +compiler.cfg.rpo +compiler.cfg.def-use +compiler.cfg.liveness +compiler.cfg.registers +compiler.cfg.dominance +compiler.cfg.instructions +compiler.cfg.renaming +compiler.cfg.renaming.functor +compiler.cfg.ssa.construction.tdmsc ; +IN: compiler.cfg.ssa.construction + +! The phi placement algorithm is implemented in +! compiler.cfg.ssa.construction.tdmsc. + +! The renaming algorithm is based on "Practical Improvements to +! the Construction and Destruction of Static Single Assignment Form", +! however we construct pruned SSA, not semi-pruned SSA. + +! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.49.9683 + + ] 2tri + [ defs-multi get conjoin ] [ drop ] if + ] [ 2drop ] if ; + +: compute-defs ( cfg -- ) + H{ } clone defs set + H{ } clone defs-multi set + [ + dup instructions>> [ + compute-insn-defs + ] with each + ] each-basic-block ; + +! Maps basic blocks to sequences of vregs +SYMBOL: inserting-phi-nodes + +: insert-phi-node-later ( vreg bb -- ) + 2dup live-in key? [ + [ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep + inserting-phi-nodes get push-at + ] [ 2drop ] if ; + +: compute-phi-nodes-for ( vreg bbs -- ) + keys [ insert-phi-node-later ] with merge-set-each ; + +: compute-phi-nodes ( -- ) + H{ } clone inserting-phi-nodes set + defs-multi get defs get '[ _ at compute-phi-nodes-for ] assoc-each ; + +: insert-phi-nodes-in ( phis bb -- ) + [ append ] change-instructions drop ; + +: insert-phi-nodes ( -- ) + inserting-phi-nodes get [ swap insert-phi-nodes-in ] assoc-each ; + +SYMBOLS: stacks pushed ; + +: init-renaming ( -- ) + H{ } clone stacks set ; + +: gen-name ( vreg -- vreg' ) + [ next-vreg dup ] dip + dup pushed get 2dup key? + [ 2drop stacks get at set-last ] + [ conjoin stacks get push-at ] + if ; + +: top-name ( vreg -- vreg' ) + stacks get at last ; + +RENAMING: ssa-rename [ gen-name ] [ top-name ] [ ] + +GENERIC: rename-insn ( insn -- ) + +M: insn rename-insn + [ ssa-rename-insn-uses ] + [ ssa-rename-insn-defs ] + bi ; + +M: ##phi rename-insn + ssa-rename-insn-defs ; + +: rename-insns ( bb -- ) + instructions>> [ rename-insn ] each ; + +: rename-successor-phi ( phi bb -- ) + swap inputs>> [ top-name ] change-at ; + +: rename-successor-phis ( succ bb -- ) + [ inserting-phi-nodes get at ] dip + '[ _ rename-successor-phi ] each ; + +: rename-successors-phis ( bb -- ) + [ successors>> ] keep '[ _ rename-successor-phis ] each ; + +: pop-stacks ( -- ) + pushed get stacks get '[ drop _ at pop* ] assoc-each ; + +: rename-in-block ( bb -- ) + H{ } clone pushed set + [ rename-insns ] + [ rename-successors-phis ] + [ + pushed get + [ dom-children [ rename-in-block ] each ] dip + pushed set + ] tri + pop-stacks ; + +: rename ( cfg -- ) + init-renaming + entry>> rename-in-block ; + +PRIVATE> + +: construct-ssa ( cfg -- cfg' ) + { + [ compute-live-sets ] + [ compute-merge-sets ] + [ compute-defs compute-phi-nodes insert-phi-nodes ] + [ rename ] + [ ] + } cleave ; \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc-tests.factor b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc-tests.factor new file mode 100644 index 0000000000..955d41814f --- /dev/null +++ b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc-tests.factor @@ -0,0 +1,73 @@ +USING: accessors arrays compiler.cfg compiler.cfg.debugger +compiler.cfg.dominance compiler.cfg.predecessors +compiler.cfg.ssa.construction.tdmsc kernel namespaces sequences +tools.test vectors sets ; +IN: compiler.cfg.ssa.construction.tdmsc.tests + +: test-tdmsc ( -- ) + cfg new 0 get >>entry dup cfg set + compute-merge-sets ; + +V{ } 0 test-bb +V{ } 1 test-bb +V{ } 2 test-bb +V{ } 3 test-bb +V{ } 4 test-bb +V{ } 5 test-bb + +0 { 1 2 } edges +1 3 edge +2 4 edge +3 4 edge +4 5 edge + +[ ] [ test-tdmsc ] unit-test + +[ V{ 4 } ] [ 1 get 1array merge-set [ number>> ] map ] unit-test +[ V{ 4 } ] [ 2 get 1array merge-set [ number>> ] map ] unit-test +[ V{ } ] [ 0 get 1array merge-set ] unit-test +[ V{ } ] [ 4 get 1array merge-set ] unit-test + +V{ } 0 test-bb +V{ } 1 test-bb +V{ } 2 test-bb +V{ } 3 test-bb +V{ } 4 test-bb +V{ } 5 test-bb +V{ } 6 test-bb + +0 { 1 5 } edges +1 { 2 3 } edges +2 4 edge +3 4 edge +4 6 edge +5 6 edge + +[ ] [ test-tdmsc ] unit-test + +[ t ] [ + 2 get 3 get 2array merge-set + 4 get 6 get 2array set= +] unit-test + +V{ } 0 test-bb +V{ } 1 test-bb +V{ } 2 test-bb +V{ } 3 test-bb +V{ } 4 test-bb +V{ } 5 test-bb +V{ } 6 test-bb +V{ } 7 test-bb + +0 1 edge +1 2 edge +2 { 3 6 } edges +3 4 edge +6 7 edge +4 5 edge +5 2 edge + +[ ] [ test-tdmsc ] unit-test + +[ V{ 2 } ] [ { 2 3 4 5 } [ get ] map merge-set [ number>> ] map ] unit-test +[ V{ } ] [ { 0 1 6 7 } [ get ] map merge-set ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor new file mode 100644 index 0000000000..647c97d6c3 --- /dev/null +++ b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor @@ -0,0 +1,110 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs bit-arrays bit-sets fry +hashtables hints kernel locals math namespaces sequences sets +compiler.cfg compiler.cfg.dominance compiler.cfg.rpo ; +IN: compiler.cfg.ssa.construction.tdmsc + +! TDMSC-I algorithm from "A Practical and Fast Iterative Algorithm for +! Phi-Function Computation Using DJ Graphs" + +! http://portal.acm.org/citation.cfm?id=1065887.1065890 + + ] H{ } map>assoc merge-sets set ; + +: compute-levels ( cfg -- ) + 0 over entry>> associate [ + '[ + _ [ [ dom-parent ] dip at 1 + ] 2keep set-at + ] each-basic-block + ] keep levels set ; + +: j-edge? ( from to -- ? ) + 2dup eq? [ 2drop f ] [ dominates? not ] if ; + +: level ( bb -- n ) levels get at ; inline + +: set-bit ( bit-array n -- ) + [ t ] 2dip swap set-nth ; + +: update-merge-set ( tmp to -- ) + [ merge-sets get ] dip + '[ + _ + [ merge-sets get at bit-set-union ] + [ dupd number>> set-bit ] + bi + ] change-at ; + +:: walk ( tmp to lnode -- lnode ) + tmp level to level >= [ + tmp to update-merge-set + tmp dom-parent to tmp walk + ] [ lnode ] if ; + +: each-incoming-j-edge ( bb quot: ( from to -- ) -- ) + [ [ predecessors>> ] keep ] dip + '[ _ 2dup j-edge? _ [ 2drop ] if ] each ; inline + +: visited? ( pair -- ? ) visited get key? ; + +: consistent? ( snode lnode -- ? ) + [ merge-sets get at ] bi@ swap bit-set-subset? ; + +: (process-edge) ( from to -- ) + f walk [ + 2dup 2array visited? [ + consistent? [ again? on ] unless + ] [ 2drop ] if + ] each-incoming-j-edge ; + +: process-edge ( from to -- ) + 2dup 2array dup visited? [ 3drop ] [ + visited get conjoin + (process-edge) + ] if ; + +: process-block ( bb -- ) + [ process-edge ] each-incoming-j-edge ; + +: compute-merge-set-step ( bfo -- ) + visited get clear-assoc + [ process-block ] each ; + +: compute-merge-set-loop ( cfg -- ) + breadth-first-order + '[ again? off _ compute-merge-set-step again? get ] + loop ; + +: (merge-set) ( bbs -- flags rpo ) + merge-sets get '[ _ at ] [ bit-set-union ] map-reduce + cfg get reverse-post-order ; inline + +: filter-by ( flags seq -- seq' ) + [ drop ] pusher [ 2each ] dip ; + +HINTS: filter-by { bit-array object } ; + +PRIVATE> + +: compute-merge-sets ( cfg -- ) + needs-dominance + + H{ } clone visited set + [ compute-levels ] + [ init-merge-sets ] + [ compute-merge-set-loop ] + tri ; + +: merge-set-each ( bbs quot: ( bb -- ) -- ) + [ (merge-set) ] dip '[ + swap _ [ drop ] if + ] 2each ; inline + +: merge-set ( bbs -- bbs' ) + (merge-set) filter-by ; \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/cssa/cssa.factor b/basis/compiler/cfg/ssa/cssa/cssa.factor new file mode 100644 index 0000000000..14287e900f --- /dev/null +++ b/basis/compiler/cfg/ssa/cssa/cssa.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs kernel locals fry +cpu.architecture +compiler.cfg.rpo +compiler.cfg.utilities +compiler.cfg.registers +compiler.cfg.instructions +compiler.cfg.representations ; +IN: compiler.cfg.ssa.cssa + +! Convert SSA to conventional SSA. This pass runs after representation +! selection, so it must keep track of representations when introducing +! new values. + +:: insert-copy ( bb src rep -- bb dst ) + rep next-vreg-rep :> dst + bb [ dst src rep src rep-of emit-conversion ] add-instructions + bb dst ; + +: convert-phi ( ##phi -- ) + dup dst>> rep-of '[ [ _ insert-copy ] assoc-map ] change-inputs drop ; + +: construct-cssa ( cfg -- ) + [ [ convert-phi ] each-phi ] each-basic-block ; \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/destruction/destruction.factor b/basis/compiler/cfg/ssa/destruction/destruction.factor new file mode 100644 index 0000000000..424be91e2b --- /dev/null +++ b/basis/compiler/cfg/ssa/destruction/destruction.factor @@ -0,0 +1,108 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs fry kernel namespaces +sequences sequences.deep +sets vectors +compiler.cfg.rpo +compiler.cfg.def-use +compiler.cfg.renaming +compiler.cfg.dominance +compiler.cfg.instructions +compiler.cfg.liveness.ssa +compiler.cfg.ssa.cssa +compiler.cfg.ssa.interference +compiler.cfg.ssa.interference.live-ranges +compiler.cfg.utilities +compiler.utilities ; +IN: compiler.cfg.ssa.destruction + +! Maps vregs to leaders. +SYMBOL: leader-map + +: leader ( vreg -- vreg' ) leader-map get compress-path ; + +! Maps leaders to equivalence class elements. +SYMBOL: class-element-map + +: class-elements ( vreg -- elts ) class-element-map get at ; + +! Sequence of vreg pairs +SYMBOL: copies + +: init-coalescing ( -- ) + H{ } clone leader-map set + H{ } clone class-element-map set + V{ } clone copies set ; + +: classes-interfere? ( vreg1 vreg2 -- ? ) + [ leader ] bi@ 2dup eq? [ 2drop f ] [ + [ class-elements flatten ] bi@ sets-interfere? + ] if ; + +: update-leaders ( vreg1 vreg2 -- ) + swap leader-map get set-at ; + +: merge-classes ( vreg1 vreg2 -- ) + [ [ class-elements ] bi@ push ] + [ drop class-element-map get delete-at ] 2bi ; + +: eliminate-copy ( vreg1 vreg2 -- ) + [ leader ] bi@ + 2dup eq? [ 2drop ] [ + [ update-leaders ] + [ merge-classes ] + 2bi + ] if ; + +: introduce-vreg ( vreg -- ) + [ leader-map get conjoin ] + [ [ 1vector ] keep class-element-map get set-at ] bi ; + +GENERIC: prepare-insn ( insn -- ) + +M: ##copy prepare-insn + [ dst>> ] [ src>> ] bi 2array copies get push ; + +M: ##phi prepare-insn + [ dst>> ] [ inputs>> values ] bi + [ eliminate-copy ] with each ; + +M: insn prepare-insn drop ; + +: prepare-block ( bb -- ) + instructions>> [ prepare-insn ] each ; + +: prepare-coalescing ( cfg -- ) + init-coalescing + defs get keys [ introduce-vreg ] each + [ prepare-block ] each-basic-block ; + +: process-copies ( -- ) + copies get [ + 2dup classes-interfere? + [ 2drop ] [ eliminate-copy ] if + ] assoc-each ; + +: useless-copy? ( ##copy -- ? ) + dup ##copy? [ [ dst>> ] [ src>> ] bi eq? ] [ drop f ] if ; + +: 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-here + ] each-basic-block ; + +: destruct-ssa ( cfg -- cfg' ) + needs-dominance + + dup construct-cssa + dup compute-defs + compute-ssa-live-sets + dup compute-live-ranges + dup prepare-coalescing + process-copies + dup perform-renaming ; \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/interference/interference-tests.factor b/basis/compiler/cfg/ssa/interference/interference-tests.factor new file mode 100644 index 0000000000..2f13331024 --- /dev/null +++ b/basis/compiler/cfg/ssa/interference/interference-tests.factor @@ -0,0 +1,50 @@ +USING: accessors compiler.cfg compiler.cfg.debugger +compiler.cfg.def-use compiler.cfg.dominance +compiler.cfg.instructions compiler.cfg.liveness.ssa +compiler.cfg.registers compiler.cfg.predecessors +compiler.cfg.ssa.interference +compiler.cfg.ssa.interference.live-ranges cpu.architecture +kernel namespaces tools.test ; +IN: compiler.cfg.ssa.interference.tests + +: test-interference ( -- ) + cfg new 0 get >>entry + compute-ssa-live-sets + dup compute-defs + compute-live-ranges ; + +V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 2 D 0 } + T{ ##copy f 1 0 } + T{ ##copy f 3 2 } + T{ ##branch } +} 0 test-bb + +V{ + T{ ##peek f 4 D 0 } + T{ ##peek f 5 D 0 } + T{ ##replace f 3 D 0 } + T{ ##peek f 6 D 0 } + T{ ##replace f 5 D 0 } + T{ ##return } +} 1 test-bb + +0 1 edge + +[ ] [ test-interference ] unit-test + +[ f ] [ 0 1 vregs-interfere? ] unit-test +[ f ] [ 1 0 vregs-interfere? ] unit-test +[ f ] [ 2 3 vregs-interfere? ] unit-test +[ f ] [ 3 2 vregs-interfere? ] unit-test +[ t ] [ 0 2 vregs-interfere? ] unit-test +[ t ] [ 2 0 vregs-interfere? ] unit-test +[ f ] [ 1 3 vregs-interfere? ] unit-test +[ f ] [ 3 1 vregs-interfere? ] unit-test +[ t ] [ 3 4 vregs-interfere? ] unit-test +[ t ] [ 4 3 vregs-interfere? ] unit-test +[ t ] [ 3 5 vregs-interfere? ] unit-test +[ t ] [ 5 3 vregs-interfere? ] unit-test +[ f ] [ 3 6 vregs-interfere? ] unit-test +[ f ] [ 6 3 vregs-interfere? ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/interference/interference.factor b/basis/compiler/cfg/ssa/interference/interference.factor new file mode 100644 index 0000000000..a76b55cd83 --- /dev/null +++ b/basis/compiler/cfg/ssa/interference/interference.factor @@ -0,0 +1,92 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs combinators combinators.short-circuit fry +kernel math math.order sorting namespaces sequences locals +compiler.cfg.def-use compiler.cfg.dominance +compiler.cfg.ssa.interference.live-ranges ; +IN: compiler.cfg.ssa.interference + +! Interference testing using SSA properties. Actually the only SSA property +! used here is that definitions dominate uses; because of this, the input +! is allowed to have multiple definitions of each vreg as long as they're +! all in the same basic block. This is needed because two-operand conversion +! runs before coalescing, which uses SSA interference testing. + ; + +:: interferes-same-block? ( vreg1 vreg2 bb1 bb2 -- ? ) + ! If both are defined in the same basic block, they interfere if their + ! local live ranges intersect. + vreg1 bb1 def-index + vreg2 bb1 def-index < + [ vreg1 vreg2 ] [ vreg2 vreg1 ] if + bb1 kill-after-def? ; + +: interferes-first-dominates? ( vreg1 vreg2 bb1 bb2 -- ? ) + ! If vreg1 dominates vreg2, then they interfere if vreg2's definition + ! occurs before vreg1 is killed. + nip + kill-after-def? ; + +: interferes-second-dominates? ( vreg1 vreg2 bb1 bb2 -- ? ) + ! If vreg2 dominates vreg1, then they interfere if vreg1's definition + ! occurs before vreg2 is killed. + drop + swapd kill-after-def? ; + +PRIVATE> + +: vregs-interfere? ( vreg1 vreg2 -- ? ) + 2dup [ def-of ] bi@ { + { [ 2dup eq? ] [ interferes-same-block? ] } + { [ 2dup dominates? ] [ interferes-first-dominates? ] } + { [ 2dup swap dominates? ] [ interferes-second-dominates? ] } + [ 2drop 2drop f ] + } cond ; + +assoc + [ second pre-of ] sort-with ; + +: ?last ( seq -- elt/f ) [ f ] [ last ] if-empty ; inline + +: find-parent ( dom current -- parent ) + over empty? [ 2drop f ] [ + over last over dominates? [ drop last ] [ + over pop* find-parent + ] if + ] if ; + +:: linear-test ( seq1 seq2 -- ? ) + ! Instead of sorting, SSA destruction should keep equivalence + ! classes sorted by merging them on append + V{ } clone :> dom + seq1 seq2 append sort-vregs-by-bb [| pair | + pair first :> current + dom current find-parent + dup [ current vregs-interfere? ] when + [ t ] [ current dom push f ] if + ] any? ; + +PRIVATE> + +: sets-interfere? ( seq1 seq2 -- ? ) + quadratic-test ; \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor b/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor new file mode 100644 index 0000000000..fd1f09a900 --- /dev/null +++ b/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor @@ -0,0 +1,67 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs fry kernel namespaces sequences math +arrays compiler.cfg.def-use compiler.cfg.instructions +compiler.cfg.liveness.ssa compiler.cfg.rpo compiler.cfg.dominance ; +IN: compiler.cfg.ssa.interference.live-ranges + +! Live ranges for interference testing + +> [ visit-insn ] each-index ] + [ [ local-def-indices get ] dip def-indices get set-at ] + [ [ local-kill-indices get ] dip kill-indices get set-at ] + tri ; + +PRIVATE> + +: compute-live-ranges ( cfg -- ) + needs-dominance + + H{ } clone def-indices set + H{ } clone kill-indices set + [ compute-local-live-ranges ] each-basic-block ; + +: def-index ( vreg bb -- n ) + def-indices get at at ; + +ERROR: bad-kill-index vreg bb ; + +: kill-index ( vreg bb -- n ) + 2dup live-out? [ 2drop 1/0. ] [ + 2dup kill-indices get at at* [ 2nip ] [ + drop 2dup live-in? + [ bad-kill-index ] [ 2drop -1/0. ] if + ] if + ] if ; diff --git a/basis/compiler/cfg/ssa/liveness/liveness-tests.factor b/basis/compiler/cfg/ssa/liveness/liveness-tests.factor new file mode 100644 index 0000000000..bc5807087d --- /dev/null +++ b/basis/compiler/cfg/ssa/liveness/liveness-tests.factor @@ -0,0 +1,291 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: kernel tools.test namespaces sequences vectors accessors sets +arrays math.ranges assocs +cpu.architecture +compiler.cfg +compiler.cfg.ssa.liveness.private +compiler.cfg.ssa.liveness +compiler.cfg.debugger +compiler.cfg.instructions +compiler.cfg.predecessors +compiler.cfg.registers +compiler.cfg.dominance +compiler.cfg.def-use ; +IN: compiler.cfg.ssa.liveness + +[ t ] [ { 1 } 1 only? ] unit-test +[ t ] [ { } 1 only? ] unit-test +[ f ] [ { 2 1 } 1 only? ] unit-test +[ f ] [ { 2 } 1 only? ] unit-test + +: test-liveness ( -- ) + cfg new 0 get >>entry + dup compute-defs + dup compute-uses + needs-dominance + precompute-liveness ; + +V{ + T{ ##peek f 0 D 0 } + T{ ##replace f 0 D 0 } + T{ ##replace f 1 D 1 } +} 0 test-bb + +V{ + T{ ##replace f 2 D 0 } +} 1 test-bb + +V{ + T{ ##replace f 3 D 0 } +} 2 test-bb + +0 { 1 2 } edges + +[ ] [ test-liveness ] unit-test + +[ H{ } ] [ back-edge-targets get ] unit-test +[ t ] [ 0 get R_q { 0 1 2 } [ get ] map unique = ] unit-test +[ t ] [ 1 get R_q { 1 } [ get ] map unique = ] unit-test +[ t ] [ 2 get R_q { 2 } [ get ] map unique = ] unit-test + +: self-T_q ( n -- ? ) + get [ T_q ] [ 1array unique ] bi = ; + +[ t ] [ 0 self-T_q ] unit-test +[ t ] [ 1 self-T_q ] unit-test +[ t ] [ 2 self-T_q ] unit-test + +[ f ] [ 0 0 get live-in? ] unit-test +[ t ] [ 1 0 get live-in? ] unit-test +[ t ] [ 2 0 get live-in? ] unit-test +[ t ] [ 3 0 get live-in? ] unit-test + +[ f ] [ 0 0 get live-out? ] unit-test +[ f ] [ 1 0 get live-out? ] unit-test +[ t ] [ 2 0 get live-out? ] unit-test +[ t ] [ 3 0 get live-out? ] unit-test + +[ f ] [ 0 1 get live-in? ] unit-test +[ f ] [ 1 1 get live-in? ] unit-test +[ t ] [ 2 1 get live-in? ] unit-test +[ f ] [ 3 1 get live-in? ] unit-test + +[ f ] [ 0 1 get live-out? ] unit-test +[ f ] [ 1 1 get live-out? ] unit-test +[ f ] [ 2 1 get live-out? ] unit-test +[ f ] [ 3 1 get live-out? ] unit-test + +[ f ] [ 0 2 get live-in? ] unit-test +[ f ] [ 1 2 get live-in? ] unit-test +[ f ] [ 2 2 get live-in? ] unit-test +[ t ] [ 3 2 get live-in? ] unit-test + +[ f ] [ 0 2 get live-out? ] unit-test +[ f ] [ 1 2 get live-out? ] unit-test +[ f ] [ 2 2 get live-out? ] unit-test +[ f ] [ 3 2 get live-out? ] unit-test + +V{ } 0 test-bb +V{ } 1 test-bb +V{ } 2 test-bb +V{ } 3 test-bb +V{ + T{ ##phi f 2 H{ { 2 0 } { 3 1 } } } +} 4 test-bb +test-diamond + +[ ] [ test-liveness ] unit-test + +[ t ] [ 0 1 get live-in? ] unit-test +[ t ] [ 1 1 get live-in? ] unit-test +[ f ] [ 2 1 get live-in? ] unit-test + +[ t ] [ 0 1 get live-out? ] unit-test +[ t ] [ 1 1 get live-out? ] unit-test +[ f ] [ 2 1 get live-out? ] unit-test + +[ t ] [ 0 2 get live-in? ] unit-test +[ f ] [ 1 2 get live-in? ] unit-test +[ f ] [ 2 2 get live-in? ] unit-test + +[ f ] [ 0 2 get live-out? ] unit-test +[ f ] [ 1 2 get live-out? ] unit-test +[ f ] [ 2 2 get live-out? ] unit-test + +[ f ] [ 0 3 get live-in? ] unit-test +[ t ] [ 1 3 get live-in? ] unit-test +[ f ] [ 2 3 get live-in? ] unit-test + +[ f ] [ 0 3 get live-out? ] unit-test +[ f ] [ 1 3 get live-out? ] unit-test +[ f ] [ 2 3 get live-out? ] unit-test + +[ f ] [ 0 4 get live-in? ] unit-test +[ f ] [ 1 4 get live-in? ] unit-test +[ f ] [ 2 4 get live-in? ] unit-test + +[ f ] [ 0 4 get live-out? ] unit-test +[ f ] [ 1 4 get live-out? ] unit-test +[ f ] [ 2 4 get live-out? ] unit-test + +! This is the CFG in Figure 3 from the paper +V{ } 0 test-bb +V{ } 1 test-bb +0 1 edge +V{ } 2 test-bb +1 2 edge +V{ + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 0 } + T{ ##peek f 2 D 0 } +} 3 test-bb +V{ } 11 test-bb +2 { 3 11 } edges +V{ + T{ ##replace f 0 D 0 } +} 4 test-bb +V{ } 8 test-bb +3 { 8 4 } edges +V{ + T{ ##replace f 1 D 0 } +} 9 test-bb +8 9 edge +V{ + T{ ##replace f 2 D 0 } +} 5 test-bb +4 5 edge +V{ } 10 test-bb +V{ } 6 test-bb +5 6 edge +9 { 6 10 } edges +V{ } 7 test-bb +6 { 5 7 } edges +10 8 edge +7 2 edge + +[ ] [ test-liveness ] unit-test + +[ t ] [ 1 get R_q 1 11 [a,b] [ get ] map unique = ] unit-test +[ t ] [ 2 get R_q 2 11 [a,b] [ get ] map unique = ] unit-test +[ t ] [ 3 get R_q 3 10 [a,b] [ get ] map unique = ] unit-test +[ t ] [ 4 get R_q 4 7 [a,b] [ get ] map unique = ] unit-test +[ t ] [ 5 get R_q 5 7 [a,b] [ get ] map unique = ] unit-test +[ t ] [ 6 get R_q 6 7 [a,b] [ get ] map unique = ] unit-test +[ t ] [ 7 get R_q 7 7 [a,b] [ get ] map unique = ] unit-test +[ t ] [ 8 get R_q 6 10 [a,b] [ get ] map unique = ] unit-test +[ t ] [ 9 get R_q 8 6 10 [a,b] remove [ get ] map unique = ] unit-test +[ t ] [ 10 get R_q 10 10 [a,b] [ get ] map unique = ] unit-test +[ t ] [ 11 get R_q 11 11 [a,b] [ get ] map unique = ] unit-test + +[ t ] [ 1 get T_q 1 get 1array unique = ] unit-test +[ t ] [ 2 get T_q 2 get 1array unique = ] unit-test +[ t ] [ 3 get T_q 3 get 2 get 2array unique = ] unit-test +[ t ] [ 4 get T_q 4 get 2 get 2array unique = ] unit-test +[ t ] [ 5 get T_q 5 get 2 get 2array unique = ] unit-test +[ t ] [ 6 get T_q { 6 2 5 } [ get ] map unique = ] unit-test +[ t ] [ 7 get T_q { 7 2 } [ get ] map unique = ] unit-test +[ t ] [ 8 get T_q { 8 2 5 } [ get ] map unique = ] unit-test +[ t ] [ 9 get T_q { 2 5 8 9 } [ get ] map unique = ] unit-test +[ t ] [ 10 get T_q { 2 5 8 10 } [ get ] map unique = ] unit-test +[ t ] [ 11 get T_q 11 get 1array unique = ] unit-test + +[ f ] [ 1 get back-edge-target? ] unit-test +[ t ] [ 2 get back-edge-target? ] unit-test +[ f ] [ 3 get back-edge-target? ] unit-test +[ f ] [ 4 get back-edge-target? ] unit-test +[ t ] [ 5 get back-edge-target? ] unit-test +[ f ] [ 6 get back-edge-target? ] unit-test +[ f ] [ 7 get back-edge-target? ] unit-test +[ t ] [ 8 get back-edge-target? ] unit-test +[ f ] [ 9 get back-edge-target? ] unit-test +[ f ] [ 10 get back-edge-target? ] unit-test +[ f ] [ 11 get back-edge-target? ] unit-test + +[ f ] [ 0 1 get live-in? ] unit-test +[ f ] [ 1 1 get live-in? ] unit-test +[ f ] [ 2 1 get live-in? ] unit-test + +[ f ] [ 0 1 get live-out? ] unit-test +[ f ] [ 1 1 get live-out? ] unit-test +[ f ] [ 2 1 get live-out? ] unit-test + +[ f ] [ 0 2 get live-in? ] unit-test +[ f ] [ 1 2 get live-in? ] unit-test +[ f ] [ 2 2 get live-in? ] unit-test + +[ f ] [ 0 2 get live-out? ] unit-test +[ f ] [ 1 2 get live-out? ] unit-test +[ f ] [ 2 2 get live-out? ] unit-test + +[ f ] [ 0 3 get live-in? ] unit-test +[ f ] [ 1 3 get live-in? ] unit-test +[ f ] [ 2 3 get live-in? ] unit-test + +[ t ] [ 0 3 get live-out? ] unit-test +[ t ] [ 1 3 get live-out? ] unit-test +[ t ] [ 2 3 get live-out? ] unit-test + +[ t ] [ 0 4 get live-in? ] unit-test +[ f ] [ 1 4 get live-in? ] unit-test +[ t ] [ 2 4 get live-in? ] unit-test + +[ f ] [ 0 4 get live-out? ] unit-test +[ f ] [ 1 4 get live-out? ] unit-test +[ t ] [ 2 4 get live-out? ] unit-test + +[ f ] [ 0 5 get live-in? ] unit-test +[ f ] [ 1 5 get live-in? ] unit-test +[ t ] [ 2 5 get live-in? ] unit-test + +[ f ] [ 0 5 get live-out? ] unit-test +[ f ] [ 1 5 get live-out? ] unit-test +[ t ] [ 2 5 get live-out? ] unit-test + +[ f ] [ 0 6 get live-in? ] unit-test +[ f ] [ 1 6 get live-in? ] unit-test +[ t ] [ 2 6 get live-in? ] unit-test + +[ f ] [ 0 6 get live-out? ] unit-test +[ f ] [ 1 6 get live-out? ] unit-test +[ t ] [ 2 6 get live-out? ] unit-test + +[ f ] [ 0 7 get live-in? ] unit-test +[ f ] [ 1 7 get live-in? ] unit-test +[ f ] [ 2 7 get live-in? ] unit-test + +[ f ] [ 0 7 get live-out? ] unit-test +[ f ] [ 1 7 get live-out? ] unit-test +[ f ] [ 2 7 get live-out? ] unit-test + +[ f ] [ 0 8 get live-in? ] unit-test +[ t ] [ 1 8 get live-in? ] unit-test +[ t ] [ 2 8 get live-in? ] unit-test + +[ f ] [ 0 8 get live-out? ] unit-test +[ t ] [ 1 8 get live-out? ] unit-test +[ t ] [ 2 8 get live-out? ] unit-test + +[ f ] [ 0 9 get live-in? ] unit-test +[ t ] [ 1 9 get live-in? ] unit-test +[ t ] [ 2 9 get live-in? ] unit-test + +[ f ] [ 0 9 get live-out? ] unit-test +[ t ] [ 1 9 get live-out? ] unit-test +[ t ] [ 2 9 get live-out? ] unit-test + +[ f ] [ 0 10 get live-in? ] unit-test +[ t ] [ 1 10 get live-in? ] unit-test +[ t ] [ 2 10 get live-in? ] unit-test + +[ f ] [ 0 10 get live-out? ] unit-test +[ t ] [ 1 10 get live-out? ] unit-test +[ t ] [ 2 10 get live-out? ] unit-test + +[ f ] [ 0 11 get live-in? ] unit-test +[ f ] [ 1 11 get live-in? ] unit-test +[ f ] [ 2 11 get live-in? ] unit-test + +[ f ] [ 0 11 get live-out? ] unit-test +[ f ] [ 1 11 get live-out? ] unit-test +[ f ] [ 2 11 get live-out? ] unit-test diff --git a/basis/compiler/cfg/ssa/liveness/liveness.factor b/basis/compiler/cfg/ssa/liveness/liveness.factor new file mode 100644 index 0000000000..1ed6010dbe --- /dev/null +++ b/basis/compiler/cfg/ssa/liveness/liveness.factor @@ -0,0 +1,130 @@ +! 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 ; +IN: compiler.cfg.ssa.liveness + +! Liveness checking on SSA IR, as described in +! "Fast Liveness Checking for SSA-Form Programs", Sebastian Hack et al. +! http://hal.archives-ouvertes.fr/docs/00/19/22/19/PDF/fast_liveness.pdf + +> ] [ number>> ] tri + '[ number>> _ >= ] filter + [ R_q ] map assoc-combine + [ conjoin ] keep ; + +: set-R_q ( q -- ) + [ next-R_q ] keep R_q-sets get set-at ; + +: set-back-edges ( q -- ) + [ successors>> ] [ number>> ] bi '[ + dup number>> _ < + [ back-edge-targets get conjoin ] [ drop ] if + ] each ; + +: init-R_q ( -- ) + H{ } clone R_q-sets set + H{ } clone back-edge-targets set ; + +: compute-R_q ( cfg -- ) + init-R_q + post-order [ + [ set-R_q ] [ set-back-edges ] bi + ] each ; + +! This algorithm for computing T_q uses equation (1) +! but not the faster algorithm described in the paper + +: back-edges-from ( q -- edges ) + R_q keys [ + [ successors>> ] [ number>> ] bi + '[ number>> _ < ] filter + ] gather ; + +: T^_q ( q -- T^_q ) + [ back-edges-from ] [ R_q ] bi + '[ _ key? not ] filter ; + +: next-T_q ( q -- T_q ) + dup dup T^_q [ next-T_q keys ] map + concat unique [ conjoin ] keep + [ swap T_q-sets get set-at ] keep ; + +: compute-T_q ( cfg -- ) + H{ } T_q-sets set + [ next-T_q drop ] each-basic-block ; + +PRIVATE> + +: precompute-liveness ( cfg -- ) + [ compute-R_q ] [ compute-T_q ] bi ; + + + +: live-in? ( vreg node -- ? ) + [ drop ] live? ; + + + +:: live-out? ( vreg node -- ? ) + [let | def [ vreg def-of ] | + { + { [ node def eq? ] [ vreg uses-of def only? not ] } + { [ def node strictly-dominates? ] [ vreg node (live-out?) ] } + [ f ] + } cond + ] ; diff --git a/basis/compiler/cfg/stack-analysis/authors.txt b/basis/compiler/cfg/stack-analysis/authors.txt deleted file mode 100644 index d4f5d6b3ae..0000000000 --- a/basis/compiler/cfg/stack-analysis/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov \ No newline at end of file diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor deleted file mode 100644 index 4455d5e208..0000000000 --- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor +++ /dev/null @@ -1,113 +0,0 @@ -USING: prettyprint compiler.cfg.debugger compiler.cfg.linearization -compiler.cfg.predecessors compiler.cfg.stack-analysis -compiler.cfg.instructions sequences kernel tools.test accessors -sequences.private alien math combinators.private compiler.cfg -compiler.cfg.checker compiler.cfg.height compiler.cfg.rpo -compiler.cfg.dce compiler.cfg.registers compiler.cfg.useless-blocks -sets ; -IN: compiler.cfg.stack-analysis.tests - -! Fundamental invariant: a basic block should not load or store a value more than once -: check-for-redundant-ops ( cfg -- ) - [ - instructions>> - [ - [ ##peek? ] filter [ loc>> ] map duplicates empty? - [ "Redundant peeks" throw ] unless - ] [ - [ ##replace? ] filter [ loc>> ] map duplicates empty? - [ "Redundant replaces" throw ] unless - ] bi - ] each-basic-block ; - -: test-stack-analysis ( quot -- cfg ) - dup cfg? [ test-cfg first ] unless - compute-predecessors - delete-useless-blocks - delete-useless-conditionals - normalize-height - stack-analysis - dup check-cfg - dup check-for-redundant-ops ; - -: linearize ( cfg -- mr ) - flatten-cfg instructions>> ; - -[ ] [ [ ] test-stack-analysis drop ] unit-test - -! Only peek once -[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize [ ##peek? ] count ] unit-test - -! Redundant replace is redundant -[ f ] [ [ dup drop ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test -[ f ] [ [ swap swap ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test - -! Replace required here -[ t ] [ [ dup ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test -[ t ] [ [ [ drop 1 ] when ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test - -! Only one replace, at the end -[ 1 ] [ [ [ 1 ] [ 2 ] if ] test-stack-analysis linearize [ ##replace? ] count ] unit-test - -! Do we support the full language? -[ ] [ [ { [ ] [ ] } dispatch ] test-stack-analysis drop ] unit-test -[ ] [ [ { [ ] [ ] } dispatch dup ] test-stack-analysis drop ] unit-test -[ ] [ - [ "int" { "int" "int" } "cdecl" [ + ] alien-callback ] - test-cfg second test-stack-analysis drop -] unit-test - -! Test loops -[ ] [ [ [ t ] loop ] test-stack-analysis drop ] unit-test -[ ] [ [ [ dup ] loop ] test-stack-analysis drop ] unit-test - -! Make sure that peeks are inserted in the right place -[ ] [ [ [ drop 1 ] when ] test-stack-analysis drop ] unit-test - -! This should be a total no-op -[ f ] [ [ [ ] dip ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test - -! Don't insert inc-d/inc-r; that's wrong! -[ 1 ] [ [ dup ] test-stack-analysis linearize [ ##inc-d? ] count ] unit-test - -! Bug in height tracking -[ ] [ [ dup [ ] [ reverse ] if ] test-stack-analysis drop ] unit-test -[ ] [ [ dup [ ] [ dup reverse drop ] if ] test-stack-analysis drop ] unit-test -[ ] [ [ [ drop dup 4.0 > ] find-last-integer ] test-stack-analysis drop ] unit-test - -! Bugs with code that throws -[ ] [ [ [ "Oops" throw ] unless ] test-stack-analysis drop ] unit-test -[ ] [ [ [ ] (( -- * )) call-effect-unsafe ] test-stack-analysis drop ] unit-test -[ ] [ [ dup [ "Oops" throw ] when dup ] test-stack-analysis drop ] unit-test -[ ] [ [ B{ 1 2 3 4 } over [ "Oops" throw ] when swap ] test-stack-analysis drop ] unit-test - -! Make sure the replace stores a value with the right height -[ ] [ - [ [ . ] [ 2drop 1 ] if ] test-stack-analysis eliminate-dead-code linearize - [ ##replace? ] filter [ length 1 assert= ] [ first loc>> D 0 assert= ] bi -] unit-test - -! translate-loc was the wrong way round -[ ] [ - [ 1 2 rot ] test-stack-analysis eliminate-dead-code linearize - [ [ ##load-immediate? ] count 2 assert= ] - [ [ ##peek? ] count 1 assert= ] - [ [ ##replace? ] count 3 assert= ] - tri -] unit-test - -[ ] [ - [ 1 2 ? ] test-stack-analysis eliminate-dead-code linearize - [ [ ##load-immediate? ] count 2 assert= ] - [ [ ##peek? ] count 1 assert= ] - [ [ ##replace? ] count 1 assert= ] - tri -] unit-test - -! Sync before a back-edge, not after -! ##peeks should be inserted before a ##loop-entry -! Don't optimize out the constants -[ 1 t ] [ - [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize - [ [ ##add-imm? ] count ] [ [ ##load-immediate? ] any? ] bi -] unit-test diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor deleted file mode 100644 index 4ebdf7012f..0000000000 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ /dev/null @@ -1,295 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs kernel namespaces math sequences fry grouping -sets make combinators compiler.cfg.copy-prop compiler.cfg.def-use -compiler.cfg.instructions compiler.cfg.registers compiler.cfg.rpo -compiler.cfg.hats compiler.cfg ; -IN: compiler.cfg.stack-analysis - -! Convert stack operations to register operations - -! If 'poisoned' is set, disregard height information. This is set if we don't have -! height change information for an instruction. -TUPLE: state locs>vregs actual-locs>vregs changed-locs ds-height rs-height poisoned? ; - -: ( -- state ) - state new - H{ } clone >>locs>vregs - H{ } clone >>actual-locs>vregs - H{ } clone >>changed-locs - 0 >>ds-height - 0 >>rs-height ; - -M: state clone - call-next-method - [ clone ] change-locs>vregs - [ clone ] change-actual-locs>vregs - [ clone ] change-changed-locs ; - -: loc>vreg ( loc -- vreg ) state get locs>vregs>> at ; - -: record-peek ( dst loc -- ) - state get [ locs>vregs>> set-at ] [ actual-locs>vregs>> set-at ] 3bi ; - -: changed-loc ( loc -- ) - state get changed-locs>> conjoin ; - -: record-replace ( src loc -- ) - dup changed-loc state get locs>vregs>> set-at ; - -GENERIC: height-for ( loc -- n ) - -M: ds-loc height-for drop state get ds-height>> ; -M: rs-loc height-for drop state get rs-height>> ; - -: (translate-loc) ( loc -- n height ) [ n>> ] [ height-for ] bi ; inline - -GENERIC: translate-loc ( loc -- loc' ) - -M: ds-loc translate-loc (translate-loc) - ; -M: rs-loc translate-loc (translate-loc) - ; - -GENERIC: untranslate-loc ( loc -- loc' ) - -M: ds-loc untranslate-loc (translate-loc) + ; -M: rs-loc untranslate-loc (translate-loc) + ; - -: redundant-replace? ( vreg loc -- ? ) - dup untranslate-loc n>> 0 < - [ 2drop t ] [ state get actual-locs>vregs>> at = ] if ; - -: save-changed-locs ( state -- ) - [ changed-locs>> ] [ locs>vregs>> ] bi '[ - _ at swap 2dup redundant-replace? - [ 2drop ] [ untranslate-loc ##replace ] if - ] assoc-each ; - -: clear-state ( state -- ) - [ locs>vregs>> clear-assoc ] - [ actual-locs>vregs>> clear-assoc ] - [ changed-locs>> clear-assoc ] - tri ; - -ERROR: poisoned-state state ; - -: sync-state ( -- ) - state get { - [ dup poisoned?>> [ poisoned-state ] [ drop ] if ] - [ save-changed-locs ] - [ clear-state ] - } cleave ; - -: poison-state ( -- ) state get t >>poisoned? drop ; - -! Abstract interpretation -GENERIC: visit ( insn -- ) - -! Instructions which don't have any effect on the stack -UNION: neutral-insn - ##flushable - ##effect ; - -M: neutral-insn visit , ; - -UNION: sync-if-back-edge - ##branch - ##conditional-branch - ##compare-imm-branch - ##dispatch - ##loop-entry ; - -SYMBOL: local-only? - -t local-only? set-global - -: back-edge? ( from to -- ? ) - [ number>> ] bi@ > ; - -: sync-state? ( -- ? ) - basic-block get successors>> - [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any? - local-only? get or ; - -M: sync-if-back-edge visit - sync-state? [ sync-state ] when , ; - -: adjust-d ( n -- ) state get [ + ] change-ds-height drop ; - -M: ##inc-d visit [ , ] [ n>> adjust-d ] bi ; - -: adjust-r ( n -- ) state get [ + ] change-rs-height drop ; - -M: ##inc-r visit [ , ] [ n>> adjust-r ] bi ; - -: eliminate-peek ( dst src -- ) - ! the requested stack location is already in 'src' - [ ##copy ] [ swap copies get set-at ] 2bi ; - -M: ##peek visit - dup - [ dst>> ] [ loc>> translate-loc ] bi - dup loc>vreg dup [ nip eliminate-peek drop ] [ drop record-peek , ] if ; - -M: ##replace visit - [ src>> resolve ] [ loc>> translate-loc ] bi - record-replace ; - -M: ##copy visit - [ call-next-method ] [ record-copy ] bi ; - -M: ##call visit - [ call-next-method ] [ height>> adjust-d ] bi ; - -! Instructions that poison the stack state -UNION: poison-insn - ##jump - ##return - ##callback-return - ##fixnum-mul-tail - ##fixnum-add-tail - ##fixnum-sub-tail ; - -M: poison-insn visit call-next-method poison-state ; - -! Instructions that kill all live vregs -UNION: kill-vreg-insn - poison-insn - ##stack-frame - ##call - ##prologue - ##epilogue - ##fixnum-mul - ##fixnum-add - ##fixnum-sub - ##alien-invoke - ##alien-indirect ; - -M: kill-vreg-insn visit sync-state , ; - -: visit-alien-node ( node -- ) - params>> [ out-d>> length ] [ in-d>> length ] bi - adjust-d ; - -M: ##alien-invoke visit - [ call-next-method ] [ visit-alien-node ] bi ; - -M: ##alien-indirect visit - [ call-next-method ] [ visit-alien-node ] bi ; - -M: ##alien-callback visit , ; - -! Maps basic-blocks to states -SYMBOLS: state-in state-out ; - -: initial-state ( bb states -- state ) 2drop ; - -: single-predecessor ( bb states -- state ) nip first clone ; - -ERROR: must-equal-failed seq ; - -: must-equal ( seq -- elt ) - dup all-equal? [ first ] [ must-equal-failed ] if ; - -: merge-heights ( state predecessors states -- state ) - nip - [ [ ds-height>> ] map must-equal >>ds-height ] - [ [ rs-height>> ] map must-equal >>rs-height ] bi ; - -: insert-peek ( predecessor loc -- vreg ) - ! XXX critical edges - '[ _ ^^peek ] add-instructions ; - -: merge-loc ( predecessors locs>vregs loc -- vreg ) - ! Insert a ##phi in the current block where the input - ! is the vreg storing loc from each predecessor block - [ '[ [ _ ] dip at ] map ] keep - '[ [ ] [ _ insert-peek ] ?if ] 2map - dup all-equal? [ first ] [ ^^phi ] if ; - -: (merge-locs) ( predecessors assocs -- assoc ) - dup [ keys ] map concat prune - [ [ 2nip ] [ merge-loc ] 3bi ] with with - H{ } map>assoc ; - -: merge-locs ( state predecessors states -- state ) - [ locs>vregs>> ] map (merge-locs) >>locs>vregs ; - -: merge-loc' ( locs>vregs loc -- vreg ) - ! Insert a ##phi in the current block where the input - ! is the vreg storing loc from each predecessor block - '[ [ _ ] dip at ] map - dup all-equal? [ first ] [ drop f ] if ; - -: merge-actual-locs ( state predecessors states -- state ) - nip - [ actual-locs>vregs>> ] map - dup [ keys ] map concat prune - [ [ nip ] [ merge-loc' ] 2bi ] with - H{ } map>assoc - [ nip ] assoc-filter - >>actual-locs>vregs ; - -: merge-changed-locs ( state predecessors states -- state ) - nip [ changed-locs>> ] map assoc-combine >>changed-locs ; - -ERROR: cannot-merge-poisoned states ; - -: multiple-predecessors ( bb states -- state ) - dup [ not ] any? [ - [ ] 2dip - sift merge-heights - ] [ - dup [ poisoned?>> ] any? [ - cannot-merge-poisoned - ] [ - [ state new ] 2dip - [ predecessors>> ] dip - { - [ merge-locs ] - [ merge-actual-locs ] - [ merge-heights ] - [ merge-changed-locs ] - } 2cleave - ] if - ] if ; - -: merge-states ( bb states -- state ) - ! If any states are poisoned, save all registers - ! to the stack in each branch - dup length { - { 0 [ initial-state ] } - { 1 [ single-predecessor ] } - [ drop multiple-predecessors ] - } case ; - -: block-in-state ( bb -- states ) - dup predecessors>> state-out get '[ _ at ] map merge-states ; - -: set-block-in-state ( state bb -- ) - [ clone ] dip state-in get set-at ; - -: set-block-out-state ( state bb -- ) - [ clone ] dip state-out get set-at ; - -: visit-block ( bb -- ) - ! block-in-state may add phi nodes at the start of the basic block - ! so we wrap the whole thing with a 'make' - [ - dup basic-block set - dup block-in-state - [ swap set-block-in-state ] [ - state [ - [ instructions>> [ visit ] each ] - [ [ state get ] dip set-block-out-state ] - [ ] - tri - ] with-variable - ] 2bi - ] V{ } make >>instructions drop ; - -: stack-analysis ( cfg -- cfg' ) - [ - H{ } clone copies set - H{ } clone state-in set - H{ } clone state-out set - dup [ visit-block ] each-basic-block - ] with-scope ; diff --git a/basis/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor index 5cb5762b78..4b071cb43c 100644 --- a/basis/compiler/cfg/stack-frame/stack-frame.factor +++ b/basis/compiler/cfg/stack-frame/stack-frame.factor @@ -9,41 +9,27 @@ TUPLE: stack-frame { return integer } { total-size integer } { gc-root-size integer } -spill-counts ; +{ spill-area-size integer } ; ! Stack frame utilities : param-base ( -- n ) stack-frame get [ params>> ] [ return>> ] bi + ; -: spill-float-offset ( n -- offset ) - double-float-regs reg-size * ; - -: spill-integer-base ( -- n ) - stack-frame get spill-counts>> double-float-regs [ swap at ] keep reg-size * +: spill-offset ( n -- offset ) param-base + ; -: spill-integer-offset ( n -- offset ) - cells spill-integer-base + ; - -: spill-area-size ( stack-frame -- n ) - spill-counts>> [ swap reg-size * ] { } assoc>map sum ; - : gc-root-base ( -- n ) - stack-frame get spill-area-size - param-base + ; + stack-frame get spill-area-size>> param-base + ; : gc-root-offset ( n -- n' ) gc-root-base + ; -: gc-roots-size ( live-registers live-spill-slots -- n ) - [ keys [ reg-class>> reg-size ] sigma ] bi@ + ; - : (stack-frame-size) ( stack-frame -- n ) [ { - [ spill-area-size ] - [ gc-root-size>> ] [ params>> ] [ return>> ] + [ gc-root-size>> ] + [ spill-area-size>> ] } cleave ] sum-outputs ; diff --git a/basis/compiler/cfg/stacks/finalize/finalize.factor b/basis/compiler/cfg/stacks/finalize/finalize.factor new file mode 100644 index 0000000000..f1f7880c90 --- /dev/null +++ b/basis/compiler/cfg/stacks/finalize/finalize.factor @@ -0,0 +1,59 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces assocs kernel fry accessors sequences make math locals +combinators compiler.cfg compiler.cfg.hats compiler.cfg.instructions +compiler.cfg.utilities compiler.cfg.rpo compiler.cfg.stacks.local +compiler.cfg.stacks.global compiler.cfg.stacks.height +compiler.cfg.predecessors ; +IN: compiler.cfg.stacks.finalize + +! This pass inserts peeks and replaces. + +:: inserting-peeks ( from to -- assoc ) + ! A peek is inserted on an edge if the destination anticipates + ! the stack location, the source does not anticipate it and + ! it is not available from the source in a register. + to anticip-in + from anticip-out from avail-out assoc-union + assoc-diff ; + +:: inserting-replaces ( from to -- assoc ) + ! A replace is inserted on an edge if two conditions hold: + ! - the location is not dead at the destination, OR + ! the location is live at the destination but not available + ! at the destination + ! - the location is pending in the source but not the destination + from pending-out to pending-in assoc-diff + to dead-in to live-in to anticip-in assoc-diff assoc-diff + assoc-diff ; + +: each-insertion ( assoc bb quot: ( vreg loc -- ) -- ) + '[ drop [ loc>vreg ] [ _ untranslate-loc ] bi @ ] assoc-each ; inline + +ERROR: bad-peek dst loc ; + +: insert-peeks ( from to -- ) + [ inserting-peeks ] keep + [ dup n>> 0 < [ bad-peek ] [ ##peek ] if ] each-insertion ; + +: insert-replaces ( from to -- ) + [ inserting-replaces ] keep + [ dup n>> 0 < [ 2drop ] [ ##replace ] if ] each-insertion ; + +: visit-edge ( from to -- ) + ! If both blocks are subroutine calls, don't bother + ! computing anything. + 2dup [ kill-block? ] both? [ 2drop ] [ + 2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ] V{ } make + [ 2drop ] [ insert-simple-basic-block ] if-empty + ] if ; + +: visit-block ( bb -- ) + [ predecessors>> ] keep '[ _ visit-edge ] each ; + +: finalize-stack-shuffling ( cfg -- cfg' ) + needs-predecessors + + dup [ visit-block ] each-basic-block + + cfg-changed ; diff --git a/basis/compiler/cfg/stacks/global/global.factor b/basis/compiler/cfg/stacks/global/global.factor new file mode 100644 index 0000000000..30a999064a --- /dev/null +++ b/basis/compiler/cfg/stacks/global/global.factor @@ -0,0 +1,59 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs kernel combinators compiler.cfg.dataflow-analysis +compiler.cfg.stacks.local ; +IN: compiler.cfg.stacks.global + +: transfer-peeked-locs ( assoc bb -- assoc' ) + [ replace-set assoc-diff ] [ peek-set assoc-union ] bi ; + +! A stack location is anticipated at a location if every path from +! the location to an exit block will read the stack location +! before writing it. +BACKWARD-ANALYSIS: anticip + +M: anticip-analysis transfer-set drop transfer-peeked-locs ; + +! A stack location is live at a location if some path from +! the location to an exit block will read the stack location +! before writing it. +BACKWARD-ANALYSIS: live + +M: live-analysis transfer-set drop transfer-peeked-locs ; + +M: live-analysis join-sets 2drop assoc-combine ; + +! A stack location is available at a location if all paths from +! the entry block to the location load the location into a +! register. +FORWARD-ANALYSIS: avail + +M: avail-analysis transfer-set + drop [ peek-set assoc-union ] [ replace-set assoc-union ] bi ; + +! A stack location is pending at a location if all paths from +! the entry block to the location write the location. +FORWARD-ANALYSIS: pending + +M: pending-analysis transfer-set + drop replace-set assoc-union ; + +! A stack location is dead at a location if no paths from the +! location to the exit block read the location before writing it. +BACKWARD-ANALYSIS: dead + +M: dead-analysis transfer-set + drop + [ kill-set assoc-union ] + [ replace-set assoc-union ] bi ; + +! Main word +: compute-global-sets ( cfg -- cfg' ) + { + [ compute-anticip-sets ] + [ compute-live-sets ] + [ compute-pending-sets ] + [ compute-dead-sets ] + [ compute-avail-sets ] + [ ] + } cleave ; diff --git a/basis/compiler/cfg/stacks/height/height.factor b/basis/compiler/cfg/stacks/height/height.factor new file mode 100644 index 0000000000..4d91dc614a --- /dev/null +++ b/basis/compiler/cfg/stacks/height/height.factor @@ -0,0 +1,27 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs fry kernel math +namespaces compiler.cfg.registers ; +IN: compiler.cfg.stacks.height + +! Global stack height tracking done while constructing CFG. +SYMBOLS: ds-heights rs-heights ; + +: record-stack-heights ( ds-height rs-height bb -- ) + [ ds-heights get set-at ] [ rs-heights get set-at ] bi-curry bi* ; + +GENERIC# translate-loc 1 ( loc bb -- loc' ) + +M: ds-loc translate-loc [ n>> ] [ ds-heights get at ] bi* - ; +M: rs-loc translate-loc [ n>> ] [ rs-heights get at ] bi* - ; + +: translate-locs ( assoc bb -- assoc' ) + '[ [ _ translate-loc ] dip ] assoc-map ; + +GENERIC# untranslate-loc 1 ( loc bb -- loc' ) + +M: ds-loc untranslate-loc [ n>> ] [ ds-heights get at ] bi* + ; +M: rs-loc untranslate-loc [ n>> ] [ rs-heights get at ] bi* + ; + +: untranslate-locs ( assoc bb -- assoc' ) + '[ [ _ untranslate-loc ] dip ] assoc-map ; \ No newline at end of file diff --git a/basis/compiler/cfg/stacks/local/local.factor b/basis/compiler/cfg/stacks/local/local.factor new file mode 100644 index 0000000000..30a2c4c13f --- /dev/null +++ b/basis/compiler/cfg/stacks/local/local.factor @@ -0,0 +1,109 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs kernel math math.order namespaces sets make +sequences combinators fry +compiler.cfg +compiler.cfg.hats +compiler.cfg.instructions +compiler.cfg.registers +compiler.cfg.stacks.height +compiler.cfg.parallel-copy ; +IN: compiler.cfg.stacks.local + +! Local stack analysis. We build three sets for every basic block +! in the CFG: +! - peek-set: all stack locations that the block reads before writing +! - replace-set: all stack locations that the block writes +! - kill-set: all stack locations which become unavailable after the +! block ends because of the stack height being decremented +! This is done while constructing the CFG. + +SYMBOLS: peek-sets replace-sets kill-sets ; + +SYMBOL: locs>vregs + +: loc>vreg ( loc -- vreg ) locs>vregs get [ drop next-vreg ] cache ; +: vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ; + +TUPLE: current-height +{ d initial: 0 } +{ r initial: 0 } +{ emit-d initial: 0 } +{ emit-r initial: 0 } ; + +SYMBOLS: local-peek-set local-replace-set replace-mapping ; + +GENERIC: translate-local-loc ( loc -- loc' ) +M: ds-loc translate-local-loc n>> current-height get d>> - ; +M: rs-loc translate-local-loc n>> current-height get r>> - ; + +: emit-stack-changes ( -- ) + replace-mapping get dup assoc-empty? [ drop ] [ + [ [ loc>vreg ] dip ] assoc-map parallel-copy + ] if ; + +: emit-height-changes ( -- ) + current-height get + [ emit-d>> dup 0 = [ drop ] [ ##inc-d ] if ] + [ emit-r>> dup 0 = [ drop ] [ ##inc-r ] if ] bi ; + +: emit-changes ( -- ) + ! Insert height and stack changes prior to the last instruction + building get pop + emit-stack-changes + emit-height-changes + , ; + +! inc-d/inc-r: these emit ##inc-d/##inc-r to change the stack height later +: inc-d ( n -- ) + current-height get + [ [ + ] change-emit-d drop ] + [ [ + ] change-d drop ] + 2bi ; + +: inc-r ( n -- ) + current-height get + [ [ + ] change-emit-r drop ] + [ [ + ] change-r drop ] + 2bi ; + +: peek-loc ( loc -- vreg ) + translate-local-loc + dup replace-mapping get at + [ ] [ dup local-peek-set get conjoin loc>vreg ] ?if ; + +: replace-loc ( vreg loc -- ) + translate-local-loc replace-mapping get set-at ; + +: compute-local-kill-set ( -- assoc ) + basic-block get current-height get + [ [ ds-heights get at dup ] [ d>> ] bi* [-] iota [ swap - ] with map ] + [ [ rs-heights get at dup ] [ r>> ] bi* [-] iota [ swap - ] with map ] 2bi + append unique ; + +: begin-local-analysis ( -- ) + H{ } clone local-peek-set set + H{ } clone replace-mapping set + current-height get + [ 0 >>emit-d 0 >>emit-r drop ] + [ [ d>> ] [ r>> ] bi basic-block get record-stack-heights ] bi ; + +: remove-redundant-replaces ( -- ) + replace-mapping get [ [ loc>vreg ] dip = not ] assoc-filter + [ replace-mapping set ] [ keys unique local-replace-set set ] bi ; + +: end-local-analysis ( -- ) + remove-redundant-replaces + emit-changes + basic-block get { + [ [ local-peek-set get ] dip peek-sets get set-at ] + [ [ local-replace-set get ] dip replace-sets get set-at ] + [ [ compute-local-kill-set ] dip kill-sets get set-at ] + } cleave ; + +: clone-current-height ( -- ) + current-height [ clone ] change ; + +: peek-set ( bb -- assoc ) peek-sets get at ; +: replace-set ( bb -- assoc ) replace-sets get at ; +: kill-set ( bb -- assoc ) kill-sets get at ; \ No newline at end of file diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor index c8fcae87c0..ce673ba5bb 100755 --- a/basis/compiler/cfg/stacks/stacks.factor +++ b/basis/compiler/cfg/stacks/stacks.factor @@ -1,45 +1,76 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: math sequences kernel cpu.architecture -compiler.cfg.instructions compiler.cfg.registers -compiler.cfg.hats ; +USING: math sequences kernel namespaces accessors biassocs compiler.cfg +compiler.cfg.instructions compiler.cfg.registers compiler.cfg.hats +compiler.cfg.predecessors compiler.cfg.stacks.local +compiler.cfg.stacks.height compiler.cfg.stacks.global +compiler.cfg.stacks.finalize ; IN: compiler.cfg.stacks -: ds-drop ( -- ) - -1 ##inc-d ; +: begin-stack-analysis ( -- ) + locs>vregs set + H{ } clone ds-heights set + H{ } clone rs-heights set + H{ } clone peek-sets set + H{ } clone replace-sets set + H{ } clone kill-sets set + current-height new current-height set ; -: ds-pop ( -- vreg ) - D 0 ^^peek -1 ##inc-d ; +: end-stack-analysis ( -- ) + cfg get + compute-global-sets + finalize-stack-shuffling + drop ; -: ds-push ( vreg -- ) - 1 ##inc-d D 0 ##replace ; +: ds-drop ( -- ) -1 inc-d ; + +: ds-peek ( -- vreg ) D 0 peek-loc ; + +: ds-pop ( -- vreg ) ds-peek ds-drop ; + +: ds-push ( vreg -- ) 1 inc-d D 0 replace-loc ; : ds-load ( n -- vregs ) dup 0 = [ drop f ] - [ [ [ ^^peek ] map ] [ neg ##inc-d ] bi ] if ; + [ [ [ peek-loc ] map ] [ neg inc-d ] bi ] if ; : ds-store ( vregs -- ) [ - [ length ##inc-d ] - [ [ ##replace ] each-index ] bi + [ length inc-d ] + [ [ replace-loc ] each-index ] bi ] unless-empty ; +: rs-drop ( -- ) -1 inc-r ; + : rs-load ( n -- vregs ) dup 0 = [ drop f ] - [ [ [ ^^peek ] map ] [ neg ##inc-r ] bi ] if ; + [ [ [ peek-loc ] map ] [ neg inc-r ] bi ] if ; : rs-store ( vregs -- ) [ - [ length ##inc-r ] - [ [ ##replace ] each-index ] bi + [ length inc-r ] + [ [ replace-loc ] each-index ] bi ] unless-empty ; +: (2inputs) ( -- vreg1 vreg2 ) + D 1 peek-loc D 0 peek-loc ; + : 2inputs ( -- vreg1 vreg2 ) - D 1 ^^peek D 0 ^^peek -2 ##inc-d ; + (2inputs) -2 inc-d ; + +: (3inputs) ( -- vreg1 vreg2 vreg3 ) + D 2 peek-loc D 1 peek-loc D 0 peek-loc ; : 3inputs ( -- vreg1 vreg2 vreg3 ) - D 2 ^^peek D 1 ^^peek D 0 ^^peek -3 ##inc-d ; + (3inputs) -3 inc-d ; + +! adjust-d/adjust-r: these are called when other instructions which +! internally adjust the stack height are emitted, such as ##call and +! ##alien-invoke +: adjust-d ( n -- ) current-height get [ + ] change-d drop ; +: adjust-r ( n -- ) current-height get [ + ] change-r drop ; + diff --git a/basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor b/basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor new file mode 100644 index 0000000000..61c3cd67d1 --- /dev/null +++ b/basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor @@ -0,0 +1,60 @@ +USING: compiler.cfg.stacks.uninitialized compiler.cfg.debugger +compiler.cfg.registers compiler.cfg.instructions compiler.cfg +compiler.cfg.predecessors cpu.architecture tools.test kernel vectors +namespaces accessors sequences ; +IN: compiler.cfg.stacks.uninitialized.tests + +: test-uninitialized ( -- ) + cfg new 0 get >>entry + compute-uninitialized-sets ; + +V{ + T{ ##inc-d f 3 } +} 0 test-bb + +V{ + T{ ##replace f 0 D 0 } + T{ ##replace f 0 D 1 } + T{ ##replace f 0 D 2 } + T{ ##inc-r f 1 } +} 1 test-bb + +V{ + T{ ##peek f 0 D 0 } + T{ ##inc-d f 1 } +} 2 test-bb + +0 1 edge +1 2 edge + +[ ] [ test-uninitialized ] unit-test + +[ V{ D 0 D 1 D 2 } ] [ 1 get uninitialized-locs ] unit-test +[ V{ R 0 } ] [ 2 get uninitialized-locs ] unit-test + +! When merging, if a location is uninitialized in one branch and +! initialized in another, we have to consider it uninitialized, +! since it cannot be safely read from by a ##peek, or traced by GC. + +V{ } 0 test-bb + +V{ + T{ ##inc-d f 1 } +} 1 test-bb + +V{ + T{ ##call f namestack } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##return } +} 3 test-bb + +0 { 1 2 } edges +1 3 edge +2 3 edge + +[ ] [ test-uninitialized ] unit-test + +[ V{ D 0 } ] [ 3 get uninitialized-locs ] unit-test diff --git a/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor new file mode 100644 index 0000000000..ce0e98de5f --- /dev/null +++ b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor @@ -0,0 +1,76 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences byte-arrays namespaces accessors classes math +math.order fry arrays combinators compiler.cfg.registers +compiler.cfg.instructions compiler.cfg.dataflow-analysis ; +IN: compiler.cfg.stacks.uninitialized + +! Uninitialized stack location analysis. + +! Consider the following sequence of instructions: +! ##inc-d 2 +! _gc +! ##replace ... D 0 +! ##replace ... D 1 +! The GC check runs before stack locations 0 and 1 have been initialized, +! and it needs to zero them out so that GC doesn't try to trace them. + + ] [ prepend ] } + } cond + ] change ; + +M: ##inc-d visit-insn n>> ds-loc handle-inc ; + +M: ##inc-r visit-insn n>> rs-loc handle-inc ; + +ERROR: uninitialized-peek insn ; + +M: ##peek visit-insn + dup loc>> [ n>> ] [ class get ] bi ?nth 0 = + [ uninitialized-peek ] [ drop ] if ; + +M: ##replace visit-insn + loc>> [ n>> ] [ class get ] bi + 2dup length < [ [ 1 ] 2dip set-nth ] [ 2drop ] if ; + +M: insn visit-insn drop ; + +: prepare ( pair -- ) + [ first2 [ [ clone ] [ B{ } ] if* ] bi@ ] [ B{ } B{ } ] if* + [ ds-loc set ] [ rs-loc set ] bi* ; + +: visit-block ( bb -- ) instructions>> [ visit-insn ] each ; + +: finish ( -- pair ) ds-loc get rs-loc get 2array ; + +: (join-sets) ( seq1 seq2 -- seq ) + 2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ bitand ] 2map ; + +: (uninitialized-locs) ( seq quot -- seq' ) + [ dup length [ drop 0 = ] pusher [ 2each ] dip ] dip map ; inline + +PRIVATE> + +FORWARD-ANALYSIS: uninitialized + +M: uninitialized-analysis transfer-set ( pair bb analysis -- pair' ) + drop [ prepare ] dip visit-block finish ; + +M: uninitialized-analysis join-sets ( sets analysis -- pair ) + 2drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ; + +: uninitialized-locs ( bb -- locs ) + uninitialized-in dup [ + first2 + [ [ ] (uninitialized-locs) ] + [ [ ] (uninitialized-locs) ] + bi* append + ] when ; diff --git a/basis/compiler/cfg/tco/tco.factor b/basis/compiler/cfg/tco/tco.factor new file mode 100644 index 0000000000..810b901013 --- /dev/null +++ b/basis/compiler/cfg/tco/tco.factor @@ -0,0 +1,68 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators.short-circuit kernel math +namespaces sequences fry combinators +compiler.utilities +compiler.cfg +compiler.cfg.rpo +compiler.cfg.hats +compiler.cfg.instructions +compiler.cfg.utilities ; +IN: compiler.cfg.tco + +! Tail call optimization. + +: return? ( bb -- ? ) + skip-empty-blocks + instructions>> { + [ length 2 = ] + [ first ##epilogue? ] + [ second ##return? ] + } 1&& ; + +: tail-call? ( bb -- ? ) + { + [ instructions>> { [ length 2 >= ] [ last ##branch? ] } 1&& ] + [ successors>> first return? ] + } 1&& ; + +: word-tail-call? ( bb -- ? ) + instructions>> penultimate ##call? ; + +: convert-tail-call ( bb quot: ( insn -- tail-insn ) -- ) + '[ + instructions>> + [ pop* ] [ pop ] [ ] tri + [ [ \ ##epilogue new-insn ] dip push ] + [ _ dip push ] bi + ] + [ successors>> delete-all ] + bi ; inline + +: convert-word-tail-call ( bb -- ) + [ word>> \ ##jump new-insn ] convert-tail-call ; + +: loop-tail-call? ( bb -- ? ) + instructions>> penultimate + { [ ##call? ] [ word>> cfg get label>> eq? ] } 1&& ; + +: convert-loop-tail-call ( bb -- ) + ! If a word calls itself, this becomes a loop in the CFG. + [ instructions>> [ pop* ] [ pop* ] [ [ \ ##branch new-insn ] dip push ] tri ] + [ successors>> delete-all ] + [ [ cfg get entry>> successors>> first ] dip successors>> push ] + tri ; + +: optimize-tail-call ( bb -- ) + dup tail-call? [ + { + { [ dup loop-tail-call? ] [ convert-loop-tail-call ] } + { [ dup word-tail-call? ] [ convert-word-tail-call ] } + [ drop ] + } cond + ] [ drop ] if ; + +: optimize-tail-calls ( cfg -- cfg' ) + dup [ optimize-tail-call ] each-basic-block + + cfg-changed predecessors-changed ; \ No newline at end of file diff --git a/basis/compiler/cfg/two-operand/two-operand-tests.factor b/basis/compiler/cfg/two-operand/two-operand-tests.factor new file mode 100644 index 0000000000..09d88a2959 --- /dev/null +++ b/basis/compiler/cfg/two-operand/two-operand-tests.factor @@ -0,0 +1,52 @@ +USING: kernel compiler.cfg.two-operand compiler.cfg.instructions +compiler.cfg.registers cpu.architecture namespaces tools.test ; +IN: compiler.cfg.two-operand.tests + +3 vreg-counter set-global + +[ + V{ + T{ ##copy f 1 2 int-rep } + T{ ##sub f 1 1 3 } + } +] [ + H{ + { 1 int-rep } + { 2 int-rep } + { 3 int-rep } + } clone representations set + { + T{ ##sub f 1 2 3 } + } (convert-two-operand) +] unit-test + +[ + V{ + T{ ##copy f 1 2 double-float-rep } + T{ ##sub-float f 1 1 3 } + } +] [ + H{ + { 1 double-float-rep } + { 2 double-float-rep } + { 3 double-float-rep } + } clone representations set + { + T{ ##sub-float f 1 2 3 } + } (convert-two-operand) +] unit-test + +[ + V{ + T{ ##copy f 1 2 double-float-rep } + T{ ##mul-float f 1 1 1 } + } +] [ + H{ + { 1 double-float-rep } + { 2 double-float-rep } + } clone representations set + { + T{ ##mul-float f 1 2 2 } + } (convert-two-operand) +] unit-test diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor index d30a02b0d3..15151ff9e6 100644 --- a/basis/compiler/cfg/two-operand/two-operand.factor +++ b/basis/compiler/cfg/two-operand/two-operand.factor @@ -1,59 +1,73 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences make compiler.cfg.instructions -compiler.cfg.local cpu.architecture ; +USING: accessors kernel sequences make combinators +compiler.cfg.registers compiler.cfg.instructions +compiler.cfg.rpo cpu.architecture ; IN: compiler.cfg.two-operand -! On x86, instructions take the form x = x op y -! Our SSA IR is x = y op z - +! This pass runs before SSA coalescing and normalizes instructions +! to fit the x86 two-address scheme. Since the input is in SSA, +! it suffices to convert +! +! x = y op z +! +! to +! +! x = y +! x = x op z +! ! We don't bother with ##add, ##add-imm, ##sub-imm or ##mul-imm ! since x86 has LEA and IMUL instructions which are effectively ! three-operand addition and multiplication, respectively. -: make-copy ( dst src -- insn ) \ ##copy new-insn ; inline - -: make-copy/float ( dst src -- insn ) \ ##copy-float new-insn ; inline - -: convert-two-operand/integer ( insn -- ) - [ [ dst>> ] [ src1>> ] bi ##copy ] - [ dup dst>> >>src1 , ] - bi ; inline - -: convert-two-operand/float ( insn -- ) - [ [ dst>> ] [ src1>> ] bi ##copy-float ] - [ dup dst>> >>src1 , ] - bi ; inline +UNION: two-operand-insn + ##sub + ##mul + ##and + ##and-imm + ##or + ##or-imm + ##xor + ##xor-imm + ##shl + ##shl-imm + ##shr + ##shr-imm + ##sar + ##sar-imm + ##min + ##max + ##fixnum-overflow + ##add-float + ##sub-float + ##mul-float + ##div-float + ##min-float + ##max-float ; GENERIC: convert-two-operand* ( insn -- ) +: emit-copy ( dst src -- ) + dup rep-of ##copy ; inline + +M: two-operand-insn convert-two-operand* + [ [ dst>> ] [ src1>> ] bi emit-copy ] + [ + dup [ src1>> ] [ src2>> ] bi = [ dup dst>> >>src2 ] when + dup dst>> >>src1 , + ] bi ; + M: ##not convert-two-operand* - [ [ dst>> ] [ src>> ] bi ##copy ] + [ [ dst>> ] [ src>> ] bi emit-copy ] [ dup dst>> >>src , ] bi ; -M: ##sub convert-two-operand* convert-two-operand/integer ; -M: ##mul convert-two-operand* convert-two-operand/integer ; -M: ##and convert-two-operand* convert-two-operand/integer ; -M: ##and-imm convert-two-operand* convert-two-operand/integer ; -M: ##or convert-two-operand* convert-two-operand/integer ; -M: ##or-imm convert-two-operand* convert-two-operand/integer ; -M: ##xor convert-two-operand* convert-two-operand/integer ; -M: ##xor-imm convert-two-operand* convert-two-operand/integer ; -M: ##shl-imm convert-two-operand* convert-two-operand/integer ; -M: ##shr-imm convert-two-operand* convert-two-operand/integer ; -M: ##sar-imm convert-two-operand* convert-two-operand/integer ; - -M: ##add-float convert-two-operand* convert-two-operand/float ; -M: ##sub-float convert-two-operand* convert-two-operand/float ; -M: ##mul-float convert-two-operand* convert-two-operand/float ; -M: ##div-float convert-two-operand* convert-two-operand/float ; - M: insn convert-two-operand* , ; +: (convert-two-operand) ( insns -- insns' ) + dup first kill-vreg-insn? [ + [ [ convert-two-operand* ] each ] V{ } make + ] unless ; + : convert-two-operand ( cfg -- cfg' ) - two-operand? [ - [ drop ] - [ [ [ convert-two-operand* ] each ] V{ } make ] - local-optimization - ] when ; + two-operand? [ [ (convert-two-operand) ] local-optimization ] when ; \ No newline at end of file diff --git a/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor b/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor deleted file mode 100644 index 1d14cef193..0000000000 --- a/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor +++ /dev/null @@ -1,11 +0,0 @@ -IN: compiler.cfg.useless-blocks.tests -USING: fry kernel sequences compiler.cfg.useless-blocks compiler.cfg.checker -compiler.cfg.debugger compiler.cfg.predecessors tools.test ; - -{ - [ [ drop 1 ] when ] - [ [ drop 1 ] unless ] -} [ - [ [ ] ] dip - '[ _ test-cfg first compute-predecessors delete-useless-blocks check-cfg ] unit-test -] each \ No newline at end of file diff --git a/basis/compiler/cfg/useless-blocks/useless-blocks.factor b/basis/compiler/cfg/useless-blocks/useless-blocks.factor deleted file mode 100644 index cbe006b4d7..0000000000 --- a/basis/compiler/cfg/useless-blocks/useless-blocks.factor +++ /dev/null @@ -1,62 +0,0 @@ -! Copyright (C) 2008, 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors sequences combinators combinators.short-circuit -classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ; -IN: compiler.cfg.useless-blocks - -: update-predecessor-for-delete ( bb -- ) - ! We have to replace occurrences of bb with bb's successor - ! in bb's predecessor's list of successors. - dup predecessors>> first [ - [ - 2dup eq? [ drop successors>> first ] [ nip ] if - ] with map - ] change-successors drop ; - -: update-successor-for-delete ( bb -- ) - ! We have to replace occurrences of bb with bb's predecessor - ! in bb's sucessor's list of predecessors. - dup successors>> first [ - [ - 2dup eq? [ drop predecessors>> first ] [ nip ] if - ] with map - ] change-predecessors drop ; - -: delete-basic-block ( bb -- ) - [ update-predecessor-for-delete ] - [ update-successor-for-delete ] - bi ; - -: delete-basic-block? ( bb -- ? ) - { - [ instructions>> length 1 = ] - [ predecessors>> length 1 = ] - [ successors>> length 1 = ] - [ instructions>> first ##branch? ] - } 1&& ; - -: delete-useless-blocks ( cfg -- cfg' ) - dup [ - dup delete-basic-block? [ delete-basic-block ] [ drop ] if - ] each-basic-block - f >>post-order ; - -: delete-conditional? ( bb -- ? ) - dup instructions>> [ drop f ] [ - last class { - ##compare-branch - ##compare-imm-branch - ##compare-float-branch - } memq? [ successors>> first2 eq? ] [ drop f ] if - ] if-empty ; - -: delete-conditional ( bb -- ) - dup successors>> first 1vector >>successors - [ but-last \ ##branch new-insn suffix ] change-instructions - drop ; - -: delete-useless-conditionals ( cfg -- cfg' ) - dup [ - dup delete-conditional? [ delete-conditional ] [ drop ] if - ] each-basic-block - f >>post-order ; diff --git a/basis/compiler/cfg/useless-blocks/summary.txt b/basis/compiler/cfg/useless-conditionals/summary.txt similarity index 100% rename from basis/compiler/cfg/useless-blocks/summary.txt rename to basis/compiler/cfg/useless-conditionals/summary.txt diff --git a/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor b/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor new file mode 100644 index 0000000000..d480ad97d1 --- /dev/null +++ b/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2008, 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors sequences math combinators combinators.short-circuit +classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo +compiler.cfg.utilities ; +IN: compiler.cfg.useless-conditionals + +: delete-conditional? ( bb -- ? ) + { + [ instructions>> last class { ##compare-branch ##compare-imm-branch ##compare-float-branch } memq? ] + [ successors>> first2 [ skip-empty-blocks ] bi@ eq? ] + } 1&& ; + +: delete-conditional ( bb -- ) + [ first skip-empty-blocks 1vector ] change-successors + instructions>> [ pop* ] [ [ \ ##branch new-insn ] dip push ] bi ; + +: delete-useless-conditionals ( cfg -- cfg' ) + dup [ + dup delete-conditional? [ delete-conditional ] [ drop ] if + ] each-basic-block + + cfg-changed predecessors-changed ; diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index e415008808..bb61a63939 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -1,42 +1,81 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel math layouts make sequences combinators -cpu.architecture namespaces compiler.cfg -compiler.cfg.instructions ; +USING: accessors assocs combinators combinators.short-circuit +cpu.architecture kernel layouts locals make math namespaces sequences +sets vectors fry compiler.cfg compiler.cfg.instructions +compiler.cfg.rpo arrays ; IN: compiler.cfg.utilities -: value-info-small-fixnum? ( value-info -- ? ) - literal>> { - { [ dup fixnum? ] [ tag-fixnum small-enough? ] } - [ drop f ] - } cond ; +PREDICATE: kill-block < basic-block + instructions>> { + [ length 2 = ] + [ first kill-vreg-insn? ] + } 1&& ; -: value-info-small-tagged? ( value-info -- ? ) - dup literal?>> [ - literal>> { - { [ dup fixnum? ] [ tag-fixnum small-enough? ] } - { [ dup not ] [ drop t ] } - [ drop f ] - } cond - ] [ drop f ] if ; +: back-edge? ( from to -- ? ) + [ number>> ] bi@ >= ; -: set-basic-block ( basic-block -- ) - [ basic-block set ] [ instructions>> building set ] bi ; +: loop-entry? ( bb -- ? ) + dup predecessors>> [ swap back-edge? ] with any? ; -: begin-basic-block ( -- ) - basic-block get [ - dupd successors>> push - ] when* - set-basic-block ; +: empty-block? ( bb -- ? ) + instructions>> { + [ length 1 = ] + [ first ##branch? ] + } 1&& ; -: end-basic-block ( -- ) - building off - basic-block off ; +SYMBOL: visited -: stop-iterating ( -- next ) end-basic-block f ; +: (skip-empty-blocks) ( bb -- bb' ) + dup visited get key? [ + dup empty-block? [ + dup visited get conjoin + successors>> first (skip-empty-blocks) + ] when + ] unless ; -: call-height ( ##call -- n ) - [ out-d>> length ] [ in-d>> length ] bi - ; +: skip-empty-blocks ( bb -- bb' ) + H{ } clone visited [ (skip-empty-blocks) ] with-variable ; + +:: insert-basic-block ( froms to bb -- ) + bb froms V{ } like >>predecessors drop + bb to 1vector >>successors drop + to predecessors>> [ dup froms memq? [ drop bb ] when ] change-each + froms [ successors>> [ dup to eq? [ drop bb ] when ] change-each ] each ; + +: add-instructions ( bb quot -- ) + [ instructions>> building ] dip '[ + building get pop + [ @ ] dip + , + ] with-variable ; inline + +: ( insns -- bb ) + + swap >vector + \ ##branch new-insn over push + >>instructions ; + +: insert-simple-basic-block ( from to insns -- ) + [ 1vector ] 2dip insert-basic-block ; + +: has-phis? ( bb -- ? ) + instructions>> first ##phi? ; + +: cfg-has-phis? ( cfg -- ? ) + post-order [ has-phis? ] any? ; + +: if-has-phis ( bb quot: ( bb -- ) -- ) + [ dup has-phis? ] dip [ drop ] if ; inline + +: each-phi ( bb quot: ( ##phi -- ) -- ) + [ instructions>> ] dip + '[ dup ##phi? [ @ t ] [ drop f ] if ] all? drop ; inline + +: each-non-phi ( bb quot: ( insn -- ) -- ) + [ instructions>> ] dip + '[ dup ##phi? [ drop ] _ if ] each ; inline + +: predecessor ( bb -- pred ) + predecessors>> first ; inline -: emit-primitive ( node -- ) - [ word>> ] [ call-height ] bi ##call ##branch begin-basic-block ; diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor index bf750231c7..e8488b8afb 100644 --- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor +++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor @@ -1,37 +1,43 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors classes kernel math namespaces combinators -compiler.cfg.instructions compiler.cfg.value-numbering.graph ; +combinators.short-circuit compiler.cfg.instructions +compiler.cfg.value-numbering.graph ; IN: compiler.cfg.value-numbering.expressions ! Referentially-transparent expressions -TUPLE: expr op ; TUPLE: unary-expr < expr in ; TUPLE: binary-expr < expr in1 in2 ; TUPLE: commutative-expr < binary-expr ; TUPLE: compare-expr < binary-expr cc ; TUPLE: constant-expr < expr value ; +TUPLE: reference-expr < expr value ; +TUPLE: unary-float-function-expr < expr in func ; +TUPLE: binary-float-function-expr < expr in1 in2 func ; +TUPLE: box-displaced-alien-expr < expr displacement base base-class ; : ( constant -- expr ) f swap constant-expr boa ; inline M: constant-expr equal? over constant-expr? [ - [ [ value>> ] bi@ = ] - [ [ value>> class ] bi@ = ] 2bi - and + { + [ [ value>> class ] bi@ = ] + [ [ value>> ] bi@ = ] + } 2&& ] [ 2drop f ] if ; -! Expressions whose values are inputs to the basic block. We -! can eliminate a second computation having the same 'n' as -! the first one; we can also eliminate input-exprs whose -! result is not used. -TUPLE: input-expr < expr n ; +: ( constant -- expr ) + f swap reference-expr boa ; inline -SYMBOL: input-expr-counter - -: next-input-expr ( class -- expr ) - input-expr-counter [ dup 1 + ] change input-expr boa ; +M: reference-expr equal? + over reference-expr? [ + [ value>> ] bi@ { + { [ 2dup eq? ] [ 2drop t ] } + { [ 2dup [ float? ] both? ] [ fp-bitwise= ] } + [ 2drop f ] + } cond + ] [ 2drop f ] if ; : constant>vn ( constant -- vn ) expr>vn ; inline @@ -39,6 +45,8 @@ GENERIC: >expr ( insn -- expr ) M: ##load-immediate >expr val>> ; +M: ##load-reference >expr obj>> ; + M: ##unary >expr [ class ] [ src>> vreg>vn ] bi unary-expr boa ; @@ -80,7 +88,28 @@ M: ##compare-imm >expr compare-imm>expr ; M: ##compare-float >expr compare>expr ; -M: ##flushable >expr class next-input-expr ; +M: ##box-displaced-alien >expr + { + [ class ] + [ src1>> vreg>vn ] + [ src2>> vreg>vn ] + [ base-class>> ] + } cleave box-displaced-alien-expr boa ; + +M: ##unary-float-function >expr + [ class ] [ src>> vreg>vn ] [ func>> ] tri + unary-float-function-expr boa ; + +M: ##binary-float-function >expr + { + [ class ] + [ src1>> vreg>vn ] + [ src2>> vreg>vn ] + [ func>> ] + } cleave + binary-float-function-expr boa ; + +M: ##flushable >expr drop next-input-expr ; : init-expressions ( -- ) 0 input-expr-counter set ; diff --git a/basis/compiler/cfg/value-numbering/graph/graph.factor b/basis/compiler/cfg/value-numbering/graph/graph.factor index 7ec9eaf7ce..77b75bd3ac 100644 --- a/basis/compiler/cfg/value-numbering/graph/graph.factor +++ b/basis/compiler/cfg/value-numbering/graph/graph.factor @@ -10,13 +10,24 @@ SYMBOL: vn-counter ! biassoc mapping expressions to value numbers SYMBOL: exprs>vns +TUPLE: expr op ; + : expr>vn ( expr -- vn ) exprs>vns get [ drop next-vn ] cache ; : vn>expr ( vn -- expr ) exprs>vns get value-at ; +! Expressions whose values are inputs to the basic block. +TUPLE: input-expr < expr n ; + +SYMBOL: input-expr-counter + +: next-input-expr ( -- expr ) + f input-expr-counter counter input-expr boa ; + SYMBOL: vregs>vns -: vreg>vn ( vreg -- vn ) vregs>vns get at ; +: vreg>vn ( vreg -- vn ) + vregs>vns get [ drop next-input-expr expr>vn ] cache ; : vn>vreg ( vn -- vreg ) vregs>vns get value-at ; @@ -26,6 +37,8 @@ SYMBOL: vregs>vns : vn>constant ( vn -- constant ) vn>expr value>> ; inline +: vreg>constant ( vreg -- constant ) vreg>vn vn>constant ; inline + : init-value-graph ( -- ) 0 vn-counter set exprs>vns set diff --git a/basis/compiler/cfg/value-numbering/propagate/propagate.factor b/basis/compiler/cfg/value-numbering/propagate/propagate.factor deleted file mode 100644 index d5c9830c0b..0000000000 --- a/basis/compiler/cfg/value-numbering/propagate/propagate.factor +++ /dev/null @@ -1,69 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: namespaces assocs sequences kernel accessors -compiler.cfg.instructions compiler.cfg.value-numbering.graph ; -IN: compiler.cfg.value-numbering.propagate - -! If two vregs compute the same value, replace references to -! the latter with the former. - -: resolve ( vreg -- vreg' ) vreg>vn vn>vreg ; inline - -GENERIC: propagate ( insn -- insn ) - -M: ##effect propagate - [ resolve ] change-src ; - -M: ##unary propagate - [ resolve ] change-src ; - -M: ##binary propagate - [ resolve ] change-src1 - [ resolve ] change-src2 ; - -M: ##binary-imm propagate - [ resolve ] change-src1 ; - -M: ##slot propagate - [ resolve ] change-obj - [ resolve ] change-slot ; - -M: ##slot-imm propagate - [ resolve ] change-obj ; - -M: ##set-slot propagate - call-next-method - [ resolve ] change-obj - [ resolve ] change-slot ; - -M: ##string-nth propagate - [ resolve ] change-obj - [ resolve ] change-index ; - -M: ##set-slot-imm propagate - call-next-method - [ resolve ] change-obj ; - -M: ##alien-getter propagate - call-next-method - [ resolve ] change-src ; - -M: ##alien-setter propagate - call-next-method - [ resolve ] change-value ; - -M: ##conditional-branch propagate - [ resolve ] change-src1 - [ resolve ] change-src2 ; - -M: ##compare-imm-branch propagate - [ resolve ] change-src1 ; - -M: ##dispatch propagate - [ resolve ] change-src ; - -M: ##fixnum-overflow propagate - [ resolve ] change-src1 - [ resolve ] change-src2 ; - -M: insn propagate ; diff --git a/basis/compiler/cfg/value-numbering/propagate/summary.txt b/basis/compiler/cfg/value-numbering/propagate/summary.txt deleted file mode 100644 index fd56a8e099..0000000000 --- a/basis/compiler/cfg/value-numbering/propagate/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Propagation pass to update code after value numbering diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor old mode 100644 new mode 100755 index 7630d0a658..2662dc4665 --- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor +++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor @@ -1,26 +1,35 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences layouts accessors combinators namespaces -math fry -compiler.cfg.hats +USING: accessors combinators combinators.short-circuit arrays +fry kernel layouts math namespaces sequences cpu.architecture +math.bitwise math.order classes vectors locals make +compiler.cfg +compiler.cfg.registers +compiler.cfg.comparisons compiler.cfg.instructions +compiler.cfg.value-numbering.expressions compiler.cfg.value-numbering.graph -compiler.cfg.value-numbering.simplify -compiler.cfg.value-numbering.expressions ; +compiler.cfg.value-numbering.simplify ; IN: compiler.cfg.value-numbering.rewrite -GENERIC: rewrite ( insn -- insn' ) +: vreg-small-constant? ( vreg -- ? ) + vreg>expr { + [ constant-expr? ] + [ value>> small-enough? ] + } 1&& ; -M: ##mul-imm rewrite - dup src2>> dup power-of-2? [ - [ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* \ ##shl-imm new-insn - dup number-values - ] [ drop ] if ; +! Outputs f to mean no change + +GENERIC: rewrite ( insn -- insn/f ) + +M: insn rewrite drop f ; : ##branch-t? ( insn -- ? ) dup ##compare-imm-branch? [ - [ cc>> cc/= eq? ] - [ src2>> \ f tag-number eq? ] bi and + { + [ cc>> cc/= eq? ] + [ src2>> \ f tag-number eq? ] + } 1&& ] [ drop f ] if ; inline : rewrite-boolean-comparison? ( insn -- ? ) @@ -47,71 +56,318 @@ M: ##mul-imm rewrite : rewrite-tagged-comparison? ( insn -- ? ) #! Are we comparing two tagged fixnums? Then untag them. - [ src1>> vreg>expr tag-fixnum-expr? ] - [ src2>> tag-mask get bitand 0 = ] - bi and ; inline + { + [ src1>> vreg>expr tag-fixnum-expr? ] + [ src2>> tag-mask get bitand 0 = ] + } 1&& ; inline + +: tagged>constant ( n -- n' ) + tag-bits get neg shift ; inline : (rewrite-tagged-comparison) ( insn -- src1 src2 cc ) [ src1>> vreg>expr in1>> vn>vreg ] - [ src2>> tag-bits get neg shift ] + [ src2>> tagged>constant ] [ cc>> ] tri ; inline -GENERIC: rewrite-tagged-comparison ( insn -- insn' ) +GENERIC: rewrite-tagged-comparison ( insn -- insn/f ) M: ##compare-imm-branch rewrite-tagged-comparison (rewrite-tagged-comparison) \ ##compare-imm-branch new-insn ; M: ##compare-imm rewrite-tagged-comparison [ dst>> ] [ (rewrite-tagged-comparison) ] bi - i \ ##compare-imm new-insn ; - -M: ##compare-imm-branch rewrite - dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when - dup ##compare-imm-branch? [ - dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when - ] when ; - -: flip-comparison? ( insn -- ? ) - dup cc>> cc= eq? [ src1>> vreg>expr constant-expr? ] [ drop f ] if ; - -: flip-comparison ( insn -- insn' ) - [ dst>> ] - [ src2>> ] - [ src1>> vreg>vn vn>constant ] tri - cc= i \ ##compare-imm new-insn ; - -M: ##compare rewrite - dup flip-comparison? [ - flip-comparison - dup number-values - rewrite - ] when ; + next-vreg \ ##compare-imm new-insn ; : rewrite-redundant-comparison? ( insn -- ? ) - [ src1>> vreg>expr compare-expr? ] - [ src2>> \ f tag-number = ] - [ cc>> { cc= cc/= } memq? ] - tri and and ; inline + { + [ src1>> vreg>expr compare-expr? ] + [ src2>> \ f tag-number = ] + [ cc>> { cc= cc/= } memq? ] + } 1&& ; inline : rewrite-redundant-comparison ( insn -- insn' ) [ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri { - { \ ##compare [ >compare-expr< i \ ##compare new-insn ] } - { \ ##compare-imm [ >compare-imm-expr< i \ ##compare-imm new-insn ] } - { \ ##compare-float [ >compare-expr< i \ ##compare-float new-insn ] } + { \ ##compare [ >compare-expr< next-vreg \ ##compare new-insn ] } + { \ ##compare-imm [ >compare-imm-expr< next-vreg \ ##compare-imm new-insn ] } + { \ ##compare-float [ >compare-expr< next-vreg \ ##compare-float new-insn ] } } case swap cc= eq? [ [ negate-cc ] change-cc ] when ; -M: ##compare-imm rewrite - dup rewrite-redundant-comparison? [ - rewrite-redundant-comparison - dup number-values rewrite - ] when - dup ##compare-imm? [ - dup rewrite-tagged-comparison? [ - rewrite-tagged-comparison - dup number-values rewrite - ] when - ] when ; +ERROR: bad-comparison ; -M: insn rewrite ; +: (fold-compare-imm) ( insn -- ? ) + [ [ src1>> vreg>constant ] [ src2>> ] bi ] [ cc>> ] bi + pick integer? + [ [ <=> ] dip evaluate-cc ] + [ + 2nip { + { cc= [ f ] } + { cc/= [ t ] } + [ bad-comparison ] + } case + ] if ; + +: fold-compare-imm? ( insn -- ? ) + src1>> vreg>expr [ constant-expr? ] [ reference-expr? ] bi or ; + +: fold-branch ( ? -- insn ) + 0 1 ? + basic-block get [ nth 1vector ] change-successors drop + \ ##branch new-insn ; + +: fold-compare-imm-branch ( insn -- insn/f ) + (fold-compare-imm) fold-branch ; + +M: ##compare-imm-branch rewrite + { + { [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] } + { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] } + { [ dup fold-compare-imm? ] [ fold-compare-imm-branch ] } + [ drop f ] + } cond ; + +: swap-compare ( src1 src2 cc swap? -- src1 src2 cc ) + [ [ swap ] dip swap-cc ] when ; inline + +: >compare-imm-branch ( insn swap? -- insn' ) + [ + [ src1>> ] + [ src2>> ] + [ cc>> ] + tri + ] dip + swap-compare + [ vreg>constant ] dip + \ ##compare-imm-branch new-insn ; inline + +: self-compare? ( insn -- ? ) + [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ = ; inline + +: (rewrite-self-compare) ( insn -- ? ) + cc>> { cc= cc<= cc>= } memq? ; + +: rewrite-self-compare-branch ( insn -- insn' ) + (rewrite-self-compare) fold-branch ; + +M: ##compare-branch rewrite + { + { [ dup src1>> vreg-small-constant? ] [ t >compare-imm-branch ] } + { [ dup src2>> vreg-small-constant? ] [ f >compare-imm-branch ] } + { [ dup self-compare? ] [ rewrite-self-compare-branch ] } + [ drop f ] + } cond ; + +: >compare-imm ( insn swap? -- insn' ) + [ + { + [ dst>> ] + [ src1>> ] + [ src2>> ] + [ cc>> ] + } cleave + ] dip + swap-compare + [ vreg>constant ] dip + next-vreg \ ##compare-imm new-insn ; inline + +: >boolean-insn ( insn ? -- insn' ) + [ dst>> ] dip + { + { t [ t \ ##load-reference new-insn ] } + { f [ \ f tag-number \ ##load-immediate new-insn ] } + } case ; + +: rewrite-self-compare ( insn -- insn' ) + dup (rewrite-self-compare) >boolean-insn ; + +M: ##compare rewrite + { + { [ dup src1>> vreg-small-constant? ] [ t >compare-imm ] } + { [ dup src2>> vreg-small-constant? ] [ f >compare-imm ] } + { [ dup self-compare? ] [ rewrite-self-compare ] } + [ drop f ] + } cond ; + +: fold-compare-imm ( insn -- insn' ) + dup (fold-compare-imm) >boolean-insn ; + +M: ##compare-imm rewrite + { + { [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] } + { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] } + { [ dup fold-compare-imm? ] [ fold-compare-imm ] } + [ drop f ] + } cond ; + +: constant-fold? ( insn -- ? ) + src1>> vreg>expr constant-expr? ; inline + +GENERIC: constant-fold* ( x y insn -- z ) + +M: ##add-imm constant-fold* drop + ; +M: ##sub-imm constant-fold* drop - ; +M: ##mul-imm constant-fold* drop * ; +M: ##and-imm constant-fold* drop bitand ; +M: ##or-imm constant-fold* drop bitor ; +M: ##xor-imm constant-fold* drop bitxor ; +M: ##shr-imm constant-fold* drop [ cell-bits 2^ wrap ] dip neg shift ; +M: ##sar-imm constant-fold* drop neg shift ; +M: ##shl-imm constant-fold* drop shift ; + +: constant-fold ( insn -- insn' ) + [ dst>> ] + [ [ src1>> vreg>constant ] [ src2>> ] [ ] tri constant-fold* ] bi + \ ##load-immediate new-insn ; inline + +: reassociate? ( insn -- ? ) + [ src1>> vreg>expr op>> ] [ class ] bi = ; inline + +: reassociate ( insn op -- insn ) + [ + { + [ dst>> ] + [ src1>> vreg>expr [ in1>> vn>vreg ] [ in2>> vn>constant ] bi ] + [ src2>> ] + [ ] + } cleave constant-fold* + ] dip + over small-enough? [ new-insn ] [ 2drop 2drop f ] if ; inline + +M: ##add-imm rewrite + { + { [ dup constant-fold? ] [ constant-fold ] } + { [ dup reassociate? ] [ \ ##add-imm reassociate ] } + [ drop f ] + } cond ; + +: sub-imm>add-imm ( insn -- insn' ) + [ dst>> ] [ src1>> ] [ src2>> neg ] tri dup small-enough? + [ \ ##add-imm new-insn ] [ 3drop f ] if ; + +M: ##sub-imm rewrite + { + { [ dup constant-fold? ] [ constant-fold ] } + [ sub-imm>add-imm ] + } cond ; + +: strength-reduce-mul ( insn -- insn' ) + [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ; + +: strength-reduce-mul? ( insn -- ? ) + src2>> power-of-2? ; + +M: ##mul-imm rewrite + { + { [ dup constant-fold? ] [ constant-fold ] } + { [ dup strength-reduce-mul? ] [ strength-reduce-mul ] } + { [ dup reassociate? ] [ \ ##mul-imm reassociate ] } + [ drop f ] + } cond ; + +M: ##and-imm rewrite + { + { [ dup constant-fold? ] [ constant-fold ] } + { [ dup reassociate? ] [ \ ##and-imm reassociate ] } + [ drop f ] + } cond ; + +M: ##or-imm rewrite + { + { [ dup constant-fold? ] [ constant-fold ] } + { [ dup reassociate? ] [ \ ##or-imm reassociate ] } + [ drop f ] + } cond ; + +M: ##xor-imm rewrite + { + { [ dup constant-fold? ] [ constant-fold ] } + { [ dup reassociate? ] [ \ ##xor-imm reassociate ] } + [ drop f ] + } cond ; + +M: ##shl-imm rewrite + { + { [ dup constant-fold? ] [ constant-fold ] } + [ drop f ] + } cond ; + +M: ##shr-imm rewrite + { + { [ dup constant-fold? ] [ constant-fold ] } + [ drop f ] + } cond ; + +M: ##sar-imm rewrite + { + { [ dup constant-fold? ] [ constant-fold ] } + [ drop f ] + } cond ; + +: insn>imm-insn ( insn op swap? -- ) + swap [ + [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] dip + [ swap ] when vreg>constant + ] dip new-insn ; inline + +: rewrite-arithmetic ( insn op -- ? ) + { + { [ over src2>> vreg-small-constant? ] [ f insn>imm-insn ] } + [ 2drop f ] + } cond ; inline + +: rewrite-arithmetic-commutative ( insn op -- ? ) + { + { [ over src2>> vreg-small-constant? ] [ f insn>imm-insn ] } + { [ over src1>> vreg-small-constant? ] [ t insn>imm-insn ] } + [ 2drop f ] + } cond ; inline + +M: ##add rewrite \ ##add-imm rewrite-arithmetic-commutative ; + +: subtraction-identity? ( insn -- ? ) + [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ eq? ; + +: rewrite-subtraction-identity ( insn -- insn' ) + dst>> 0 \ ##load-immediate new-insn ; + +M: ##sub rewrite + { + { [ dup subtraction-identity? ] [ rewrite-subtraction-identity ] } + [ \ ##sub-imm rewrite-arithmetic ] + } cond ; + +M: ##mul rewrite \ ##mul-imm rewrite-arithmetic-commutative ; + +M: ##and rewrite \ ##and-imm rewrite-arithmetic-commutative ; + +M: ##or rewrite \ ##or-imm rewrite-arithmetic-commutative ; + +M: ##xor rewrite \ ##xor-imm rewrite-arithmetic-commutative ; + +M: ##shl rewrite \ ##shl-imm rewrite-arithmetic ; + +M: ##shr rewrite \ ##shr-imm rewrite-arithmetic ; + +M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ; + +: box-displaced-alien? ( expr -- ? ) + op>> \ ##box-displaced-alien eq? ; + +! ##box-displaced-alien f 1 2 3 +! ##unbox-c-ptr 4 1 +! => +! ##box-displaced-alien f 1 2 3 +! ##unbox-c-ptr 5 3 +! ##add 4 5 2 + +:: rewrite-unbox-displaced-alien ( insn expr -- insns ) + [ + next-vreg :> temp + temp expr base>> vn>vreg expr base-class>> insn temp>> ##unbox-c-ptr + insn dst>> temp expr displacement>> vn>vreg ##add + ] { } make ; + +M: ##unbox-any-c-ptr rewrite + dup src>> vreg>expr dup box-displaced-alien? + [ rewrite-unbox-displaced-alien ] [ 2drop f ] if ; diff --git a/basis/compiler/cfg/value-numbering/simplify/simplify.factor b/basis/compiler/cfg/value-numbering/simplify/simplify.factor index e70ba4b54b..6508801840 100644 --- a/basis/compiler/cfg/value-numbering/simplify/simplify.factor +++ b/basis/compiler/cfg/value-numbering/simplify/simplify.factor @@ -3,28 +3,20 @@ USING: kernel accessors combinators classes math layouts compiler.cfg.instructions compiler.cfg.value-numbering.graph -compiler.cfg.value-numbering.expressions ; +compiler.cfg.value-numbering.expressions locals ; IN: compiler.cfg.value-numbering.simplify ! Return value of f means we didn't simplify. GENERIC: simplify* ( expr -- vn/expr/f ) -: simplify-unbox ( in boxer -- vn/expr/f ) - over op>> eq? [ in>> ] [ drop f ] if ; inline - -: simplify-unbox-float ( in -- vn/expr/f ) - \ ##box-float simplify-unbox ; inline - : simplify-unbox-alien ( in -- vn/expr/f ) - \ ##box-alien simplify-unbox ; inline + dup op>> \ ##box-alien eq? [ in>> ] [ drop f ] if ; inline M: unary-expr simplify* #! Note the copy propagation: a copy always simplifies to #! its source VN. [ in>> vn>expr ] [ op>> ] bi { { \ ##copy [ ] } - { \ ##copy-float [ ] } - { \ ##unbox-float [ simplify-unbox-float ] } { \ ##unbox-alien [ simplify-unbox-alien ] } { \ ##unbox-any-c-ptr [ simplify-unbox-alien ] } [ 2drop f ] @@ -32,6 +24,8 @@ M: unary-expr simplify* : expr-zero? ( expr -- ? ) T{ constant-expr f f 0 } = ; inline +: expr-one? ( expr -- ? ) T{ constant-expr f f 1 } = ; inline + : >binary-expr< ( expr -- in1 in2 ) [ in1>> vn>expr ] [ in2>> vn>expr ] bi ; inline @@ -42,23 +36,86 @@ M: unary-expr simplify* [ 2drop f ] } cond ; inline -: useless-shift? ( in1 in2 -- ? ) +: simplify-sub ( expr -- vn/expr/f ) + >binary-expr< { + { [ dup expr-zero? ] [ drop ] } + [ 2drop f ] + } cond ; inline + +: simplify-mul ( expr -- vn/expr/f ) + >binary-expr< { + { [ over expr-one? ] [ drop ] } + { [ dup expr-one? ] [ drop ] } + [ 2drop f ] + } cond ; inline + +: simplify-and ( expr -- vn/expr/f ) + >binary-expr< { + { [ 2dup eq? ] [ drop ] } + [ 2drop f ] + } cond ; inline + +: simplify-or ( expr -- vn/expr/f ) + >binary-expr< { + { [ 2dup eq? ] [ drop ] } + { [ over expr-zero? ] [ nip ] } + { [ dup expr-zero? ] [ drop ] } + [ 2drop f ] + } cond ; inline + +: simplify-xor ( expr -- vn/expr/f ) + >binary-expr< { + { [ over expr-zero? ] [ nip ] } + { [ dup expr-zero? ] [ drop ] } + [ 2drop f ] + } cond ; inline + +: useless-shr? ( in1 in2 -- ? ) over op>> \ ##shl-imm eq? [ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline -: simplify-shift ( expr -- vn/expr/f ) - >binary-expr< - 2dup useless-shift? [ drop in1>> ] [ 2drop f ] if ; inline +: simplify-shr ( expr -- vn/expr/f ) + >binary-expr< { + { [ 2dup useless-shr? ] [ drop in1>> ] } + { [ dup expr-zero? ] [ drop ] } + [ 2drop f ] + } cond ; inline + +: simplify-shl ( expr -- vn/expr/f ) + >binary-expr< { + { [ dup expr-zero? ] [ drop ] } + [ 2drop f ] + } cond ; inline M: binary-expr simplify* dup op>> { { \ ##add [ simplify-add ] } { \ ##add-imm [ simplify-add ] } - { \ ##shr-imm [ simplify-shift ] } - { \ ##sar-imm [ simplify-shift ] } + { \ ##sub [ simplify-sub ] } + { \ ##sub-imm [ simplify-sub ] } + { \ ##mul [ simplify-mul ] } + { \ ##mul-imm [ simplify-mul ] } + { \ ##and [ simplify-and ] } + { \ ##and-imm [ simplify-and ] } + { \ ##or [ simplify-or ] } + { \ ##or-imm [ simplify-or ] } + { \ ##xor [ simplify-xor ] } + { \ ##xor-imm [ simplify-xor ] } + { \ ##shr [ simplify-shr ] } + { \ ##shr-imm [ simplify-shr ] } + { \ ##sar [ simplify-shr ] } + { \ ##sar-imm [ simplify-shr ] } + { \ ##shl [ simplify-shl ] } + { \ ##shl-imm [ simplify-shl ] } [ 2drop f ] } case ; +M: box-displaced-alien-expr simplify* + [ base>> ] [ displacement>> ] bi { + { [ dup vn>expr expr-zero? ] [ drop ] } + [ 2drop f ] + } cond ; + M: expr simplify* drop f ; : simplify ( expr -- vn ) @@ -68,7 +125,5 @@ M: expr simplify* drop f ; { [ dup integer? ] [ nip ] } } cond ; -GENERIC: number-values ( insn -- ) - -M: ##flushable number-values [ >expr simplify ] [ dst>> ] bi set-vn ; -M: insn number-values drop ; +: number-values ( insn -- ) + [ >expr simplify ] [ dst>> ] bi set-vn ; diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index 5063273bf4..ab9b9f26c7 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -1,8 +1,11 @@ -IN: compiler.cfg.value-numbering.tests USING: compiler.cfg.value-numbering compiler.cfg.instructions -compiler.cfg.registers compiler.cfg.debugger cpu.architecture -tools.test kernel math combinators.short-circuit accessors -sequences compiler.cfg vectors arrays ; +compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons +cpu.architecture tools.test kernel math combinators.short-circuit +accessors sequences compiler.cfg.predecessors locals compiler.cfg.dce +compiler.cfg.ssa.destruction compiler.cfg.loop-detection +compiler.cfg.representations compiler.cfg assocs vectors arrays +layouts namespaces alien ; +IN: compiler.cfg.value-numbering.tests : trim-temps ( insns -- insns ) [ @@ -13,159 +16,1346 @@ sequences compiler.cfg vectors arrays ; } 1|| [ f >>temp ] when ] map ; -: test-value-numbering ( insns -- insns ) - { } init-value-numbering - value-numbering-step ; - +! Folding constants together [ { - T{ ##peek f V int-regs 45 D 1 } - T{ ##copy f V int-regs 48 V int-regs 45 } - T{ ##compare-imm-branch f V int-regs 45 7 cc/= } + T{ ##load-reference f 0 0.0 } + T{ ##load-reference f 1 -0.0 } + T{ ##replace f 0 D 0 } + T{ ##replace f 1 D 1 } } ] [ { - T{ ##peek f V int-regs 45 D 1 } - T{ ##copy f V int-regs 48 V int-regs 45 } - T{ ##compare-imm-branch f V int-regs 48 7 cc/= } - } test-value-numbering -] unit-test - -[ - { - T{ ##load-immediate f V int-regs 2 8 } - T{ ##peek f V int-regs 3 D 0 } - T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 } - T{ ##replace f V int-regs 4 D 0 } - } -] [ - { - T{ ##load-immediate f V int-regs 2 8 } - T{ ##peek f V int-regs 3 D 0 } - T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 } - T{ ##replace f V int-regs 4 D 0 } - } test-value-numbering -] unit-test - -[ t ] [ - { - T{ ##peek f V int-regs 1 D 0 } - T{ ##dispatch f V int-regs 1 V int-regs 2 } - } dup test-value-numbering = -] unit-test - -[ t ] [ - { - T{ ##peek f V int-regs 16 D 0 } - T{ ##peek f V int-regs 17 D -1 } - T{ ##sar-imm f V int-regs 18 V int-regs 17 3 } - T{ ##add-imm f V int-regs 19 V int-regs 16 13 } - T{ ##add f V int-regs 21 V int-regs 18 V int-regs 19 } - T{ ##alien-unsigned-1 f V int-regs 22 V int-regs 21 } - T{ ##shl-imm f V int-regs 23 V int-regs 22 3 } - T{ ##replace f V int-regs 23 D 0 } - } dup test-value-numbering = -] unit-test - -[ - { - T{ ##peek f V int-regs 1 D 0 } - T{ ##shl-imm f V int-regs 2 V int-regs 1 3 } - T{ ##shr-imm f V int-regs 3 V int-regs 2 3 } - T{ ##replace f V int-regs 1 D 0 } - } -] [ - { - T{ ##peek f V int-regs 1 D 0 } - T{ ##mul-imm f V int-regs 2 V int-regs 1 8 } - T{ ##shr-imm f V int-regs 3 V int-regs 2 3 } - T{ ##replace f V int-regs 3 D 0 } - } test-value-numbering -] unit-test - -[ - { - T{ ##load-reference f V int-regs 1 + } - T{ ##peek f V int-regs 2 D 0 } - T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> } - T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> } - T{ ##replace f V int-regs 4 D 0 } - } -] [ - { - T{ ##load-reference f V int-regs 1 + } - T{ ##peek f V int-regs 2 D 0 } - T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> } - T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc/= } - T{ ##replace f V int-regs 6 D 0 } - } test-value-numbering trim-temps -] unit-test - -[ - { - T{ ##load-reference f V int-regs 1 + } - T{ ##peek f V int-regs 2 D 0 } - T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= } - T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> } - T{ ##replace f V int-regs 6 D 0 } - } -] [ - { - T{ ##load-reference f V int-regs 1 + } - T{ ##peek f V int-regs 2 D 0 } - T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= } - T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc= } - T{ ##replace f V int-regs 6 D 0 } - } test-value-numbering trim-temps -] unit-test - -[ - { - T{ ##peek f V int-regs 8 D 0 } - T{ ##peek f V int-regs 9 D -1 } - T{ ##unbox-float f V double-float-regs 10 V int-regs 8 } - T{ ##unbox-float f V double-float-regs 11 V int-regs 9 } - T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< } - T{ ##compare-float f V int-regs 14 V double-float-regs 10 V double-float-regs 11 cc>= } - T{ ##replace f V int-regs 14 D 0 } - } -] [ - { - T{ ##peek f V int-regs 8 D 0 } - T{ ##peek f V int-regs 9 D -1 } - T{ ##unbox-float f V double-float-regs 10 V int-regs 8 } - T{ ##unbox-float f V double-float-regs 11 V int-regs 9 } - T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< } - T{ ##compare-imm f V int-regs 14 V int-regs 12 5 cc= } - T{ ##replace f V int-regs 14 D 0 } - } test-value-numbering trim-temps -] unit-test - -[ - { - T{ ##peek f V int-regs 29 D -1 } - T{ ##peek f V int-regs 30 D -2 } - T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= } - T{ ##compare-branch f V int-regs 29 V int-regs 30 cc<= } - } -] [ - { - T{ ##peek f V int-regs 29 D -1 } - T{ ##peek f V int-regs 30 D -2 } - T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= } - T{ ##compare-imm-branch f V int-regs 33 5 cc/= } - } test-value-numbering trim-temps -] unit-test - -[ - { - T{ ##copy f V int-regs 48 V int-regs 45 } - T{ ##compare-imm-branch f V int-regs 45 7 cc/= } - } -] [ - { V int-regs 45 } init-value-numbering - { - T{ ##copy f V int-regs 48 V int-regs 45 } - T{ ##compare-imm-branch f V int-regs 48 7 cc/= } + T{ ##load-reference f 0 0.0 } + T{ ##load-reference f 1 -0.0 } + T{ ##replace f 0 D 0 } + T{ ##replace f 1 D 1 } } value-numbering-step ] unit-test + +[ + { + T{ ##load-reference f 0 0.0 } + T{ ##copy f 1 0 any-rep } + T{ ##replace f 0 D 0 } + T{ ##replace f 1 D 1 } + } +] [ + { + T{ ##load-reference f 0 0.0 } + T{ ##load-reference f 1 0.0 } + T{ ##replace f 0 D 0 } + T{ ##replace f 1 D 1 } + } value-numbering-step +] unit-test + +[ + { + T{ ##load-reference f 0 t } + T{ ##copy f 1 0 any-rep } + T{ ##replace f 0 D 0 } + T{ ##replace f 1 D 1 } + } +] [ + { + T{ ##load-reference f 0 t } + T{ ##load-reference f 1 t } + T{ ##replace f 0 D 0 } + T{ ##replace f 1 D 1 } + } value-numbering-step +] unit-test + +! Compare propagation +[ + { + T{ ##load-reference f 1 + } + T{ ##peek f 2 D 0 } + T{ ##compare f 4 2 1 cc> } + T{ ##copy f 6 4 any-rep } + T{ ##replace f 6 D 0 } + } +] [ + { + T{ ##load-reference f 1 + } + T{ ##peek f 2 D 0 } + T{ ##compare f 4 2 1 cc> } + T{ ##compare-imm f 6 4 5 cc/= } + T{ ##replace f 6 D 0 } + } value-numbering-step trim-temps +] unit-test + +[ + { + T{ ##load-reference f 1 + } + T{ ##peek f 2 D 0 } + T{ ##compare f 4 2 1 cc<= } + T{ ##compare f 6 2 1 cc/<= } + T{ ##replace f 6 D 0 } + } +] [ + { + T{ ##load-reference f 1 + } + T{ ##peek f 2 D 0 } + T{ ##compare f 4 2 1 cc<= } + T{ ##compare-imm f 6 4 5 cc= } + T{ ##replace f 6 D 0 } + } value-numbering-step trim-temps +] unit-test + +[ + { + T{ ##peek f 8 D 0 } + T{ ##peek f 9 D -1 } + T{ ##unbox-float f 10 8 } + T{ ##unbox-float f 11 9 } + T{ ##compare-float f 12 10 11 cc< } + T{ ##compare-float f 14 10 11 cc/< } + T{ ##replace f 14 D 0 } + } +] [ + { + T{ ##peek f 8 D 0 } + T{ ##peek f 9 D -1 } + T{ ##unbox-float f 10 8 } + T{ ##unbox-float f 11 9 } + T{ ##compare-float f 12 10 11 cc< } + T{ ##compare-imm f 14 12 5 cc= } + T{ ##replace f 14 D 0 } + } value-numbering-step trim-temps +] unit-test + +[ + { + T{ ##peek f 29 D -1 } + T{ ##peek f 30 D -2 } + T{ ##compare f 33 29 30 cc<= } + T{ ##compare-branch f 29 30 cc<= } + } +] [ + { + T{ ##peek f 29 D -1 } + T{ ##peek f 30 D -2 } + T{ ##compare f 33 29 30 cc<= } + T{ ##compare-imm-branch f 33 5 cc/= } + } value-numbering-step trim-temps +] unit-test + +! Immediate operand conversion +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##add-imm f 2 0 100 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##add f 2 0 1 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##add-imm f 2 0 100 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##add f 2 1 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##add-imm f 2 0 -100 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##sub f 2 0 1 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##sub f 1 0 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##mul-imm f 2 0 100 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##mul f 2 0 1 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##mul-imm f 2 0 100 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##mul f 2 1 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 1 D 0 } + T{ ##shl-imm f 2 1 3 } + } +] [ + { + T{ ##peek f 1 D 0 } + T{ ##mul-imm f 2 1 8 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##and-imm f 2 0 100 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##and f 2 0 1 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##and-imm f 2 0 100 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##and f 2 1 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##or-imm f 2 0 100 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##or f 2 0 1 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##or-imm f 2 0 100 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##or f 2 1 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##xor-imm f 2 0 100 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##xor f 2 0 1 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##xor-imm f 2 0 100 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##xor f 2 1 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##compare-imm f 2 0 100 cc<= } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##compare f 2 0 1 cc<= } + } value-numbering-step trim-temps +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##compare-imm f 2 0 100 cc>= } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##compare f 2 1 0 cc<= } + } value-numbering-step trim-temps +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##compare-imm-branch f 0 100 cc<= } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##compare-branch f 0 1 cc<= } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##compare-imm-branch f 0 100 cc>= } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##compare-branch f 1 0 cc<= } + } value-numbering-step trim-temps +] unit-test + +! Reassociation +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##add-imm f 2 0 100 } + T{ ##load-immediate f 3 50 } + T{ ##add-imm f 4 0 150 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##add f 2 0 1 } + T{ ##load-immediate f 3 50 } + T{ ##add f 4 2 3 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##add-imm f 2 0 100 } + T{ ##load-immediate f 3 50 } + T{ ##add-imm f 4 0 150 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##add f 2 1 0 } + T{ ##load-immediate f 3 50 } + T{ ##add f 4 3 2 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##add-imm f 2 0 100 } + T{ ##load-immediate f 3 50 } + T{ ##add-imm f 4 0 50 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##add f 2 0 1 } + T{ ##load-immediate f 3 50 } + T{ ##sub f 4 2 3 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##add-imm f 2 0 -100 } + T{ ##load-immediate f 3 50 } + T{ ##add-imm f 4 0 -150 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##sub f 2 0 1 } + T{ ##load-immediate f 3 50 } + T{ ##sub f 4 2 3 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##mul-imm f 2 0 100 } + T{ ##load-immediate f 3 50 } + T{ ##mul-imm f 4 0 5000 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##mul f 2 0 1 } + T{ ##load-immediate f 3 50 } + T{ ##mul f 4 2 3 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##mul-imm f 2 0 100 } + T{ ##load-immediate f 3 50 } + T{ ##mul-imm f 4 0 5000 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##mul f 2 1 0 } + T{ ##load-immediate f 3 50 } + T{ ##mul f 4 3 2 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##and-imm f 2 0 100 } + T{ ##load-immediate f 3 50 } + T{ ##and-imm f 4 0 32 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##and f 2 0 1 } + T{ ##load-immediate f 3 50 } + T{ ##and f 4 2 3 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##and-imm f 2 0 100 } + T{ ##load-immediate f 3 50 } + T{ ##and-imm f 4 0 32 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##and f 2 1 0 } + T{ ##load-immediate f 3 50 } + T{ ##and f 4 3 2 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##or-imm f 2 0 100 } + T{ ##load-immediate f 3 50 } + T{ ##or-imm f 4 0 118 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##or f 2 0 1 } + T{ ##load-immediate f 3 50 } + T{ ##or f 4 2 3 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##or-imm f 2 0 100 } + T{ ##load-immediate f 3 50 } + T{ ##or-imm f 4 0 118 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##or f 2 1 0 } + T{ ##load-immediate f 3 50 } + T{ ##or f 4 3 2 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##xor-imm f 2 0 100 } + T{ ##load-immediate f 3 50 } + T{ ##xor-imm f 4 0 86 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##xor f 2 0 1 } + T{ ##load-immediate f 3 50 } + T{ ##xor f 4 2 3 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##xor-imm f 2 0 100 } + T{ ##load-immediate f 3 50 } + T{ ##xor-imm f 4 0 86 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 100 } + T{ ##xor f 2 1 0 } + T{ ##load-immediate f 3 50 } + T{ ##xor f 4 3 2 } + } value-numbering-step +] unit-test + +! Simplification +[ + { + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##load-immediate f 2 0 } + T{ ##copy f 3 0 any-rep } + T{ ##replace f 3 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##sub f 2 1 1 } + T{ ##add f 3 0 2 } + T{ ##replace f 3 D 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##load-immediate f 2 0 } + T{ ##copy f 3 0 any-rep } + T{ ##replace f 3 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##sub f 2 1 1 } + T{ ##sub f 3 0 2 } + T{ ##replace f 3 D 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##load-immediate f 2 0 } + T{ ##copy f 3 0 any-rep } + T{ ##replace f 3 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##sub f 2 1 1 } + T{ ##or f 3 0 2 } + T{ ##replace f 3 D 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##load-immediate f 2 0 } + T{ ##copy f 3 0 any-rep } + T{ ##replace f 3 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##peek f 1 D 1 } + T{ ##sub f 2 1 1 } + T{ ##xor f 3 0 2 } + T{ ##replace f 3 D 0 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 1 } + T{ ##copy f 2 0 any-rep } + T{ ##replace f 2 D 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 1 } + T{ ##mul f 2 0 1 } + T{ ##replace f 2 D 0 } + } value-numbering-step +] unit-test + +! Constant folding +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 3 } + T{ ##load-immediate f 3 4 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 3 } + T{ ##add f 3 1 2 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 3 } + T{ ##load-immediate f 3 -2 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 3 } + T{ ##sub f 3 1 2 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 2 } + T{ ##load-immediate f 2 3 } + T{ ##load-immediate f 3 6 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 2 } + T{ ##load-immediate f 2 3 } + T{ ##mul f 3 1 2 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 2 } + T{ ##load-immediate f 2 1 } + T{ ##load-immediate f 3 0 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 2 } + T{ ##load-immediate f 2 1 } + T{ ##and f 3 1 2 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 2 } + T{ ##load-immediate f 2 1 } + T{ ##load-immediate f 3 3 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 2 } + T{ ##load-immediate f 2 1 } + T{ ##or f 3 1 2 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 2 } + T{ ##load-immediate f 2 3 } + T{ ##load-immediate f 3 1 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 2 } + T{ ##load-immediate f 2 3 } + T{ ##xor f 3 1 2 } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 3 8 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 1 } + T{ ##shl-imm f 3 1 3 } + } value-numbering-step +] unit-test + +cell 8 = [ + [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 -1 } + T{ ##load-immediate f 3 HEX: ffffffffffff } + } + ] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 -1 } + T{ ##shr-imm f 3 1 16 } + } value-numbering-step + ] unit-test +] when + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 -8 } + T{ ##load-immediate f 3 -4 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 -8 } + T{ ##sar-imm f 3 1 1 } + } value-numbering-step +] unit-test + +cell 8 = [ + [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 65536 } + T{ ##load-immediate f 2 140737488355328 } + T{ ##add f 3 0 2 } + } + ] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 65536 } + T{ ##shl-imm f 2 1 31 } + T{ ##add f 3 0 2 } + } value-numbering-step + ] unit-test + + [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 2 140737488355328 } + T{ ##add f 3 0 2 } + } + ] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 2 140737488355328 } + T{ ##add f 3 0 2 } + } value-numbering-step + ] unit-test + + [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 2 2147483647 } + T{ ##add-imm f 3 0 2147483647 } + T{ ##add-imm f 4 3 2147483647 } + } + ] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 2 2147483647 } + T{ ##add f 3 0 2 } + T{ ##add f 4 3 2 } + } value-numbering-step + ] unit-test +] when + +! Displaced alien optimizations +3 vreg-counter set-global + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 2 16 } + T{ ##box-displaced-alien f 1 2 0 c-ptr } + T{ ##unbox-any-c-ptr f 4 0 } + T{ ##add-imm f 3 4 16 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 2 16 } + T{ ##box-displaced-alien f 1 2 0 c-ptr } + T{ ##unbox-any-c-ptr f 3 1 } + } value-numbering-step +] unit-test + +4 vreg-counter set-global + +[ + { + T{ ##box-alien f 0 1 } + T{ ##load-immediate f 2 16 } + T{ ##box-displaced-alien f 3 2 0 c-ptr } + T{ ##copy f 5 1 any-rep } + T{ ##add-imm f 4 5 16 } + } +] [ + { + T{ ##box-alien f 0 1 } + T{ ##load-immediate f 2 16 } + T{ ##box-displaced-alien f 3 2 0 c-ptr } + T{ ##unbox-any-c-ptr f 4 3 } + } value-numbering-step +] unit-test + +3 vreg-counter set-global + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 2 0 } + T{ ##copy f 3 0 any-rep } + T{ ##replace f 3 D 1 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 2 0 } + T{ ##box-displaced-alien f 3 2 0 c-ptr } + T{ ##replace f 3 D 1 } + } value-numbering-step +] unit-test + +! Branch folding +[ + { + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##load-immediate f 3 5 } + } +] [ + { + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##compare f 3 1 2 cc= } + } value-numbering-step +] unit-test + +[ + { + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##load-reference f 3 t } + } +] [ + { + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##compare f 3 1 2 cc/= } + } value-numbering-step +] unit-test + +[ + { + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##load-reference f 3 t } + } +] [ + { + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##compare f 3 1 2 cc< } + } value-numbering-step +] unit-test + +[ + { + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##load-immediate f 3 5 } + } +] [ + { + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##compare f 3 2 1 cc< } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 5 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##compare f 1 0 0 cc< } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-reference f 1 t } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##compare f 1 0 0 cc<= } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 5 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##compare f 1 0 0 cc> } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-reference f 1 t } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##compare f 1 0 0 cc>= } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-immediate f 1 5 } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##compare f 1 0 0 cc/= } + } value-numbering-step +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-reference f 1 t } + } +] [ + { + T{ ##peek f 0 D 0 } + T{ ##compare f 1 0 0 cc= } + } value-numbering-step +] unit-test + +: test-branch-folding ( insns -- insns' n ) + + [ V{ 0 1 } clone >>successors basic-block set value-numbering-step ] keep + successors>> first ; + +[ + { + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##branch } + } + 1 +] [ + { + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##compare-branch f 1 2 cc= } + } test-branch-folding +] unit-test + +[ + { + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##branch } + } + 0 +] [ + { + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##compare-branch f 1 2 cc/= } + } test-branch-folding +] unit-test + +[ + { + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##branch } + } + 0 +] [ + { + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##compare-branch f 1 2 cc< } + } test-branch-folding +] unit-test + +[ + { + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##branch } + } + 1 +] [ + { + T{ ##load-immediate f 1 1 } + T{ ##load-immediate f 2 2 } + T{ ##compare-branch f 2 1 cc< } + } test-branch-folding +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##branch } + } + 1 +] [ + { + T{ ##peek f 0 D 0 } + T{ ##compare-branch f 0 0 cc< } + } test-branch-folding +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##branch } + } + 0 +] [ + { + T{ ##peek f 0 D 0 } + T{ ##compare-branch f 0 0 cc<= } + } test-branch-folding +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##branch } + } + 1 +] [ + { + T{ ##peek f 0 D 0 } + T{ ##compare-branch f 0 0 cc> } + } test-branch-folding +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##branch } + } + 0 +] [ + { + T{ ##peek f 0 D 0 } + T{ ##compare-branch f 0 0 cc>= } + } test-branch-folding +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##branch } + } + 0 +] [ + { + T{ ##peek f 0 D 0 } + T{ ##compare-branch f 0 0 cc= } + } test-branch-folding +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##branch } + } + 1 +] [ + { + T{ ##peek f 0 D 0 } + T{ ##compare-branch f 0 0 cc/= } + } test-branch-folding +] unit-test + +[ + { + T{ ##peek f 0 D 0 } + T{ ##load-reference f 1 t } + T{ ##branch } + } + 0 +] [ + { + T{ ##peek f 0 D 0 } + T{ ##compare f 1 0 0 cc<= } + T{ ##compare-imm-branch f 1 5 cc/= } + } test-branch-folding +] unit-test + +! More branch folding tests +V{ T{ ##branch } } 0 test-bb + +V{ + T{ ##peek f 0 D 0 } + T{ ##compare-branch f 0 0 cc< } +} 1 test-bb + +V{ + T{ ##load-immediate f 1 1 } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##load-immediate f 2 2 } + T{ ##branch } +} 3 test-bb + +V{ + T{ ##phi f 3 H{ { 2 1 } { 3 2 } } } + T{ ##replace f 3 D 0 } + T{ ##return } +} 4 test-bb + +test-diamond + +[ ] [ + cfg new 0 get >>entry dup cfg set + value-numbering + select-representations + destruct-ssa drop +] unit-test + +[ 1 ] [ 1 get successors>> length ] unit-test + +[ t ] [ 1 get successors>> first 3 get eq? ] unit-test + +[ 2 ] [ 4 get instructions>> length ] unit-test + +V{ + T{ ##peek f 0 D 0 } + T{ ##branch } +} 0 test-bb + +V{ + T{ ##peek f 1 D 1 } + T{ ##compare-branch f 1 1 cc< } +} 1 test-bb + +V{ + T{ ##copy f 2 0 any-rep } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##phi f 3 V{ } } + T{ ##branch } +} 3 test-bb + +V{ + T{ ##replace f 3 D 0 } + T{ ##return } +} 4 test-bb + +1 get 1 2array +2 get 0 2array 2array 3 get instructions>> first (>>inputs) + +test-diamond + +[ ] [ + cfg new 0 get >>entry + value-numbering + eliminate-dead-code + drop +] unit-test + +[ t ] [ 1 get successors>> first 3 get eq? ] unit-test + +[ 1 ] [ 3 get instructions>> first inputs>> assoc-size ] unit-test + +V{ T{ ##prologue } T{ ##branch } } 0 test-bb + +V{ + T{ ##peek { dst 15 } { loc D 0 } } + T{ ##copy { dst 16 } { src 15 } { rep any-rep } } + T{ ##copy { dst 17 } { src 15 } { rep any-rep } } + T{ ##copy { dst 18 } { src 15 } { rep any-rep } } + T{ ##copy { dst 19 } { src 15 } { rep any-rep } } + T{ ##compare + { dst 20 } + { src1 18 } + { src2 19 } + { cc cc= } + { temp 22 } + } + T{ ##copy { dst 21 } { src 20 } { rep any-rep } } + T{ ##compare-imm-branch + { src1 21 } + { src2 5 } + { cc cc/= } + } +} 1 test-bb + +V{ + T{ ##copy { dst 23 } { src 15 } { rep any-rep } } + T{ ##copy { dst 24 } { src 15 } { rep any-rep } } + T{ ##load-reference { dst 25 } { obj t } } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##replace { src 25 } { loc D 0 } } + T{ ##epilogue } + T{ ##return } +} 3 test-bb + +V{ + T{ ##copy { dst 26 } { src 15 } { rep any-rep } } + T{ ##copy { dst 27 } { src 15 } { rep any-rep } } + T{ ##add + { dst 28 } + { src1 26 } + { src2 27 } + } + T{ ##branch } +} 4 test-bb + +V{ + T{ ##replace { src 28 } { loc D 0 } } + T{ ##epilogue } + T{ ##return } +} 5 test-bb + +0 1 edge +1 { 2 4 } edges +2 3 edge +4 5 edge + +[ ] [ + cfg new 0 get >>entry + value-numbering eliminate-dead-code drop +] unit-test + +[ f ] [ 1 get instructions>> [ ##peek? ] any? ] unit-test + diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor index 9f5473c62f..6874f2c001 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering.factor @@ -1,26 +1,47 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces assocs biassocs classes kernel math accessors -sorting sets sequences -compiler.cfg.local -compiler.cfg.liveness +USING: namespaces assocs kernel accessors +sorting sets sequences arrays +cpu.architecture +sequences.deep +compiler.cfg +compiler.cfg.rpo +compiler.cfg.instructions compiler.cfg.value-numbering.graph compiler.cfg.value-numbering.expressions -compiler.cfg.value-numbering.propagate compiler.cfg.value-numbering.simplify compiler.cfg.value-numbering.rewrite ; IN: compiler.cfg.value-numbering -: number-input-values ( live-in -- ) - [ [ f next-input-expr simplify ] dip set-vn ] each ; +! Local value numbering. -: init-value-numbering ( live-in -- ) - init-value-graph - init-expressions - number-input-values ; +: >copy ( insn -- insn/##copy ) + dup dst>> dup vreg>vn vn>vreg + 2dup eq? [ 2drop ] [ any-rep \ ##copy new-insn nip ] if ; + +: rewrite-loop ( insn -- insn' ) + dup rewrite [ rewrite-loop ] [ ] ?if ; + +GENERIC: process-instruction ( insn -- insn' ) + +M: ##flushable process-instruction + dup rewrite + [ process-instruction ] + [ dup number-values >copy ] ?if ; + +M: insn process-instruction + dup rewrite + [ process-instruction ] [ ] ?if ; + +M: array process-instruction + [ process-instruction ] map ; : value-numbering-step ( insns -- insns' ) - [ [ number-values ] [ rewrite propagate ] bi ] map ; + init-value-graph + init-expressions + [ process-instruction ] map flatten ; : value-numbering ( cfg -- cfg' ) - [ init-value-numbering ] [ value-numbering-step ] local-optimization ; + [ value-numbering-step ] local-optimization + + cfg-changed predecessors-changed ; diff --git a/basis/compiler/cfg/write-barrier/authors.txt b/basis/compiler/cfg/write-barrier/authors.txt new file mode 100644 index 0000000000..a44f8d7f8d --- /dev/null +++ b/basis/compiler/cfg/write-barrier/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Daniel Ehrenberg diff --git a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor index c1a667c004..a73451042d 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor @@ -1,76 +1,190 @@ -USING: compiler.cfg.write-barrier compiler.cfg.instructions -compiler.cfg.registers compiler.cfg.debugger cpu.architecture -arrays tools.test vectors compiler.cfg kernel accessors ; +! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs compiler.cfg +compiler.cfg.alias-analysis compiler.cfg.block-joining +compiler.cfg.branch-splitting compiler.cfg.copy-prop +compiler.cfg.dce compiler.cfg.debugger +compiler.cfg.instructions compiler.cfg.loop-detection +compiler.cfg.registers compiler.cfg.ssa.construction +compiler.cfg.tco compiler.cfg.useless-conditionals +compiler.cfg.utilities compiler.cfg.value-numbering +compiler.cfg.write-barrier cpu.architecture kernel +kernel.private math namespaces sequences sequences.private +tools.test vectors ; IN: compiler.cfg.write-barrier.tests : test-write-barrier ( insns -- insns ) - write-barriers-step ; + dup write-barriers-step instructions>> ; [ - { - T{ ##peek f V int-regs 4 D 0 f } - T{ ##copy f V int-regs 6 V int-regs 4 f } - T{ ##allot f V int-regs 7 24 array V int-regs 8 f } - T{ ##load-immediate f V int-regs 9 8 f } - T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 f } - T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 f } - T{ ##replace f V int-regs 7 D 0 f } + V{ + T{ ##peek f 4 D 0 f } + T{ ##allot f 7 24 array 8 f } + T{ ##load-immediate f 9 8 f } + T{ ##set-slot-imm f 9 7 1 3 f } + T{ ##set-slot-imm f 4 7 2 3 f } + T{ ##replace f 7 D 0 f } + T{ ##branch } } ] [ { - T{ ##peek f V int-regs 4 D 0 } - T{ ##copy f V int-regs 6 V int-regs 4 } - T{ ##allot f V int-regs 7 24 array V int-regs 8 } - T{ ##load-immediate f V int-regs 9 8 } - T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 } - T{ ##write-barrier f V int-regs 7 V int-regs 10 V int-regs 11 } - T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 } - T{ ##write-barrier f V int-regs 7 V int-regs 12 V int-regs 13 } - T{ ##replace f V int-regs 7 D 0 } + T{ ##peek f 4 D 0 } + T{ ##allot f 7 24 array 8 } + T{ ##load-immediate f 9 8 } + T{ ##set-slot-imm f 9 7 1 3 } + T{ ##write-barrier f 7 10 11 } + T{ ##set-slot-imm f 4 7 2 3 } + T{ ##write-barrier f 7 12 13 } + T{ ##replace f 7 D 0 } } test-write-barrier ] unit-test [ - { - T{ ##load-immediate f V int-regs 4 24 } - T{ ##peek f V int-regs 5 D -1 } - T{ ##peek f V int-regs 6 D -2 } - T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 } - T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 } + V{ + T{ ##load-immediate f 4 24 } + T{ ##peek f 5 D -1 } + T{ ##peek f 6 D -2 } + T{ ##set-slot-imm f 5 6 3 2 } + T{ ##write-barrier f 6 7 8 } + T{ ##branch } } ] [ { - T{ ##load-immediate f V int-regs 4 24 } - T{ ##peek f V int-regs 5 D -1 } - T{ ##peek f V int-regs 6 D -2 } - T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 } - T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 } + T{ ##load-immediate f 4 24 } + T{ ##peek f 5 D -1 } + T{ ##peek f 6 D -2 } + T{ ##set-slot-imm f 5 6 3 2 } + T{ ##write-barrier f 6 7 8 } } test-write-barrier ] unit-test [ - { - T{ ##peek f V int-regs 19 D -3 } - T{ ##peek f V int-regs 22 D -2 } - T{ ##copy f V int-regs 23 V int-regs 19 } - T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 } - T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 } - T{ ##copy f V int-regs 26 V int-regs 19 } - T{ ##peek f V int-regs 28 D -1 } - T{ ##copy f V int-regs 29 V int-regs 19 } - T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 } + V{ + T{ ##peek f 19 D -3 } + T{ ##peek f 22 D -2 } + T{ ##set-slot-imm f 22 19 3 2 } + T{ ##write-barrier f 19 24 25 } + T{ ##peek f 28 D -1 } + T{ ##set-slot-imm f 28 19 4 2 } + T{ ##branch } } ] [ { - T{ ##peek f V int-regs 19 D -3 } - T{ ##peek f V int-regs 22 D -2 } - T{ ##copy f V int-regs 23 V int-regs 19 } - T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 } - T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 } - T{ ##copy f V int-regs 26 V int-regs 19 } - T{ ##peek f V int-regs 28 D -1 } - T{ ##copy f V int-regs 29 V int-regs 19 } - T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 } - T{ ##write-barrier f V int-regs 29 V int-regs 30 V int-regs 3 } + T{ ##peek f 19 D -3 } + T{ ##peek f 22 D -2 } + T{ ##set-slot-imm f 22 19 3 2 } + T{ ##write-barrier f 19 24 25 } + T{ ##peek f 28 D -1 } + T{ ##set-slot-imm f 28 19 4 2 } + T{ ##write-barrier f 19 30 3 } } test-write-barrier ] unit-test + +V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} 1 test-bb +V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} 2 test-bb +1 get 2 get 1vector >>successors drop +cfg new 1 get >>entry 0 set + +[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test +[ V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} ] [ 1 get instructions>> ] unit-test +[ V{ + T{ ##set-slot-imm f 2 1 3 4 } +} ] [ 2 get instructions>> ] unit-test + +V{ + T{ ##allot f 1 } +} 1 test-bb +V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} 2 test-bb +1 get 2 get 1vector >>successors drop +cfg new 1 get >>entry 0 set + +[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test +[ V{ + T{ ##allot f 1 } +} ] [ 1 get instructions>> ] unit-test +[ V{ + T{ ##set-slot-imm f 2 1 3 4 } +} ] [ 2 get instructions>> ] unit-test + +V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} 1 test-bb +V{ + T{ ##allot } + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} 2 test-bb +1 get 2 get 1vector >>successors drop +cfg new 1 get >>entry 0 set + +[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test +[ V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} ] [ 1 get instructions>> ] unit-test +[ V{ + T{ ##allot } + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} ] [ 2 get instructions>> ] unit-test + +V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} 1 test-bb +V{ + T{ ##allot } +} 2 test-bb +1 get 2 get 1vector >>successors drop +V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} 3 test-bb +2 get 3 get 1vector >>successors drop +cfg new 1 get >>entry 0 set +[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test +[ V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} ] [ 1 get instructions>> ] unit-test +[ V{ T{ ##allot } } ] [ 2 get instructions>> ] unit-test +[ V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} ] [ 3 get instructions>> ] unit-test + +: reverse-here' ( seq -- ) + { array } declare + [ length 2/ iota ] [ length ] [ ] tri + [ [ over - 1 - ] dip exchange-unsafe ] 2curry each ; + +: write-barrier-stats ( word -- cfg ) + test-cfg first [ + optimize-tail-calls + delete-useless-conditionals + split-branches + join-blocks + construct-ssa + alias-analysis + value-numbering + copy-propagation + eliminate-dead-code + eliminate-write-barriers + ] with-cfg + post-order>> write-barriers + [ [ loop-nesting-at ] [ length ] bi* ] assoc-map ; + +[ { { 0 1 } } ] [ \ reverse-here' write-barrier-stats ] unit-test diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor index b260b0464e..97b0c27af1 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier.factor @@ -1,8 +1,16 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors namespaces assocs sets sequences locals -compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop -compiler.cfg.liveness compiler.cfg.local ; +USING: kernel accessors namespaces assocs sets sequences +fry combinators.short-circuit locals make arrays +compiler.cfg +compiler.cfg.dominance +compiler.cfg.predecessors +compiler.cfg.loop-detection +compiler.cfg.rpo +compiler.cfg.instructions +compiler.cfg.registers +compiler.cfg.dataflow-analysis +compiler.cfg.utilities ; IN: compiler.cfg.write-barrier ! Eliminate redundant write barrier hits. @@ -14,33 +22,118 @@ SYMBOL: safe ! Objects which have been mutated SYMBOL: mutated -GENERIC: eliminate-write-barrier ( insn -- insn' ) +GENERIC: eliminate-write-barrier ( insn -- ? ) M: ##allot eliminate-write-barrier - dup dst>> safe get conjoin ; + dst>> safe get conjoin t ; M: ##write-barrier eliminate-write-barrier - dup src>> resolve dup - [ safe get key? not ] - [ mutated get key? ] bi and - [ safe get conjoin ] [ 2drop f ] if ; + src>> dup safe get key? not + [ safe get conjoin t ] [ drop f ] if ; -M: ##copy eliminate-write-barrier - dup record-copy ; +M: insn eliminate-write-barrier drop t ; -M: ##set-slot eliminate-write-barrier - dup obj>> resolve mutated get conjoin ; +! This doesn't actually benefit from being a dataflow analysis +! might as well be dominator-based +! Dealing with phi functions would help, though +FORWARD-ANALYSIS: safe -M: ##set-slot-imm eliminate-write-barrier - dup obj>> resolve mutated get conjoin ; +: has-allocation? ( bb -- ? ) + instructions>> [ { [ ##allocation? ] [ ##call? ] } 1|| ] any? ; -M: insn eliminate-write-barrier ; +M: safe-analysis transfer-set + drop [ H{ } assoc-clone-like safe set ] dip + instructions>> [ + eliminate-write-barrier drop + ] each safe get ; -: write-barriers-step ( insns -- insns' ) - H{ } clone safe set +M: safe-analysis join-sets + drop has-allocation? [ drop H{ } clone ] [ assoc-refine ] if ; + +: write-barriers-step ( bb -- ) + dup safe-in H{ } assoc-clone-like safe set + instructions>> [ eliminate-write-barrier ] filter-here ; + +GENERIC: remove-dead-barrier ( insn -- ? ) + +M: ##write-barrier remove-dead-barrier + src>> mutated get key? ; + +M: ##set-slot remove-dead-barrier + obj>> mutated get conjoin t ; + +M: ##set-slot-imm remove-dead-barrier + obj>> mutated get conjoin t ; + +M: insn remove-dead-barrier drop t ; + +: remove-dead-barriers ( bb -- ) H{ } clone mutated set - H{ } clone copies set - [ eliminate-write-barrier ] map sift ; + instructions>> [ remove-dead-barrier ] filter-here ; + +! Availability of slot +! Anticipation of this and set-slot would help too, maybe later +FORWARD-ANALYSIS: slot + +UNION: access ##read ##write ; + +M: slot-analysis transfer-set + drop [ H{ } assoc-clone-like ] dip + instructions>> over '[ + dup access? [ + obj>> _ conjoin + ] [ drop ] if + ] each ; + +: slot-available? ( vreg bb -- ? ) + slot-in key? ; + +: make-barriers ( vregs -- bb ) + [ [ next-vreg next-vreg ##write-barrier ] each ] V{ } make ; + +: emit-barriers ( vregs loop -- ) + swap [ + [ [ header>> predecessors>> ] [ ends>> keys ] bi diff ] + [ header>> ] bi + ] [ make-barriers ] bi* + insert-basic-block ; + +: write-barriers ( bbs -- bb=>barriers ) + [ + dup instructions>> + [ ##write-barrier? ] filter + [ src>> ] map + ] { } map>assoc + [ nip empty? not ] assoc-filter ; + +: filter-dominant ( bb=>barriers bbs -- barriers ) + '[ drop _ [ dominates? ] with all? ] assoc-filter + values concat prune ; + +: dominant-write-barriers ( loop -- vregs ) + [ blocks>> values write-barriers ] [ ends>> keys ] bi filter-dominant ; + +: safe-loops ( -- loops ) + loops get values + [ blocks>> keys [ has-allocation? not ] all? ] filter ; + +:: insert-extra-barriers ( cfg -- ) + safe-loops [| loop | + cfg needs-dominance needs-predecessors drop + loop dominant-write-barriers + loop header>> '[ _ slot-available? ] filter + [ loop emit-barriers cfg cfg-changed drop ] unless-empty + ] each ; + +: contains-write-barrier? ( cfg -- ? ) + post-order [ instructions>> [ ##write-barrier? ] any? ] any? ; : eliminate-write-barriers ( cfg -- cfg' ) - [ drop ] [ write-barriers-step ] local-optimization ; + dup contains-write-barrier? [ + needs-loops + dup [ remove-dead-barriers ] each-basic-block + dup compute-slot-sets + dup insert-extra-barriers + dup compute-safe-sets + dup [ write-barriers-step ] each-basic-block + ] when ; diff --git a/basis/compiler/codegen/codegen-tests.factor b/basis/compiler/codegen/codegen-tests.factor index 9c3817bad6..225577d0b9 100644 --- a/basis/compiler/codegen/codegen-tests.factor +++ b/basis/compiler/codegen/codegen-tests.factor @@ -1,6 +1,6 @@ -IN: compiler.codegen.tests USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make compiler.constants ; +IN: compiler.codegen.tests [ ] [ [ ] with-fixup drop ] unit-test [ ] [ [ \ + %call ] with-fixup drop ] unit-test diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 7602295284..00a36cc55f 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -4,7 +4,7 @@ USING: namespaces make math math.order math.parser sequences accessors kernel kernel.private layouts assocs words summary arrays combinators classes.algebra alien alien.c-types alien.structs alien.strings alien.arrays alien.complex alien.libraries sets libc -continuations.private fry cpu.architecture +continuations.private fry cpu.architecture classes locals source-files.errors compiler.errors compiler.alien @@ -18,16 +18,12 @@ compiler.codegen.fixup compiler.utilities ; IN: compiler.codegen +SYMBOL: insn-counts + +H{ } clone insn-counts set-global + GENERIC: generate-insn ( insn -- ) -SYMBOL: registers - -: register ( vreg -- operand ) - registers get at [ "Bad value" throw ] unless* ; - -: ?register ( obj -- operand ) - dup vreg? [ register ] when ; - TUPLE: asm label code calls ; SYMBOL: calls @@ -54,7 +50,11 @@ SYMBOL: labels [ word>> init-generator ] [ instructions>> - [ [ regs>> registers set ] [ generate-insn ] bi ] each + [ + [ class insn-counts get inc-at ] + [ generate-insn ] + bi + ] each ] bi ] with-fixup ; @@ -67,17 +67,19 @@ SYMBOL: labels : lookup-label ( id -- label ) labels get [ drop