diff --git a/basis/alien/arrays/arrays-docs.factor b/basis/alien/arrays/arrays-docs.factor old mode 100644 new mode 100755 index bf012090f8..db4a7bf595 --- a/basis/alien/arrays/arrays-docs.factor +++ b/basis/alien/arrays/arrays-docs.factor @@ -6,7 +6,7 @@ ARTICLE: "c-arrays" "C arrays" $nl "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" } " and " { $vocab-link "specialized-arrays.direct" } " vocabulary sets. They can also be loaded and constructed through their primitive C types:" -{ $subsection require-c-arrays } +"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 98994c753e..64827ec139 100755 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -35,7 +35,7 @@ M: array stack-size drop "void*" stack-size ; M: array c-type-boxer-quot unclip [ array-length ] - [ [ require-c-arrays ] keep ] bi* + [ [ require-c-array ] keep ] bi* [ ] 2curry ; M: array c-type-unboxer-quot drop [ >c-ptr ] ; 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 ac9a959d4c..3a7c3a7405 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -51,7 +51,7 @@ HELP: c-setter HELP: { $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." } -{ $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-arrays } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." } +{ $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: @@ -73,7 +73,7 @@ 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, then wraps the memory in a sequence object using " { $link } "." } -{ $notes "The appropriate direct 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-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." } +{ $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, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ; @@ -130,15 +130,15 @@ HELP: malloc-string } } ; -HELP: require-c-arrays +HELP: require-c-array { $values { "c-type" "a C type" } } -{ $description { $link require } "s any unloaded vocabularies needed to construct a specialized array or direct 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" } " and " { $vocab-link "specialized-arrays.direct" } " vocabulary sets for details on the underlying sequence types loaded." } ; +{ $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 direct 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-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." } ; +{ $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." diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index ac0bbf68b3..aa2ac2f93d 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -25,9 +25,7 @@ align array-class array-constructor (array)-constructor -direct-array-class -direct-array-constructor -sequence-mixin-class ; +direct-array-constructor ; TUPLE: c-type < abstract-c-type boxer @@ -89,21 +87,19 @@ M: string heap-size c-type heap-size ; M: abstract-c-type heap-size size>> ; -GENERIC: require-c-arrays ( c-type -- ) +GENERIC: require-c-array ( c-type -- ) -M: object require-c-arrays +M: object require-c-array drop ; -M: c-type require-c-arrays - [ array-class>> ?require-word ] - [ sequence-mixin-class>> ?require-word ] - [ direct-array-class>> ?require-word ] tri ; +M: c-type require-c-array + array-class>> ?require-word ; -M: string require-c-arrays - c-type require-c-arrays ; +M: string require-c-array + c-type require-c-array ; -M: array require-c-arrays - first c-type require-c-arrays ; +M: array require-c-array + first c-type require-c-array ; ERROR: specialized-array-vocab-not-loaded vocab word ; @@ -370,14 +366,6 @@ M: long-long-type box-return ( type -- ) ] [ [ "specialized-arrays." prepend ] - [ "-sequence" append ] bi* ?lookup >>sequence-mixin-class - ] - [ - [ "specialized-arrays.direct." prepend ] - [ "direct-" "-array" surround ] bi* ?lookup >>direct-array-class - ] - [ - [ "specialized-arrays.direct." prepend ] [ "" surround ] bi* ?lookup >>direct-array-constructor ] } 2cleave ; @@ -549,7 +537,7 @@ CONSTANT: primitive-types 4 >>align "box_float" >>boxer "to_float" >>unboxer - single-float-rep >>rep + float-rep >>rep [ >float ] >>unboxer-quot "float" set-array-class "float" define-primitive-type @@ -563,7 +551,7 @@ CONSTANT: primitive-types 8 >>align "box_double" >>boxer "to_double" >>unboxer - double-float-rep >>rep + double-rep >>rep [ >float ] >>unboxer-quot "double" set-array-class "double" define-primitive-type diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor old mode 100644 new mode 100755 index 9387d932c6..d76013e138 --- a/basis/classes/struct/struct-tests.factor +++ b/basis/classes/struct/struct-tests.factor @@ -6,7 +6,7 @@ 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.direct.int specialized-arrays.ushort +specialized-arrays.int specialized-arrays.ushort struct-arrays system tools.test ; IN: classes.struct.tests @@ -316,6 +316,11 @@ STRUCT: struct-test-optimization [ 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] } ; @@ -340,3 +345,4 @@ 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 old mode 100644 new mode 100755 index b2bd07a03f..dc7fa965db --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -6,7 +6,7 @@ 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.direct.uchar ; +words compiler.tree.propagation.transforms specialized-arrays.uchar ; FROM: slots => reader-word writer-word ; IN: classes.struct @@ -20,8 +20,7 @@ TUPLE: struct TUPLE: struct-slot-spec < slot-spec c-type ; -PREDICATE: struct-class < tuple-class - { [ \ struct subclass-of? ] [ all-slots length 1 = ] } 1&& ; +PREDICATE: struct-class < tuple-class \ struct subclass-of? ; : struct-slots ( struct-class -- slots ) "struct-slots" word-prop ; @@ -43,11 +42,9 @@ M: struct hashcode* : struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable : memory>struct ( ptr class -- struct ) - [ 1array ] dip slots>tuple ; - -\ memory>struct [ - dup struct-class? [ '[ _ boa ] ] [ drop f ] if -] 1 define-partial-eval + ! 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 c-ptr ] [ byte-length ] bi memory>byte-array ; inline @@ -203,6 +196,9 @@ M: struct-class c-type-unboxer-quot M: struct-class heap-size "struct-size" word-prop ; +M: struct byte-length + class "struct-size" word-prop ; foldable + ! class definition > +<< "id" require-c-array >> CONSTANT: NS-EACH-BUFFER-SIZE 16 diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor old mode 100644 new mode 100755 index 26672dde80..7342451c38 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -5,7 +5,7 @@ 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.direct.alien ; +generalizations specialized-arrays.alien ; IN: cocoa.messages : make-sender ( method function -- quot ) diff --git a/basis/colors/constants/constants-docs.factor b/basis/colors/constants/constants-docs.factor index 49d6fce3a1..73dd0c0ccc 100644 --- a/basis/colors/constants/constants-docs.factor +++ b/basis/colors/constants/constants-docs.factor @@ -23,7 +23,7 @@ HELP: COLOR: } ; ARTICLE: "colors.constants" "Standard color database" -"The " { $vocab-link "colors.constants" } " vocabulary bundles the X11 " { $snippet "rgb.txt" } " database and provides words for looking up color values." +"The " { $vocab-link "colors.constants" } " vocabulary bundles the X11 " { $snippet "rgb.txt" } " database and Factor's " { $snippet "factor-colors.txt" } " theme database to provide words for looking up color values by name." { $subsection named-color } { $subsection named-colors } { $subsection POSTPONE: COLOR: } ; diff --git a/basis/colors/constants/constants.factor b/basis/colors/constants/constants.factor index 98e7d43411..3912994066 100644 --- a/basis/colors/constants/constants.factor +++ b/basis/colors/constants/constants.factor @@ -1,17 +1,15 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel assocs math math.parser memoize io.encodings.utf8 -io.files lexer parser colors sequences splitting -combinators.smart ascii ; +io.files lexer parser colors sequences splitting ascii ; IN: colors.constants number 255 /f ] tri@ 1.0 ] dip - [ blank? ] trim-head { { CHAR: \s CHAR: - } } substitute swap - ] inputnumber 255 /f ] tri@ 1.0 ] dip + [ blank? ] trim-head { { CHAR: \s CHAR: - } } substitute swap ; : parse-rgb.txt ( lines -- assoc ) [ "!" head? not ] filter @@ -19,7 +17,9 @@ IN: colors.constants [ parse-color ] H{ } map>assoc ; MEMO: rgb.txt ( -- assoc ) - "resource:basis/colors/constants/rgb.txt" utf8 file-lines parse-rgb.txt ; + "resource:basis/colors/constants/rgb.txt" + "resource:basis/colors/constants/factor-colors.txt" + [ utf8 file-lines parse-rgb.txt ] bi@ assoc-union ; PRIVATE> diff --git a/basis/colors/constants/factor-colors.txt b/basis/colors/constants/factor-colors.txt new file mode 100644 index 0000000000..9d7649ab3d --- /dev/null +++ b/basis/colors/constants/factor-colors.txt @@ -0,0 +1,5 @@ +! Factor UI theme colors +227 226 219 FactorLightTan +172 167 147 FactorDarkTan + 81 91 105 FactorLightSlateBlue + 55 62 72 FactorDarkSlateBlue diff --git a/basis/combinators/short-circuit/short-circuit.factor b/basis/combinators/short-circuit/short-circuit.factor index a625a462af..dabbe07afb 100644 --- a/basis/combinators/short-circuit/short-circuit.factor +++ b/basis/combinators/short-circuit/short-circuit.factor @@ -1,15 +1,15 @@ USING: kernel combinators quotations arrays sequences assocs -locals generalizations macros fry ; +generalizations macros fry ; IN: combinators.short-circuit -MACRO:: n&& ( quots n -- quot ) - [ f ] quots [| q | - n - [ q '[ drop _ ndup @ dup not ] ] - [ '[ drop _ ndrop f ] ] - bi 2array - ] map - n '[ _ nnip ] suffix 1array +MACRO: n&& ( quots n -- quot ) + [ + [ [ f ] ] 2dip swap [ + [ '[ drop _ ndup @ dup not ] ] + [ drop '[ drop _ ndrop f ] ] + 2bi 2array + ] with map + ] [ '[ _ nnip ] suffix 1array ] bi [ cond ] 3append ; : 2&& ( obj1 obj2 quots -- ? ) [ with with ] unoptimized-&& ; : 3&& ( obj1 obj2 obj3 quots -- ? ) [ with with with ] unoptimized-&& ; -MACRO:: n|| ( quots n -- quot ) - [ f ] quots [| q | - n - [ q '[ drop _ ndup @ dup ] ] - [ '[ _ nnip ] ] - bi 2array - ] map - n '[ drop _ ndrop t ] [ f ] 2array suffix 1array +MACRO: n|| ( quots n -- quot ) + [ + [ [ f ] ] 2dip swap [ + [ '[ drop _ ndup @ dup ] ] + [ drop '[ _ nnip ] ] + 2bi 2array + ] with map + ] [ '[ drop _ ndrop t ] [ f ] 2array suffix 1array ] bi [ cond ] 3append ; > ] [ dst>> ] bi constants get set-at ; -M: ##flushable analyze-aliases* - dup dst>> set-heap-ac ; - M: ##allocation analyze-aliases* #! A freshly allocated object is distinct from any other #! object. @@ -246,8 +247,6 @@ M: ##copy analyze-aliases* #! vreg, since they both contain the same value. dup record-copy ; -M: insn analyze-aliases* ; - : analyze-aliases ( insns -- insns' ) [ insn# set analyze-aliases* ] map-index sift ; diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index 4e0c2aa112..8da73a1e0e 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -189,5 +189,17 @@ IN: compiler.cfg.builder.tests [ f t ] [ [ { fixnum simple-alien } declare 0 alien-cell ] [ [ ##unbox-any-c-ptr? ] contains-insn? ] - [ [ ##slot-imm? ] contains-insn? ] bi + [ [ ##unbox-alien? ] contains-insn? ] bi +] unit-test + +[ f t ] [ + [ { byte-array fixnum } declare alien-cell 4 alien-float ] + [ [ ##box-alien? ] contains-insn? ] + [ [ ##box-float? ] contains-insn? ] bi +] unit-test + +[ f t ] [ + [ { byte-array fixnum } declare alien-cell { simple-alien } declare 4 alien-float ] + [ [ ##box-alien? ] contains-insn? ] + [ [ ##box-float? ] 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 7b74d1c258..8f52071e22 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -131,7 +131,7 @@ M: #recursive emit-node : 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 ; + ds-pop any-rep ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ; M: #if emit-node { diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index 07e6cc8cea..cf15d68b59 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -21,8 +21,9 @@ ERROR: last-insn-not-a-jump bb ; dup instructions>> last { [ ##branch? ] [ ##dispatch? ] - [ ##conditional-branch? ] + [ ##compare-branch? ] [ ##compare-imm-branch? ] + [ ##compare-float-branch? ] [ ##fixnum-add? ] [ ##fixnum-sub? ] [ ##fixnum-mul? ] diff --git a/basis/compiler/cfg/dce/dce.factor b/basis/compiler/cfg/dce/dce.factor index dd42475a13..363cea7852 100644 --- a/basis/compiler/cfg/dce/dce.factor +++ b/basis/compiler/cfg/dce/dce.factor @@ -42,14 +42,11 @@ M: ##set-slot-imm build-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 ; + [ dst>> allocations get conjoin ] [ call-next-method ] bi ; -M: insn build-liveness-graph drop ; +M: insn build-liveness-graph + dup defs-vreg dup [ add-edges ] [ 2drop ] if ; GENERIC: compute-live-vregs ( insn -- ) @@ -77,24 +74,35 @@ M: ##set-slot-imm compute-live-vregs M: ##write-barrier compute-live-vregs dup src>> setter-live-vregs ; -M: ##flushable compute-live-vregs drop ; +M: ##fixnum-add compute-live-vregs record-live ; + +M: ##fixnum-sub compute-live-vregs record-live ; + +M: ##fixnum-mul compute-live-vregs record-live ; M: insn compute-live-vregs - record-live ; + dup defs-vreg [ drop ] [ record-live ] if ; GENERIC: live-insn? ( insn -- ? ) -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 ; +M: ##fixnum-add live-insn? drop t ; + +M: ##fixnum-sub live-insn? drop t ; + +M: ##fixnum-mul live-insn? drop t ; + +M: insn live-insn? defs-vreg [ live-vreg? ] [ t ] if* ; : eliminate-dead-code ( cfg -- cfg' ) + ! Even though we don't use predecessors directly, we depend + ! on the predecessors pass updating phi nodes to remove dead + ! inputs. needs-predecessors init-dead-code diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index 3102d75a4e..825ff71b9b 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -1,55 +1,52 @@ ! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays kernel assocs sequences namespaces fry -sets compiler.cfg.rpo compiler.cfg.instructions locals ; +USING: accessors assocs arrays classes combinators +compiler.units fry generalizations generic kernel locals +namespaces quotations sequences sets slots words +compiler.cfg.instructions compiler.cfg.instructions.syntax +compiler.cfg.rpo ; IN: compiler.cfg.def-use GENERIC: defs-vreg ( insn -- vreg/f ) GENERIC: temp-vregs ( insn -- seq ) GENERIC: uses-vregs ( insn -- seq ) -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 ; -M: ##allot temp-vregs temp>> 1array ; -M: ##dispatch temp-vregs temp>> 1array ; -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: ##gc temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ; -M: _dispatch temp-vregs temp>> 1array ; -M: insn temp-vregs drop f ; - -M: ##unary uses-vregs src>> 1array ; -M: ##binary uses-vregs [ src1>> ] [ src2>> ] bi 2array ; -M: ##binary-imm uses-vregs src1>> 1array ; -M: ##effect uses-vregs src>> 1array ; -M: ##slot uses-vregs [ obj>> ] [ slot>> ] bi 2array ; -M: ##slot-imm uses-vregs obj>> 1array ; -M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ; -M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ; -M: ##string-nth uses-vregs [ obj>> ] [ index>> ] bi 2array ; -M: ##set-string-nth-fast uses-vregs [ src>> ] [ obj>> ] [ index>> ] tri 3array ; -M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ; -M: ##compare-imm-branch uses-vregs src1>> 1array ; -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>> 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 ; + +> reader-word 1quotation ] [ [ drop f ] ] if* ] bi + define ; + +: define-uses-vregs-method ( insn -- ) + [ \ uses-vregs create-method ] + [ insn-use-slots [ name>> ] map slot-array-quot ] bi + define ; + +: define-temp-vregs-method ( insn -- ) + [ \ temp-vregs create-method ] + [ insn-temp-slots [ name>> ] map slot-array-quot ] bi + define ; + +PRIVATE> + +[ + insn-classes get + [ [ define-defs-vreg-method ] each ] + [ { ##phi } diff [ define-uses-vregs-method ] each ] + [ [ define-temp-vregs-method ] each ] + tri +] with-compilation-unit ! Computing def-use chains. diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index 2d79cbebc3..469ba37703 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -1,83 +1,60 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays byte-arrays kernel layouts math namespaces -sequences classes.tuple cpu.architecture compiler.cfg.registers -compiler.cfg.instructions ; +USING: accessors arrays byte-arrays kernel layouts math +namespaces sequences combinators splitting parser effects +words cpu.architecture compiler.cfg.registers +compiler.cfg.instructions compiler.cfg.instructions.syntax ; IN: compiler.cfg.hats -: ^^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 +<< + +> "##" ?head drop "^^" prepend create-in ; + +: hat-quot ( insn -- quot ) + [ + "insn-slots" word-prop [ ] [ + type>> { + { def [ [ next-vreg dup ] ] } + { temp [ [ next-vreg ] ] } + [ drop [ ] ] + } case swap [ dip ] curry compose + ] reduce + ] keep suffix ; + +: hat-effect ( insn -- effect ) + "insn-slots" word-prop + [ type>> { def temp } memq? not ] filter [ name>> ] map + { "vreg" } ; + +: define-hat ( insn -- ) + [ hat-name ] [ hat-quot ] [ hat-effect ] tri define-inline ; + +PRIVATE> + +insn-classes get [ + dup [ insn-def-slot ] [ name>> "##" head? ] bi and + [ define-hat ] [ drop ] if +] each + +>> + +: ^^load-literal ( obj -- dst ) + [ next-vreg dup ] dip { + { [ dup not ] [ drop \ f tag-number ##load-immediate ] } + { [ dup fixnum? ] [ tag-fixnum ##load-immediate ] } + [ ##load-reference ] + } cond ; inline + +: ^^unbox-c-ptr ( src class -- dst ) + [ next-vreg dup ] 2dip next-vreg ##unbox-c-ptr ; 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-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 +: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ; inline +: ^^tag-fixnum ( src -- dst ) tag-bits get ^^shl-imm ; inline +: ^^untag-fixnum ( src -- dst ) tag-bits get ^^sar-imm ; inline \ No newline at end of file diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index a7cc2e0603..8bbbbc9324 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -1,136 +1,368 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs accessors arrays kernel sequences namespaces words -math math.order layouts classes.algebra alien byte-arrays -compiler.constants combinators compiler.cfg.registers -compiler.cfg.instructions.syntax ; +math math.order layouts classes.algebra classes.union +compiler.units alien byte-arrays compiler.constants combinators +compiler.cfg.registers compiler.cfg.instructions.syntax ; IN: compiler.cfg.instructions +<< +SYMBOL: insn-classes +V{ } clone insn-classes set-global +>> + : 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 ; - -! Instruction which is referentially transparent; we can replace -! repeated computation with a reference to a previous value -TUPLE: ##pure < ##flushable ; - -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 ; - -! Read/write ops: candidates for alias analysis -TUPLE: ##read < ##flushable ; -TUPLE: ##write < ##effect ; - -TUPLE: ##alien-getter < ##flushable src ; -TUPLE: ##alien-setter < ##effect value ; +! Instructions which are referentially transparent; used for +! value numbering +TUPLE: pure-insn < insn ; ! Stack operations -INSN: ##load-immediate < ##pure { val integer } ; -INSN: ##load-reference < ##pure obj ; +INSN: ##load-immediate +def: dst/int-rep +constant: val ; -GENERIC: ##load-literal ( dst value -- ) +INSN: ##load-reference +def: dst/int-rep +constant: obj ; -M: fixnum ##load-literal tag-fixnum ##load-immediate ; -M: f ##load-literal drop \ f tag-number ##load-immediate ; -M: object ##load-literal ##load-reference ; +INSN: ##peek +def: dst/int-rep +literal: loc ; -INSN: ##peek < ##flushable { loc loc } ; -INSN: ##replace < ##effect { loc loc } ; -INSN: ##inc-d { n integer } ; -INSN: ##inc-r { n integer } ; +INSN: ##replace +use: src/int-rep +literal: loc ; + +INSN: ##inc-d +literal: n ; + +INSN: ##inc-r +literal: n ; ! Subroutine calls -INSN: ##call word ; -INSN: ##jump word ; +INSN: ##call +literal: word ; + +INSN: ##jump +literal: word ; + INSN: ##return ; ! Dummy instruction that simply inhibits TCO INSN: ##no-tco ; ! Jump tables -INSN: ##dispatch src temp ; +INSN: ##dispatch +use: src/int-rep +temp: temp/int-rep ; ! Slot access -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 } ; +INSN: ##slot +def: dst/int-rep +use: obj/int-rep slot/int-rep +literal: tag +temp: temp/int-rep ; + +INSN: ##slot-imm +def: dst/int-rep +use: obj/int-rep +literal: slot tag ; + +INSN: ##set-slot +use: src/int-rep obj/int-rep slot/int-rep +literal: tag +temp: temp/int-rep ; + +INSN: ##set-slot-imm +use: src/int-rep obj/int-rep +literal: slot tag ; ! String element access -INSN: ##string-nth < ##flushable obj index temp ; -INSN: ##set-string-nth-fast < ##effect obj index temp ; +INSN: ##string-nth +def: dst/int-rep +use: obj/int-rep index/int-rep +temp: temp/int-rep ; + +INSN: ##set-string-nth-fast +use: src/int-rep obj/int-rep index/int-rep +temp: temp/int-rep ; + +PURE-INSN: ##copy +def: dst +use: src +literal: rep ; ! Integer arithmetic -INSN: ##add < ##commutative ; -INSN: ##add-imm < ##commutative-imm ; -INSN: ##sub < ##binary ; -INSN: ##sub-imm < ##binary-imm ; -INSN: ##mul < ##commutative ; -INSN: ##mul-imm < ##commutative-imm ; -INSN: ##and < ##commutative ; -INSN: ##and-imm < ##commutative-imm ; -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 ; +PURE-INSN: ##add +def: dst/int-rep +use: src1/int-rep src2/int-rep ; -: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline -: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline +PURE-INSN: ##add-imm +def: dst/int-rep +use: src1/int-rep +constant: src2 ; + +PURE-INSN: ##sub +def: dst/int-rep +use: src1/int-rep src2/int-rep ; + +PURE-INSN: ##sub-imm +def: dst/int-rep +use: src1/int-rep +constant: src2 ; + +PURE-INSN: ##mul +def: dst/int-rep +use: src1/int-rep src2/int-rep ; + +PURE-INSN: ##mul-imm +def: dst/int-rep +use: src1/int-rep +constant: src2 ; + +PURE-INSN: ##and +def: dst/int-rep +use: src1/int-rep src2/int-rep ; + +PURE-INSN: ##and-imm +def: dst/int-rep +use: src1/int-rep +constant: src2 ; + +PURE-INSN: ##or +def: dst/int-rep +use: src1/int-rep src2/int-rep ; + +PURE-INSN: ##or-imm +def: dst/int-rep +use: src1/int-rep +constant: src2 ; + +PURE-INSN: ##xor +def: dst/int-rep +use: src1/int-rep src2/int-rep ; + +PURE-INSN: ##xor-imm +def: dst/int-rep +use: src1/int-rep +constant: src2 ; + +PURE-INSN: ##shl +def: dst/int-rep +use: src1/int-rep src2/int-rep ; + +PURE-INSN: ##shl-imm +def: dst/int-rep +use: src1/int-rep +constant: src2 ; + +PURE-INSN: ##shr +def: dst/int-rep +use: src1/int-rep src2/int-rep ; + +PURE-INSN: ##shr-imm +def: dst/int-rep +use: src1/int-rep +constant: src2 ; + +PURE-INSN: ##sar +def: dst/int-rep +use: src1/int-rep src2/int-rep ; + +PURE-INSN: ##sar-imm +def: dst/int-rep +use: src1/int-rep +constant: src2 ; + +PURE-INSN: ##min +def: dst/int-rep +use: src1/int-rep src2/int-rep ; + +PURE-INSN: ##max +def: dst/int-rep +use: src1/int-rep src2/int-rep ; + +PURE-INSN: ##not +def: dst/int-rep +use: src/int-rep ; + +PURE-INSN: ##log2 +def: dst/int-rep +use: src/int-rep ; ! Bignum/integer conversion -INSN: ##integer>bignum < ##unary/temp ; -INSN: ##bignum>integer < ##unary/temp ; +PURE-INSN: ##integer>bignum +def: dst/int-rep +use: src/int-rep +temp: temp/int-rep ; + +PURE-INSN: ##bignum>integer +def: dst/int-rep +use: src/int-rep +temp: temp/int-rep ; ! Float arithmetic -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 ; +PURE-INSN: ##unbox-float +def: dst/double-rep +use: src/int-rep ; + +PURE-INSN: ##box-float +def: dst/int-rep +use: src/double-rep +temp: temp/int-rep ; + +PURE-INSN: ##add-float +def: dst/double-rep +use: src1/double-rep src2/double-rep ; + +PURE-INSN: ##sub-float +def: dst/double-rep +use: src1/double-rep src2/double-rep ; + +PURE-INSN: ##mul-float +def: dst/double-rep +use: src1/double-rep src2/double-rep ; + +PURE-INSN: ##div-float +def: dst/double-rep +use: src1/double-rep src2/double-rep ; + +PURE-INSN: ##min-float +def: dst/double-rep +use: src1/double-rep src2/double-rep ; + +PURE-INSN: ##max-float +def: dst/double-rep +use: src1/double-rep src2/double-rep ; + +PURE-INSN: ##sqrt +def: dst/double-rep +use: src/double-rep ; ! libc intrinsics -INSN: ##unary-float-function < ##unary func ; -INSN: ##binary-float-function < ##binary func ; +PURE-INSN: ##unary-float-function +def: dst/double-rep +use: src/double-rep +literal: func ; + +PURE-INSN: ##binary-float-function +def: dst/double-rep +use: src1/double-rep src2/double-rep +literal: func ; + +! Single/double float conversion +PURE-INSN: ##single>double-float +def: dst/double-rep +use: src/float-rep ; + +PURE-INSN: ##double>single-float +def: dst/float-rep +use: src/double-rep ; ! Float/integer conversion -INSN: ##float>integer < ##unary ; -INSN: ##integer>float < ##unary ; +PURE-INSN: ##float>integer +def: dst/int-rep +use: src/double-rep ; -! Boxing and unboxing -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 ; +PURE-INSN: ##integer>float +def: dst/double-rep +use: src/int-rep ; + +! SIMD operations + +PURE-INSN: ##box-vector +def: dst/int-rep +use: src +literal: rep +temp: temp/int-rep ; + +PURE-INSN: ##unbox-vector +def: dst +use: src/int-rep +literal: rep ; + +PURE-INSN: ##broadcast-vector +def: dst +use: src/scalar-rep +literal: rep ; + +PURE-INSN: ##gather-vector-2 +def: dst +use: src1/scalar-rep src2/scalar-rep +literal: rep ; + +PURE-INSN: ##gather-vector-4 +def: dst +use: src1/scalar-rep src2/scalar-rep src3/scalar-rep src4/scalar-rep +literal: rep ; + +PURE-INSN: ##add-vector +def: dst +use: src1 src2 +literal: rep ; + +PURE-INSN: ##sub-vector +def: dst +use: src1 src2 +literal: rep ; + +PURE-INSN: ##mul-vector +def: dst +use: src1 src2 +literal: rep ; + +PURE-INSN: ##div-vector +def: dst +use: src1 src2 +literal: rep ; + +PURE-INSN: ##min-vector +def: dst +use: src1 src2 +literal: rep ; + +PURE-INSN: ##max-vector +def: dst +use: src1 src2 +literal: rep ; + +PURE-INSN: ##sqrt-vector +def: dst +use: src +literal: rep ; + +PURE-INSN: ##horizontal-add-vector +def: dst/scalar-rep +use: src +literal: rep ; + +! Boxing and unboxing aliens +PURE-INSN: ##box-alien +def: dst/int-rep +use: src/int-rep +temp: temp/int-rep ; + +PURE-INSN: ##box-displaced-alien +def: dst/int-rep +use: displacement/int-rep base/int-rep +temp: temp1/int-rep temp2/int-rep +literal: base-class ; + +PURE-INSN: ##unbox-any-c-ptr +def: dst/int-rep +use: src/int-rep +temp: temp/int-rep ; : ##unbox-f ( dst src -- ) drop 0 ##load-immediate ; : ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ; -: ##unbox-alien ( dst src -- ) 3 object tag-number ##slot-imm ; + +PURE-INSN: ##unbox-alien +def: dst/int-rep +use: src/int-rep ; : ##unbox-c-ptr ( dst src class temp -- ) { @@ -141,42 +373,95 @@ INSN: ##box-displaced-alien < ##binary temp1 temp2 base-class ; } cond ; ! Alien accessors -INSN: ##alien-unsigned-1 < ##alien-getter ; -INSN: ##alien-unsigned-2 < ##alien-getter ; -INSN: ##alien-unsigned-4 < ##alien-getter ; -INSN: ##alien-signed-1 < ##alien-getter ; -INSN: ##alien-signed-2 < ##alien-getter ; -INSN: ##alien-signed-4 < ##alien-getter ; -INSN: ##alien-cell < ##alien-getter ; -INSN: ##alien-float < ##alien-getter ; -INSN: ##alien-double < ##alien-getter ; +INSN: ##alien-unsigned-1 +def: dst/int-rep +use: src/int-rep ; -INSN: ##set-alien-integer-1 < ##alien-setter ; -INSN: ##set-alien-integer-2 < ##alien-setter ; -INSN: ##set-alien-integer-4 < ##alien-setter ; -INSN: ##set-alien-cell < ##alien-setter ; -INSN: ##set-alien-float < ##alien-setter ; -INSN: ##set-alien-double < ##alien-setter ; +INSN: ##alien-unsigned-2 +def: dst/int-rep +use: src/int-rep ; + +INSN: ##alien-unsigned-4 +def: dst/int-rep +use: src/int-rep ; + +INSN: ##alien-signed-1 +def: dst/int-rep +use: src/int-rep ; + +INSN: ##alien-signed-2 +def: dst/int-rep +use: src/int-rep ; + +INSN: ##alien-signed-4 +def: dst/int-rep +use: src/int-rep ; + +INSN: ##alien-cell +def: dst/int-rep +use: src/int-rep ; + +INSN: ##alien-float +def: dst/float-rep +use: src/int-rep ; + +INSN: ##alien-double +def: dst/double-rep +use: src/int-rep ; + +INSN: ##alien-vector +def: dst +use: src/int-rep +literal: rep ; + +INSN: ##set-alien-integer-1 +use: src/int-rep value/int-rep ; + +INSN: ##set-alien-integer-2 +use: src/int-rep value/int-rep ; + +INSN: ##set-alien-integer-4 +use: src/int-rep value/int-rep ; + +INSN: ##set-alien-cell +use: src/int-rep value/int-rep ; + +INSN: ##set-alien-float +use: src/int-rep value/float-rep ; + +INSN: ##set-alien-double +use: src/int-rep value/double-rep ; + +INSN: ##set-alien-vector +use: src/int-rep value +literal: rep ; ! Memory allocation -INSN: ##allot < ##flushable size class temp ; +INSN: ##allot +def: dst/int-rep +literal: size class +temp: temp/int-rep ; -UNION: ##allocation -##allot -##box-float -##box-alien -##box-displaced-alien -##integer>bignum ; +INSN: ##write-barrier +use: src/int-rep +temp: card#/int-rep table/int-rep ; -INSN: ##write-barrier < ##effect card# table ; - -INSN: ##alien-global < ##flushable symbol library ; +INSN: ##alien-global +def: dst/int-rep +literal: symbol library ; ! FFI -INSN: ##alien-invoke params stack-frame ; -INSN: ##alien-indirect params stack-frame ; -INSN: ##alien-callback params stack-frame ; -INSN: ##callback-return params ; +INSN: ##alien-invoke +literal: params stack-frame ; + +INSN: ##alien-indirect +literal: params stack-frame ; + +INSN: ##alien-callback +literal: params stack-frame ; + +INSN: ##callback-return +literal: params ; ! Instructions used by CFG IR only. INSN: ##prologue ; @@ -184,133 +469,172 @@ INSN: ##epilogue ; INSN: ##branch ; -INSN: ##phi < ##pure inputs ; +INSN: ##phi +def: dst +literal: inputs ; ! Conditionals -TUPLE: ##conditional-branch < insn src1 src2 cc ; +INSN: ##compare-branch +use: src1/int-rep src2/int-rep +literal: cc ; -INSN: ##compare-branch < ##conditional-branch ; -INSN: ##compare-imm-branch src1 { src2 integer } cc ; +INSN: ##compare-imm-branch +use: src1/int-rep +constant: src2 +literal: cc ; -INSN: ##compare < ##binary cc temp ; -INSN: ##compare-imm < ##binary-imm cc temp ; +PURE-INSN: ##compare +def: dst/int-rep +use: src1/int-rep src2/int-rep +literal: cc +temp: temp/int-rep ; -INSN: ##compare-float-branch < ##conditional-branch ; -INSN: ##compare-float < ##binary cc temp ; +PURE-INSN: ##compare-imm +def: dst/int-rep +use: src1/int-rep +constant: src2 +literal: cc +temp: temp/int-rep ; + +INSN: ##compare-float-branch +use: src1/double-rep src2/double-rep +literal: cc ; + +PURE-INSN: ##compare-float +def: dst/int-rep +use: src1/double-rep src2/double-rep +literal: cc +temp: temp/int-rep ; ! 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: ##fixnum-add +def: dst/int-rep +use: src1/int-rep src2/int-rep ; -INSN: ##gc temp1 temp2 data-values tagged-values uninitialized-locs ; +INSN: ##fixnum-sub +def: dst/int-rep +use: src1/int-rep src2/int-rep ; + +INSN: ##fixnum-mul +def: dst/int-rep +use: src1/int-rep src2/int-rep ; + +INSN: ##gc +temp: temp1/int-rep temp2/int-rep +literal: data-values tagged-values uninitialized-locs ; ! Instructions used by machine IR only. -INSN: _prologue stack-frame ; -INSN: _epilogue stack-frame ; +INSN: _prologue +literal: stack-frame ; -INSN: _label id ; +INSN: _epilogue +literal: stack-frame ; + +INSN: _label +literal: label ; + +INSN: _branch +literal: label ; -INSN: _branch label ; INSN: _loop-entry ; -INSN: _dispatch src temp ; -INSN: _dispatch-label label ; +INSN: _dispatch +use: src/int-rep +temp: temp ; -TUPLE: _conditional-branch < insn label src1 src2 cc ; +INSN: _dispatch-label +literal: label ; -INSN: _compare-branch < _conditional-branch ; -INSN: _compare-imm-branch label src1 { src2 integer } cc ; +INSN: _compare-branch +literal: label +use: src1/int-rep src2/int-rep +literal: cc ; -INSN: _compare-float-branch < _conditional-branch ; +INSN: _compare-imm-branch +literal: label +use: src1/int-rep +constant: src2 +literal: cc ; + +INSN: _compare-float-branch +literal: label +use: src1/int-rep src2/int-rep +literal: cc ; ! 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 ; +INSN: _fixnum-add +literal: label +def: dst/int-rep +use: src1/int-rep src2/int-rep ; + +INSN: _fixnum-sub +literal: label +def: dst/int-rep +use: src1/int-rep src2/int-rep ; + +INSN: _fixnum-mul +literal: label +def: dst/int-rep +use: src1/int-rep src2/int-rep ; TUPLE: spill-slot n ; C: spill-slot -INSN: _gc temp1 temp2 data-values tagged-values uninitialized-locs ; +INSN: _gc +temp: temp1 temp2 +literal: data-values tagged-values uninitialized-locs ; ! These instructions operate on machine registers and not ! virtual registers -INSN: _spill src rep n ; -INSN: _reload dst rep n ; -INSN: _spill-area-size n ; +INSN: _spill +use: src +literal: rep 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 ; +INSN: _reload +def: dst +literal: rep n ; + +INSN: _spill-area-size +literal: n ; + +UNION: ##allocation +##allot +##box-float +##box-vector +##box-alien +##box-displaced-alien +##integer>bignum ; + +! For alias analysis +UNION: ##read ##slot ##slot-imm ; +UNION: ##write ##set-slot ##set-slot-imm ; ! Instructions that kill all live vregs but cannot trigger GC UNION: partial-sync-insn - ##unary-float-function - ##binary-float-function ; +##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 ; +##call +##prologue +##epilogue +##alien-invoke +##alien-indirect +##alien-callback ; ! 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 +##integer>bignum +##bignum>integer +##unbox-any-c-ptr ; + +SYMBOL: vreg-insn + +[ + vreg-insn + insn-classes get [ + "insn-slots" word-prop [ type>> { def use temp } memq? ] any? + ] filter + define-union-class +] with-compilation-unit \ 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 ab1c9599e5..cc1d0df21c 100644 --- a/basis/compiler/cfg/instructions/syntax/syntax.factor +++ b/basis/compiler/cfg/instructions/syntax/syntax.factor @@ -1,22 +1,84 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: classes.tuple classes.tuple.parser kernel words -make fry sequences parser accessors effects ; +make fry sequences parser accessors effects namespaces +combinators splitting classes.parser lexer quotations ; IN: compiler.cfg.instructions.syntax +SYMBOLS: def use temp literal constant ; + +SYMBOL: scalar-rep + +TUPLE: insn-slot-spec type name rep ; + +: parse-rep ( str/f -- rep ) + { + { [ dup not ] [ ] } + { [ dup "scalar-rep" = ] [ drop scalar-rep ] } + [ "cpu.architecture" lookup ] + } cond ; + +: parse-insn-slot-spec ( type string -- spec ) + over [ "Missing type" throw ] unless + "/" split1 parse-rep + insn-slot-spec boa ; + +: parse-insn-slot-specs ( seq -- specs ) + [ + f [ + { + { "def:" [ drop def ] } + { "use:" [ drop use ] } + { "temp:" [ drop temp ] } + { "literal:" [ drop literal ] } + { "constant:" [ drop constant ] } + [ dupd parse-insn-slot-spec , ] + } case + ] reduce drop + ] { } make ; + +: insn-def-slot ( class -- slot/f ) + "insn-slots" word-prop + [ type>> def eq? ] find nip ; + +: insn-use-slots ( class -- slot/f ) + "insn-slots" word-prop + [ type>> use eq? ] filter ; + +: insn-temp-slots ( class -- slot/f ) + "insn-slots" word-prop + [ type>> temp eq? ] filter ; + +! We cannot reference words in compiler.cfg.instructions directly +! since that would create circularity. +: insn-classes-word ( -- word ) + "insn-classes" "compiler.cfg.instructions" lookup ; + : insn-word ( -- word ) - #! We want to put the insn tuple in compiler.cfg.instructions, - #! but we cannot have circularity between that vocabulary and - #! this one. "insn" "compiler.cfg.instructions" lookup ; +: pure-insn-word ( -- word ) + "pure-insn" "compiler.cfg.instructions" lookup ; + : insn-effect ( word -- effect ) boa-effect in>> but-last f ; -SYNTAX: INSN: - parse-tuple-definition "insn#" suffix - [ dup tuple eq? [ drop insn-word ] when ] dip - [ define-tuple-class ] - [ 2drop save-location ] - [ 2drop [ ] [ '[ f _ boa , ] ] [ insn-effect ] tri define-inline ] - 3tri ; +: define-insn-tuple ( class superclass specs -- ) + [ name>> ] map "insn#" suffix define-tuple-class ; + +: define-insn-ctor ( class specs -- ) + [ dup '[ _ ] [ f ] [ boa , ] surround ] dip + [ name>> ] map f define-declared ; + +: define-insn ( class superclass specs -- ) + parse-insn-slot-specs { + [ nip "insn-slots" set-word-prop ] + [ 2drop insn-classes-word get push ] + [ define-insn-tuple ] + [ 2drop save-location ] + [ nip define-insn-ctor ] + } 3cleave ; + +SYNTAX: INSN: CREATE-CLASS insn-word ";" parse-tokens define-insn ; + +SYNTAX: PURE-INSN: CREATE-CLASS pure-insn-word ";" parse-tokens define-insn ; diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor index c2faf27f03..2b903813a0 100644 --- a/basis/compiler/cfg/intrinsics/alien/alien.factor +++ b/basis/compiler/cfg/intrinsics/alien/alien.factor @@ -20,22 +20,10 @@ IN: compiler.cfg.intrinsics.alien ^^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 ; - -: (prepare-alien-accessor) ( class -- offset-vreg ) - [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ; - -: prepare-alien-accessor ( infos -- offset-vreg ) - [ second class>> ] [ first ] bi - dup value-info-small-fixnum? [ - literal>> (prepare-alien-accessor-imm) - ] [ drop (prepare-alien-accessor) ] if ; - :: inline-alien ( node quot test -- ) [let | infos [ node node-input-infos ] | infos test call - [ infos prepare-alien-accessor quot call ] + [ infos quot call ] [ node emit-primitive ] if ] ; inline @@ -45,8 +33,14 @@ IN: compiler.cfg.intrinsics.alien [ second class>> fixnum class<= ] bi and ; +: prepare-alien-accessor ( info -- offset-vreg ) + class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ; + +: prepare-alien-getter ( infos -- offset-vreg ) + first prepare-alien-accessor ; + : inline-alien-getter ( node quot -- ) - '[ @ ds-push ] + '[ prepare-alien-getter @ ds-push ] [ inline-alien-getter? ] inline-alien ; inline : inline-alien-setter? ( infos class -- ? ) @@ -55,19 +49,21 @@ IN: compiler.cfg.intrinsics.alien [ third class>> fixnum class<= ] tri and and ; +: prepare-alien-setter ( infos -- offset-vreg ) + second prepare-alien-accessor ; + : inline-alien-integer-setter ( node quot -- ) - '[ ds-pop ^^untag-fixnum @ ] + '[ prepare-alien-setter ds-pop ^^untag-fixnum @ ] [ fixnum inline-alien-setter? ] inline-alien ; inline : inline-alien-cell-setter ( node quot -- ) - [ dup node-input-infos first class>> ] dip - '[ ds-pop _ ^^unbox-c-ptr @ ] + '[ [ prepare-alien-setter ds-pop ] [ first class>> ] bi ^^unbox-c-ptr @ ] [ pinned-c-ptr inline-alien-setter? ] inline-alien ; inline : inline-alien-float-setter ( node quot -- ) - '[ ds-pop @ ] + '[ prepare-alien-setter ds-pop @ ] [ float inline-alien-setter? ] inline-alien ; inline @@ -107,15 +103,15 @@ IN: compiler.cfg.intrinsics.alien : emit-alien-float-getter ( node rep -- ) '[ _ { - { single-float-rep [ ^^alien-float ] } - { double-float-rep [ ^^alien-double ] } + { float-rep [ ^^alien-float ] } + { double-rep [ ^^alien-double ] } } case ] inline-alien-getter ; : emit-alien-float-setter ( node rep -- ) '[ _ { - { single-float-rep [ ##set-alien-float ] } - { double-float-rep [ ##set-alien-double ] } + { float-rep [ ##set-alien-float ] } + { double-rep [ ##set-alien-double ] } } case ] inline-alien-float-setter ; diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index d4b9db58c8..2e2bfd5f09 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -2,6 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: sequences accessors layouts kernel math math.intervals namespaces combinators fry arrays +cpu.architecture compiler.tree.propagation.info compiler.cfg.hats compiler.cfg.stacks @@ -71,7 +72,7 @@ IN: compiler.cfg.intrinsics.fixnum : emit-fixnum-overflow-op ( quot word -- ) ! Inputs to the final instruction need to be copied because ! of loc>vreg sync - [ [ (2inputs) [ ^^copy ] bi@ ] dip call ] dip + [ [ (2inputs) [ any-rep ^^copy ] bi@ ] dip call ] dip [ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array emit-conditional ; inline diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 920def14c1..612e9dcdc4 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -7,6 +7,7 @@ compiler.cfg.intrinsics.alien compiler.cfg.intrinsics.allot compiler.cfg.intrinsics.fixnum compiler.cfg.intrinsics.float +compiler.cfg.intrinsics.simd compiler.cfg.intrinsics.slots compiler.cfg.intrinsics.misc compiler.cfg.comparisons ; @@ -22,6 +23,7 @@ QUALIFIED: classes.tuple.private QUALIFIED: math.private QUALIFIED: math.integers.private QUALIFIED: math.floats.private +QUALIFIED: math.vectors.simd.intrinsics QUALIFIED: math.libm IN: compiler.cfg.intrinsics @@ -91,10 +93,10 @@ IN: compiler.cfg.intrinsics { 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 ] } + { alien.accessors:alien-float [ float-rep emit-alien-float-getter ] } + { alien.accessors:set-alien-float [ float-rep emit-alien-float-setter ] } + { alien.accessors:alien-double [ double-rep emit-alien-float-getter ] } + { alien.accessors:set-alien-double [ double-rep emit-alien-float-setter ] } } enable-intrinsics ; : enable-fsqrt ( -- ) @@ -142,5 +144,27 @@ IN: compiler.cfg.intrinsics { math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] } } enable-intrinsics ; +: enable-sse2-simd ( -- ) + { + { math.vectors.simd.intrinsics:assert-positive [ drop ] } + { math.vectors.simd.intrinsics:(simd-v+) [ [ ^^add-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-v-) [ [ ^^sub-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-v*) [ [ ^^mul-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-v/) [ [ ^^div-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vmin) [ [ ^^min-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vmax) [ [ ^^max-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-broadcast) [ [ ^^broadcast-vector ] emit-unary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-gather-2) [ emit-gather-vector-2 ] } + { math.vectors.simd.intrinsics:(simd-gather-4) [ emit-gather-vector-4 ] } + { math.vectors.simd.intrinsics:alien-vector [ emit-alien-vector ] } + { math.vectors.simd.intrinsics:set-alien-vector [ emit-set-alien-vector ] } + } enable-intrinsics ; + +: enable-sse3-simd ( -- ) + { + { math.vectors.simd.intrinsics:(simd-sum) [ [ ^^horizontal-add-vector ] emit-unary-vector-op ] } + } enable-intrinsics ; + : emit-intrinsic ( node word -- ) "intrinsic" word-prop call( node -- ) ; diff --git a/basis/compiler/cfg/intrinsics/simd/authors.txt b/basis/compiler/cfg/intrinsics/simd/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/compiler/cfg/intrinsics/simd/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/compiler/cfg/intrinsics/simd/simd.factor b/basis/compiler/cfg/intrinsics/simd/simd.factor new file mode 100644 index 0000000000..f1a6f986df --- /dev/null +++ b/basis/compiler/cfg/intrinsics/simd/simd.factor @@ -0,0 +1,55 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors byte-arrays fry cpu.architecture kernel +sequences compiler.tree.propagation.info +compiler.cfg.builder.blocks compiler.cfg.stacks +compiler.cfg.stacks.local compiler.cfg.hats +compiler.cfg.instructions compiler.cfg.registers +compiler.cfg.intrinsics.alien ; +IN: compiler.cfg.intrinsics.simd + +: emit-vector-op ( node quot: ( rep -- ) -- ) + [ dup node-input-infos last literal>> ] dip over representation? + [ [ drop ] 2dip call ] [ 2drop emit-primitive ] if ; inline + +: emit-binary-vector-op ( node quot -- ) + '[ [ ds-drop 2inputs ] dip @ ds-push ] emit-vector-op ; inline + +: emit-unary-vector-op ( node quot -- ) + '[ [ ds-drop ds-pop ] dip @ ds-push ] emit-vector-op ; inline + +: emit-gather-vector-2 ( node -- ) + [ ^^gather-vector-2 ] emit-binary-vector-op ; + +: emit-gather-vector-4 ( node -- ) + [ + ds-drop + [ + D 3 peek-loc + D 2 peek-loc + D 1 peek-loc + D 0 peek-loc + -4 inc-d + ] dip + ^^gather-vector-4 + ds-push + ] emit-vector-op ; + +: emit-alien-vector ( node -- ) + dup [ + '[ + ds-drop prepare-alien-getter + _ ^^alien-vector ds-push + ] + [ inline-alien-getter? ] inline-alien + ] with emit-vector-op ; + +: emit-set-alien-vector ( node -- ) + dup [ + '[ + ds-drop prepare-alien-setter ds-pop + _ ##set-alien-vector + ] + [ byte-array inline-alien-setter? ] + inline-alien + ] with emit-vector-op ; diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor index 79e56c08ad..5ae51a28e2 100644 --- a/basis/compiler/cfg/intrinsics/slots/slots.factor +++ b/basis/compiler/cfg/intrinsics/slots/slots.factor @@ -29,7 +29,7 @@ IN: compiler.cfg.intrinsics.slots : (emit-set-slot) ( infos -- obj-reg ) [ 3inputs ^^offset>slot ] [ second value-tag ] bi* - pick [ ^^set-slot ] dip ; + pick [ next-vreg ##set-slot ] dip ; : (emit-set-slot-imm) ( infos -- obj-reg ) ds-drop diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 03df2d9747..8754b65475 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -135,7 +135,7 @@ M: vreg-insn assign-registers-in-insn [ [ 2dup spill-on-gc? - [ swap [ vreg-spill-slot ] [ rep-of ] bi 3array , ] [ 2drop ] if + [ swap [ rep-of ] [ vreg-spill-slot ] bi 3array , ] [ 2drop ] if ] assoc-each ] { } make ; diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index 062c62adab..f09fe403e6 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -80,9 +80,9 @@ cfg new 0 >>spill-area-size cfg set H{ } spill-slots set H{ - { 1 single-float-rep } - { 2 single-float-rep } - { 3 single-float-rep } + { 1 float-rep } + { 2 float-rep } + { 3 float-rep } } representations set [ diff --git a/basis/compiler/cfg/renaming/functor/functor.factor b/basis/compiler/cfg/renaming/functor/functor.factor index b307155091..2af68e9175 100644 --- a/basis/compiler/cfg/renaming/functor/functor.factor +++ b/basis/compiler/cfg/renaming/functor/functor.factor @@ -1,9 +1,15 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: functors assocs kernel accessors compiler.cfg.instructions -lexer parser ; +USING: accessors arrays assocs fry functors generic.parser +kernel lexer namespaces parser sequences slots words sets +compiler.cfg.def-use compiler.cfg.instructions +compiler.cfg.instructions.syntax ; IN: compiler.cfg.renaming.functor +: slot-change-quot ( slots quot -- quot' ) + '[ [ _ ] dip changer-word [ ] 2sequence ] map [ ] join + [ drop ] append ; + FUNCTOR: define-renaming ( NAME DEF-QUOT USE-QUOT TEMP-QUOT -- ) rename-insn-defs DEFINES ${NAME}-insn-defs @@ -14,155 +20,30 @@ 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 ; +insn-classes get [ + [ \ rename-insn-defs create-method-in ] + [ insn-def-slot dup [ name>> 1array ] when DEF-QUOT slot-change-quot ] bi + define +] each 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 ; +insn-classes get { ##phi } diff [ + [ \ rename-insn-uses create-method-in ] + [ insn-use-slots [ name>> ] map USE-QUOT slot-change-quot ] bi + define +] each M: ##phi rename-insn-uses - [ USE-QUOT assoc-map ] change-inputs - drop ; - -M: insn rename-insn-uses drop ; + [ USE-QUOT assoc-map ] change-inputs 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 ; +insn-classes get [ + [ \ rename-insn-temps create-method-in ] + [ insn-temp-slots [ name>> ] map TEMP-QUOT slot-change-quot ] bi + define +] each ;FUNCTOR diff --git a/basis/compiler/cfg/representations/preferred/preferred.factor b/basis/compiler/cfg/representations/preferred/preferred.factor index 4b071ba5e2..389b78c333 100644 --- a/basis/compiler/cfg/representations/preferred/preferred.factor +++ b/basis/compiler/cfg/representations/preferred/preferred.factor @@ -1,66 +1,61 @@ ! 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 ; +USING: kernel accessors sequences arrays fry namespaces generic +words sets combinators generalizations cpu.architecture compiler.units +compiler.cfg.utilities compiler.cfg compiler.cfg.rpo +compiler.cfg.instructions compiler.cfg.instructions.syntax +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 ; +> ] ] } + { scalar-rep [ [ rep>> scalar-rep-of ] ] } + [ [ drop ] swap suffix ] + } case ; -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 ; +: define-defs-vreg-rep-method ( insn -- ) + [ \ defs-vreg-rep create-method ] + [ insn-def-slot [ rep>> rep-getter-quot ] [ [ drop f ] ] if* ] + bi define ; + +: reps-getter-quot ( reps -- quot ) + dup [ rep>> { f scalar-rep } memq? not ] all? [ + [ rep>> ] map [ drop ] swap suffix + ] [ + [ rep>> rep-getter-quot ] map dup length { + { 0 [ drop [ drop f ] ] } + { 1 [ first [ 1array ] compose ] } + { 2 [ first2 '[ _ _ bi 2array ] ] } + [ '[ _ cleave _ narray ] ] + } case + ] if ; + +: define-uses-vreg-reps-method ( insn -- ) + [ \ uses-vreg-reps create-method ] + [ insn-use-slots reps-getter-quot ] + bi define ; + +: define-temp-vreg-reps-method ( insn -- ) + [ \ temp-vreg-reps create-method ] + [ insn-temp-slots reps-getter-quot ] + bi define ; + +PRIVATE> + +[ + insn-classes get + [ [ define-defs-vreg-rep-method ] each ] + [ { ##phi } diff [ define-uses-vreg-reps-method ] each ] + [ [ define-temp-vreg-reps-method ] each ] + tri +] with-compilation-unit : each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- ) [ [ defs-vreg ] [ defs-vreg-rep ] bi ] dip with when* ; inline diff --git a/basis/compiler/cfg/representations/representations-tests.factor b/basis/compiler/cfg/representations/representations-tests.factor index 29f0fa064f..c50cfc4c86 100644 --- a/basis/compiler/cfg/representations/representations-tests.factor +++ b/basis/compiler/cfg/representations/representations-tests.factor @@ -3,7 +3,7 @@ compiler.cfg.registers compiler.cfg.instructions compiler.cfg.representations.preferred ; IN: compiler.cfg.representations -[ { double-float-rep double-float-rep } ] [ +[ { double-rep double-rep } ] [ T{ ##add-float { dst 5 } { src1 3 } @@ -11,7 +11,7 @@ IN: compiler.cfg.representations } uses-vreg-reps ] unit-test -[ double-float-rep ] [ +[ double-rep ] [ T{ ##alien-double { dst 5 } { src 3 } diff --git a/basis/compiler/cfg/representations/representations.factor b/basis/compiler/cfg/representations/representations.factor index cb98eb0ae5..ec2856f647 100644 --- a/basis/compiler/cfg/representations/representations.factor +++ b/basis/compiler/cfg/representations/representations.factor @@ -5,6 +5,7 @@ arrays combinators make locals deques dlists cpu.architecture compiler.utilities compiler.cfg compiler.cfg.rpo +compiler.cfg.hats compiler.cfg.registers compiler.cfg.instructions compiler.cfg.def-use @@ -16,13 +17,52 @@ IN: compiler.cfg.representations ! Virtual register representation selection. +ERROR: bad-conversion dst src dst-rep src-rep ; + +GENERIC: emit-box ( dst src rep -- ) +GENERIC: emit-unbox ( dst src rep -- ) + +M: float-rep emit-box + drop + [ double-rep next-vreg-rep dup ] dip ##single>double-float + int-rep next-vreg-rep ##box-float ; + +M: float-rep emit-unbox + drop + [ double-rep next-vreg-rep dup ] dip ##unbox-float + ##double>single-float ; + +M: double-rep emit-box + drop + int-rep next-vreg-rep ##box-float ; + +M: double-rep emit-unbox + drop ##unbox-float ; + +M: vector-rep emit-box + int-rep next-vreg-rep ##box-vector ; + +M: vector-rep emit-unbox + ##unbox-vector ; + : 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 ; + { + { [ 2dup eq? ] [ drop ##copy ] } + { [ dup int-rep eq? ] [ drop emit-unbox ] } + { [ over int-rep eq? ] [ nip emit-box ] } + [ + 2dup 2array { + { { double-rep float-rep } [ 2drop ##single>double-float ] } + { { float-rep double-rep } [ 2drop ##double>single-float ] } + ! Punning SIMD vector types? Naughty naughty! But + ! it is allowed... otherwise bail out. + [ + drop 2dup [ reg-class-of ] bi@ eq? + [ drop ##copy ] [ bad-conversion ] if + ] + } case + ] + } cond ; ( constant -- expr ) - f swap constant-expr boa ; inline +C: constant-expr M: constant-expr equal? over constant-expr? [ @@ -27,8 +20,9 @@ M: constant-expr equal? } 2&& ] [ 2drop f ] if ; -: ( constant -- expr ) - f swap reference-expr boa ; inline +TUPLE: reference-expr < expr value ; + +C: reference-expr M: reference-expr equal? over reference-expr? [ @@ -43,73 +37,42 @@ M: reference-expr equal? GENERIC: >expr ( insn -- expr ) +M: insn >expr drop next-input-expr ; + M: ##load-immediate >expr val>> ; M: ##load-reference >expr obj>> ; -M: ##unary >expr - [ class ] [ src>> vreg>vn ] bi unary-expr boa ; +<< -M: ##binary >expr - [ class ] [ src1>> vreg>vn ] [ src2>> vreg>vn ] tri - binary-expr boa ; +: input-values ( slot-specs -- slot-specs' ) + [ type>> { use literal constant } memq? ] filter ; -M: ##binary-imm >expr - [ class ] [ src1>> vreg>vn ] [ src2>> constant>vn ] tri - binary-expr boa ; +: expr-class ( insn -- expr ) + name>> "##" ?head drop "-expr" append create-class-in ; -M: ##commutative >expr - [ class ] [ src1>> vreg>vn ] [ src2>> vreg>vn ] tri - commutative-expr boa ; +: define-expr-class ( insn expr slot-specs -- ) + [ nip expr ] dip [ name>> ] map define-tuple-class ; -M: ##commutative-imm >expr - [ class ] [ src1>> vreg>vn ] [ src2>> constant>vn ] tri - commutative-expr boa ; +: >expr-quot ( expr slot-specs -- quot ) + [ + [ name>> reader-word 1quotation ] + [ + type>> { + { use [ [ vreg>vn ] ] } + { literal [ [ ] ] } + { constant [ [ constant>vn ] ] } + } case + ] bi append + ] map cleave>quot swap suffix \ boa suffix ; -: compare>expr ( insn -- expr ) - { - [ class ] - [ src1>> vreg>vn ] - [ src2>> vreg>vn ] - [ cc>> ] - } cleave compare-expr boa ; inline +: define->expr-method ( insn expr slot-specs -- ) + [ 2drop \ >expr create-method-in ] [ >expr-quot nip ] 3bi define ; -M: ##compare >expr compare>expr ; +: handle-pure-insn ( insn -- ) + [ ] [ expr-class ] [ "insn-slots" word-prop input-values ] tri + [ define-expr-class ] [ define->expr-method ] 3bi ; -: compare-imm>expr ( insn -- expr ) - { - [ class ] - [ src1>> vreg>vn ] - [ src2>> constant>vn ] - [ cc>> ] - } cleave compare-expr boa ; inline +insn-classes get [ pure-insn class<= ] filter [ handle-pure-insn ] each -M: ##compare-imm >expr compare-imm>expr ; - -M: ##compare-float >expr compare>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 77b75bd3ac..f380ecd02f 100644 --- a/basis/compiler/cfg/value-numbering/graph/graph.factor +++ b/basis/compiler/cfg/value-numbering/graph/graph.factor @@ -10,7 +10,7 @@ SYMBOL: vn-counter ! biassoc mapping expressions to value numbers SYMBOL: exprs>vns -TUPLE: expr op ; +TUPLE: expr ; : expr>vn ( expr -- vn ) exprs>vns get [ drop next-vn ] cache ; @@ -22,7 +22,7 @@ TUPLE: input-expr < expr n ; SYMBOL: input-expr-counter : next-input-expr ( -- expr ) - f input-expr-counter counter input-expr boa ; + input-expr-counter counter input-expr boa ; SYMBOL: vregs>vns @@ -41,5 +41,6 @@ SYMBOL: vregs>vns : init-value-graph ( -- ) 0 vn-counter set + 0 input-expr-counter set exprs>vns set vregs>vns set ; diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor index 2662dc4665..cf3baf27eb 100755 --- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor +++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor @@ -32,27 +32,30 @@ M: insn rewrite drop f ; } 1&& ] [ drop f ] if ; inline +: general-compare-expr? ( insn -- ? ) + { [ compare-expr? ] [ compare-imm-expr? ] [ compare-float-expr? ] } 1|| ; + : rewrite-boolean-comparison? ( insn -- ? ) dup ##branch-t? [ - src1>> vreg>expr compare-expr? + src1>> vreg>expr general-compare-expr? ] [ drop f ] if ; inline : >compare-expr< ( expr -- in1 in2 cc ) - [ in1>> vn>vreg ] [ in2>> vn>vreg ] [ cc>> ] tri ; inline + [ src1>> vn>vreg ] [ src2>> vn>vreg ] [ cc>> ] tri ; inline : >compare-imm-expr< ( expr -- in1 in2 cc ) - [ in1>> vn>vreg ] [ in2>> vn>constant ] [ cc>> ] tri ; inline + [ src1>> vn>vreg ] [ src2>> vn>constant ] [ cc>> ] tri ; inline : rewrite-boolean-comparison ( expr -- insn ) - src1>> vreg>expr dup op>> { - { \ ##compare [ >compare-expr< \ ##compare-branch new-insn ] } - { \ ##compare-imm [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] } - { \ ##compare-float [ >compare-expr< \ ##compare-float-branch new-insn ] } - } case ; + src1>> vreg>expr { + { [ dup compare-expr? ] [ >compare-expr< \ ##compare-branch new-insn ] } + { [ dup compare-imm-expr? ] [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] } + { [ dup compare-float-expr? ] [ >compare-expr< \ ##compare-float-branch new-insn ] } + } cond ; : tag-fixnum-expr? ( expr -- ? ) - dup op>> \ ##shl-imm eq? - [ in2>> vn>constant tag-bits get = ] [ drop f ] if ; + dup shl-imm-expr? + [ src2>> vn>constant tag-bits get = ] [ drop f ] if ; : rewrite-tagged-comparison? ( insn -- ? ) #! Are we comparing two tagged fixnums? Then untag them. @@ -65,7 +68,7 @@ M: insn rewrite drop f ; tag-bits get neg shift ; inline : (rewrite-tagged-comparison) ( insn -- src1 src2 cc ) - [ src1>> vreg>expr in1>> vn>vreg ] + [ src1>> vreg>expr src1>> vn>vreg ] [ src2>> tagged>constant ] [ cc>> ] tri ; inline @@ -81,17 +84,17 @@ M: ##compare-imm rewrite-tagged-comparison : rewrite-redundant-comparison? ( insn -- ? ) { - [ src1>> vreg>expr compare-expr? ] + [ src1>> vreg>expr general-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< 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 + [ cc>> ] [ dst>> ] [ src1>> vreg>expr ] tri { + { [ dup compare-expr? ] [ >compare-expr< next-vreg \ ##compare new-insn ] } + { [ dup compare-imm-expr? ] [ >compare-imm-expr< next-vreg \ ##compare-imm new-insn ] } + { [ dup compare-float-expr? ] [ >compare-expr< next-vreg \ ##compare-float new-insn ] } + } cond swap cc= eq? [ [ negate-cc ] change-cc ] when ; ERROR: bad-comparison ; @@ -220,14 +223,11 @@ M: ##shl-imm constant-fold* drop shift ; [ [ 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 ] + [ src1>> vreg>expr [ src1>> vn>vreg ] [ src2>> vn>constant ] bi ] [ src2>> ] [ ] } cleave constant-fold* @@ -237,7 +237,7 @@ M: ##shl-imm constant-fold* drop shift ; M: ##add-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } - { [ dup reassociate? ] [ \ ##add-imm reassociate ] } + { [ dup src1>> vreg>expr add-imm-expr? ] [ \ ##add-imm reassociate ] } [ drop f ] } cond ; @@ -261,28 +261,28 @@ M: ##mul-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } { [ dup strength-reduce-mul? ] [ strength-reduce-mul ] } - { [ dup reassociate? ] [ \ ##mul-imm reassociate ] } + { [ dup src1>> vreg>expr mul-imm-expr? ] [ \ ##mul-imm reassociate ] } [ drop f ] } cond ; M: ##and-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } - { [ dup reassociate? ] [ \ ##and-imm reassociate ] } + { [ dup src1>> vreg>expr and-imm-expr? ] [ \ ##and-imm reassociate ] } [ drop f ] } cond ; M: ##or-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } - { [ dup reassociate? ] [ \ ##or-imm reassociate ] } + { [ dup src1>> vreg>expr or-imm-expr? ] [ \ ##or-imm reassociate ] } [ drop f ] } cond ; M: ##xor-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } - { [ dup reassociate? ] [ \ ##xor-imm reassociate ] } + { [ dup src1>> vreg>expr xor-imm-expr? ] [ \ ##xor-imm reassociate ] } [ drop f ] } cond ; @@ -351,9 +351,6 @@ 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 ! => @@ -369,5 +366,5 @@ M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ; ] { } make ; M: ##unbox-any-c-ptr rewrite - dup src>> vreg>expr dup box-displaced-alien? + dup src>> vreg>expr dup box-displaced-alien-expr? [ 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 6508801840..e930bcaae9 100644 --- a/basis/compiler/cfg/value-numbering/simplify/simplify.factor +++ b/basis/compiler/cfg/value-numbering/simplify/simplify.factor @@ -1,33 +1,29 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors combinators classes math layouts compiler.cfg.instructions compiler.cfg.value-numbering.graph -compiler.cfg.value-numbering.expressions locals ; +compiler.cfg.value-numbering.expressions ; IN: compiler.cfg.value-numbering.simplify ! Return value of f means we didn't simplify. GENERIC: simplify* ( expr -- vn/expr/f ) -: simplify-unbox-alien ( in -- vn/expr/f ) - dup op>> \ ##box-alien eq? [ in>> ] [ drop f ] if ; inline +M: copy-expr simplify* src>> ; -M: unary-expr simplify* - #! Note the copy propagation: a copy always simplifies to - #! its source VN. - [ in>> vn>expr ] [ op>> ] bi { - { \ ##copy [ ] } - { \ ##unbox-alien [ simplify-unbox-alien ] } - { \ ##unbox-any-c-ptr [ simplify-unbox-alien ] } - [ 2drop f ] - } case ; +: simplify-unbox-alien ( expr -- vn/expr/f ) + src>> vn>expr dup box-alien-expr? [ src>> ] [ drop f ] if ; -: expr-zero? ( expr -- ? ) T{ constant-expr f f 0 } = ; inline +M: unbox-alien-expr simplify* simplify-unbox-alien ; -: expr-one? ( expr -- ? ) T{ constant-expr f f 1 } = ; inline +M: unbox-any-c-ptr-expr simplify* simplify-unbox-alien ; + +: expr-zero? ( expr -- ? ) T{ constant-expr f 0 } = ; inline + +: expr-one? ( expr -- ? ) T{ constant-expr f 1 } = ; inline : >binary-expr< ( expr -- in1 in2 ) - [ in1>> vn>expr ] [ in2>> vn>expr ] bi ; inline + [ src1>> vn>expr ] [ src2>> vn>expr ] bi ; inline : simplify-add ( expr -- vn/expr/f ) >binary-expr< { @@ -36,12 +32,18 @@ M: unary-expr simplify* [ 2drop f ] } cond ; inline +M: add-expr simplify* simplify-add ; +M: add-imm-expr simplify* simplify-add ; + : simplify-sub ( expr -- vn/expr/f ) >binary-expr< { { [ dup expr-zero? ] [ drop ] } [ 2drop f ] } cond ; inline +M: sub-expr simplify* simplify-sub ; +M: sub-imm-expr simplify* simplify-sub ; + : simplify-mul ( expr -- vn/expr/f ) >binary-expr< { { [ over expr-one? ] [ drop ] } @@ -49,12 +51,18 @@ M: unary-expr simplify* [ 2drop f ] } cond ; inline +M: mul-expr simplify* simplify-mul ; +M: mul-imm-expr simplify* simplify-mul ; + : simplify-and ( expr -- vn/expr/f ) >binary-expr< { { [ 2dup eq? ] [ drop ] } [ 2drop f ] } cond ; inline +M: and-expr simplify* simplify-and ; +M: and-imm-expr simplify* simplify-and ; + : simplify-or ( expr -- vn/expr/f ) >binary-expr< { { [ 2dup eq? ] [ drop ] } @@ -63,6 +71,9 @@ M: unary-expr simplify* [ 2drop f ] } cond ; inline +M: or-expr simplify* simplify-or ; +M: or-imm-expr simplify* simplify-or ; + : simplify-xor ( expr -- vn/expr/f ) >binary-expr< { { [ over expr-zero? ] [ nip ] } @@ -70,45 +81,31 @@ M: unary-expr simplify* [ 2drop f ] } cond ; inline +M: xor-expr simplify* simplify-xor ; +M: xor-imm-expr simplify* simplify-xor ; + : useless-shr? ( in1 in2 -- ? ) - over op>> \ ##shl-imm eq? - [ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline + over shl-imm-expr? + [ [ src2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline : simplify-shr ( expr -- vn/expr/f ) >binary-expr< { - { [ 2dup useless-shr? ] [ drop in1>> ] } + { [ 2dup useless-shr? ] [ drop src1>> ] } { [ dup expr-zero? ] [ drop ] } [ 2drop f ] } cond ; inline +M: shr-expr simplify* simplify-shr ; +M: shr-imm-expr simplify* simplify-shr ; + : simplify-shl ( expr -- vn/expr/f ) >binary-expr< { { [ dup expr-zero? ] [ drop ] } [ 2drop f ] } cond ; inline -M: binary-expr simplify* - dup op>> { - { \ ##add [ simplify-add ] } - { \ ##add-imm [ simplify-add ] } - { \ ##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: shl-expr simplify* simplify-shl ; +M: shl-imm-expr simplify* simplify-shl ; M: box-displaced-alien-expr simplify* [ base>> ] [ displacement>> ] bi { diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor index 6874f2c001..96ca3efcf2 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering.factor @@ -6,6 +6,7 @@ cpu.architecture sequences.deep compiler.cfg compiler.cfg.rpo +compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.value-numbering.graph compiler.cfg.value-numbering.expressions @@ -16,29 +17,21 @@ IN: compiler.cfg.value-numbering ! Local value numbering. : >copy ( insn -- insn/##copy ) - dup dst>> dup vreg>vn vn>vreg + dup defs-vreg 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 ; + [ process-instruction ] + [ dup defs-vreg [ dup number-values >copy ] when ] ?if ; M: array process-instruction [ process-instruction ] map ; : value-numbering-step ( insns -- insns' ) init-value-graph - init-expressions [ process-instruction ] map flatten ; : value-numbering ( cfg -- cfg' ) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 00a36cc55f..3587d62706 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -5,7 +5,7 @@ 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 classes locals -source-files.errors +source-files.errors slots parser generic.parser compiler.errors compiler.alien compiler.constants @@ -67,170 +67,153 @@ SYMBOL: labels : lookup-label ( id -- label ) labels get [ drop