diff --git a/basis/cocoa/types/types.factor b/basis/cocoa/types/types.factor index 6e65bc1a72..0bf4257a0b 100644 --- a/basis/cocoa/types/types.factor +++ b/basis/cocoa/types/types.factor @@ -46,6 +46,7 @@ C-STRUCT: NSSize { "CGFloat" "h" } ; TYPEDEF: NSSize _NSSize +TYPEDEF: NSSize CGSize TYPEDEF: NSPoint CGPoint : ( w h -- size ) diff --git a/basis/compiler/generator/registers/registers.factor b/basis/compiler/generator/registers/registers.factor index 76d3c32594..6fdb8d9886 100755 --- a/basis/compiler/generator/registers/registers.factor +++ b/basis/compiler/generator/registers/registers.factor @@ -50,13 +50,21 @@ C: vreg ( n reg-class -- vreg ) M: vreg v>operand [ n>> ] [ reg-class>> ] bi vregs nth ; M: vreg live-vregs* , ; -M: vreg move-spec reg-class>> move-spec ; + +M: vreg move-spec + reg-class>> { + { [ dup int-regs? ] [ f ] } + { [ dup float-regs? ] [ float ] } + } cond nip ; + +M: vreg operand-class* + reg-class>> { + { [ dup int-regs? ] [ f ] } + { [ dup float-regs? ] [ float ] } + } cond nip ; INSTANCE: vreg value -M: float-regs move-spec drop float ; -M: float-regs operand-class* drop float ; - ! Temporary register for stack shuffling SINGLETON: temp-reg diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index e44ae681ff..dc73888796 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types alien.syntax compiler kernel namespaces namespaces tools.test sequences stack-checker stack-checker.errors words arrays parser quotations continuations effects namespaces.private io io.streams.string -memory system threads tools.test math accessors ; +memory system threads tools.test math accessors combinators ; FUNCTION: void ffi_test_0 ; [ ] [ ffi_test_0 ] unit-test @@ -401,3 +401,41 @@ C-STRUCT: test_struct_13 FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ; [ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test + +! Joe Groff found this problem +C-STRUCT: double-rect +{ "double" "a" } +{ "double" "b" } +{ "double" "c" } +{ "double" "d" } ; + +: ( a b c d -- foo ) + "double-rect" + { + [ set-double-rect-d ] + [ set-double-rect-c ] + [ set-double-rect-b ] + [ set-double-rect-a ] + [ ] + } cleave ; + +: >double-rect< ( foo -- a b c d ) + { + [ double-rect-a ] + [ double-rect-b ] + [ double-rect-c ] + [ double-rect-d ] + } cleave ; + +: double-rect-callback ( -- alien ) + "void" { "void*" "void*" "double-rect" } "cdecl" + [ "example" set-global 2drop ] alien-callback ; + +: double-rect-test ( arg -- arg' ) + f f rot + double-rect-callback + "void" { "void*" "void*" "double-rect" } "cdecl" alien-indirect + "example" get-global ; + +[ 1.0 2.0 3.0 4.0 ] +[ 1.0 2.0 3.0 4.0 double-rect-test >double-rect< ] unit-test diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 15bc6444ac..2e8eb15959 100644 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -10,12 +10,13 @@ compiler.tree compiler.tree.combinators compiler.tree.cleanup compiler.tree.builder +compiler.tree.recursive compiler.tree.normalization compiler.tree.propagation compiler.tree.checker ; : cleaned-up-tree ( quot -- nodes ) - build-tree normalize propagate cleanup dup check-nodes ; + build-tree analyze-recursive normalize propagate cleanup dup check-nodes ; [ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test diff --git a/basis/compiler/tree/dead-code/dead-code-tests.factor b/basis/compiler/tree/dead-code/dead-code-tests.factor index e8d2b29027..7b15fdf856 100644 --- a/basis/compiler/tree/dead-code/dead-code-tests.factor +++ b/basis/compiler/tree/dead-code/dead-code-tests.factor @@ -3,16 +3,17 @@ compiler.tree.dead-code compiler.tree.def-use compiler.tree compiler.tree.combinators compiler.tree.propagation compiler.tree.cleanup compiler.tree.escape-analysis compiler.tree.tuple-unboxing compiler.tree.debugger -compiler.tree.normalization compiler.tree.checker tools.test -kernel math stack-checker.state accessors combinators io -prettyprint words sequences.deep sequences.private arrays -classes kernel.private ; +compiler.tree.recursive compiler.tree.normalization +compiler.tree.checker tools.test kernel math stack-checker.state +accessors combinators io prettyprint words sequences.deep +sequences.private arrays classes kernel.private ; IN: compiler.tree.dead-code.tests \ remove-dead-code must-infer : count-live-values ( quot -- n ) build-tree + analyze-recursive normalize propagate cleanup @@ -64,6 +65,7 @@ IN: compiler.tree.dead-code.tests : optimize-quot ( quot -- quot' ) build-tree + analyze-recursive normalize propagate cleanup diff --git a/basis/compiler/tree/def-use/def-use-tests.factor b/basis/compiler/tree/def-use/def-use-tests.factor index 993627eb15..d970e04afd 100755 --- a/basis/compiler/tree/def-use/def-use-tests.factor +++ b/basis/compiler/tree/def-use/def-use-tests.factor @@ -1,9 +1,10 @@ USING: accessors namespaces assocs kernel sequences math tools.test words sets combinators.short-circuit stack-checker.state compiler.tree compiler.tree.builder -compiler.tree.normalization compiler.tree.propagation -compiler.tree.cleanup compiler.tree.def-use arrays kernel.private -sorting math.order binary-search compiler.tree.checker ; +compiler.tree.recursive compiler.tree.normalization +compiler.tree.propagation compiler.tree.cleanup +compiler.tree.def-use arrays kernel.private sorting math.order +binary-search compiler.tree.checker ; IN: compiler.tree.def-use.tests \ compute-def-use must-infer @@ -18,6 +19,7 @@ IN: compiler.tree.def-use.tests : test-def-use ( quot -- ) build-tree + analyze-recursive normalize propagate cleanup @@ -27,7 +29,14 @@ IN: compiler.tree.def-use.tests : too-deep ( a b -- c ) dup [ drop ] [ 2dup too-deep too-deep drop ] if ; inline recursive -[ ] [ [ too-deep ] build-tree normalize compute-def-use check-nodes ] unit-test +[ ] [ + [ too-deep ] + build-tree + analyze-recursive + normalize + compute-def-use + check-nodes +] unit-test ! compute-def-use checks for SSA violations, so we use that to ! ensure we generate some common patterns correctly. diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor index f51046c6cb..7ece8a5a80 100644 --- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor @@ -1,13 +1,14 @@ IN: compiler.tree.escape-analysis.tests USING: compiler.tree.escape-analysis compiler.tree.escape-analysis.allocations compiler.tree.builder -compiler.tree.normalization math.functions -compiler.tree.propagation compiler.tree.cleanup -compiler.tree.combinators compiler.tree sequences math math.private -kernel tools.test accessors slots.private quotations.private -prettyprint classes.tuple.private classes classes.tuple -compiler.intrinsics namespaces compiler.tree.propagation.info -stack-checker.errors kernel.private ; +compiler.tree.recursive compiler.tree.normalization +math.functions compiler.tree.propagation compiler.tree.cleanup +compiler.tree.combinators compiler.tree sequences math +math.private kernel tools.test accessors slots.private +quotations.private prettyprint classes.tuple.private classes +classes.tuple compiler.intrinsics namespaces +compiler.tree.propagation.info stack-checker.errors +kernel.private ; \ escape-analysis must-infer @@ -28,6 +29,7 @@ M: node count-unboxed-allocations* drop ; : count-unboxed-allocations ( quot -- sizes ) build-tree + analyze-recursive normalize propagate cleanup diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor index dafe032ab6..ba7e4ff652 100644 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/basis/compiler/tree/finalization/finalization.factor @@ -7,6 +7,7 @@ byte-arrays alien.accessors compiler.intrinsics compiler.tree compiler.tree.builder +compiler.tree.recursive compiler.tree.normalization compiler.tree.propagation compiler.tree.propagation.info @@ -39,6 +40,7 @@ M: #shuffle finalize* : splice-quot ( quot -- nodes ) [ build-tree + analyze-recursive normalize propagate cleanup diff --git a/basis/compiler/tree/identities/identities.factor b/basis/compiler/tree/identities/identities.factor new file mode 100644 index 0000000000..d6ed59cbaa --- /dev/null +++ b/basis/compiler/tree/identities/identities.factor @@ -0,0 +1,98 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel sequences fry words math +math.partial-dispatch combinators arrays hashtables +compiler.tree +compiler.tree.combinators +compiler.tree.propagation.info ; +IN: compiler.tree.identities + +: define-identities ( word identities -- ) + [ integer-derived-ops ] dip + '[ _ "identities" set-word-prop ] each ; + +SYMBOL: X + +\ + { + { { X 0 } drop } + { { 0 X } nip } +} define-identities + +\ - { + { { X 0 } drop } +} define-identities + +\ * { + { { X 1 } drop } + { { 1 X } nip } + { { X 0 } nip } + { { 0 X } drop } +} define-identities + +\ / { + { { X 1 } drop } +} define-identities + +\ mod { + { { X 1 } 0 } +} define-identities + +\ rem { + { { X 1 } 0 } +} define-identities + +\ bitand { + { { X -1 } drop } + { { -1 X } nip } + { { X 0 } nip } + { { 0 X } drop } +} define-identities + +\ bitor { + { { X 0 } drop } + { { 0 X } nip } + { { X -1 } nip } + { { -1 X } drop } +} define-identities + +\ bitxor { + { { X 0 } drop } + { { 0 X } nip } +} define-identities + +\ shift { + { { 0 X } drop } + { { X 0 } drop } +} define-identities + +: matches? ( pattern infos -- ? ) + [ over X eq? [ 2drop t ] [ literal>> = ] if ] 2all? ; + +: find-identity ( patterns infos -- result ) + '[ first _ matches? ] find swap [ second ] when ; + +GENERIC: apply-identities* ( node -- node ) + +: simplify-to-constant ( #call constant -- nodes ) + [ [ in-d>> #drop ] [ out-d>> first ] bi ] dip swap #push + 2array ; + +: select-input ( node n -- #shuffle ) + [ [ in-d>> ] [ out-d>> ] bi ] dip + pick nth over first associate #shuffle ; + +M: #call apply-identities* + dup word>> "identities" word-prop [ + over node-input-infos find-identity [ + { + { \ drop [ 0 select-input ] } + { \ nip [ 1 select-input ] } + [ simplify-to-constant ] + } case + ] when* + ] when* ; + +M: node apply-identities* ; + +: apply-identities ( nodes -- nodes' ) + [ apply-identities* ] map-nodes ; diff --git a/basis/compiler/tree/normalization/introductions/introductions.factor b/basis/compiler/tree/normalization/introductions/introductions.factor new file mode 100644 index 0000000000..9e96dc0472 --- /dev/null +++ b/basis/compiler/tree/normalization/introductions/introductions.factor @@ -0,0 +1,36 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces sequences accessors math kernel +compiler.tree ; +IN: compiler.tree.normalization.introductions + +SYMBOL: introductions + +GENERIC: count-introductions* ( node -- ) + +: count-introductions ( nodes -- n ) + #! Note: we use each, not each-node, since the #branch + #! method recurses into children directly and we don't + #! recurse into #recursive at all. + [ + 0 introductions set + [ count-introductions* ] each + introductions get + ] with-scope ; + +: introductions+ ( n -- ) introductions [ + ] change ; + +M: #introduce count-introductions* + out-d>> length introductions+ ; + +M: #branch count-introductions* + children>> + [ count-introductions ] map supremum + introductions+ ; + +M: #recursive count-introductions* + [ label>> ] [ child>> count-introductions ] bi + >>introductions + drop ; + +M: node count-introductions* drop ; diff --git a/basis/compiler/tree/normalization/normalization-tests.factor b/basis/compiler/tree/normalization/normalization-tests.factor index 1b4f728adc..c4a97fcc92 100644 --- a/basis/compiler/tree/normalization/normalization-tests.factor +++ b/basis/compiler/tree/normalization/normalization-tests.factor @@ -1,5 +1,8 @@ IN: compiler.tree.normalization.tests -USING: compiler.tree.builder compiler.tree.normalization +USING: compiler.tree.builder compiler.tree.recursive +compiler.tree.normalization +compiler.tree.normalization.introductions +compiler.tree.normalization.renaming compiler.tree compiler.tree.checker sequences accessors tools.test kernel math ; @@ -22,27 +25,30 @@ sequences accessors tools.test kernel math ; [ 0 2 ] [ [ foo ] build-tree [ recursive-inputs ] - [ normalize recursive-inputs ] bi + [ analyze-recursive normalize recursive-inputs ] bi ] unit-test -[ ] [ [ [ 1 ] [ 2 ] if + * ] build-tree normalize check-nodes ] unit-test +: test-normalization ( quot -- ) + build-tree analyze-recursive normalize check-nodes ; + +[ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test DEFER: bbb : aaa ( x -- ) dup [ dup >r bbb r> aaa ] [ drop ] if ; inline recursive : bbb ( x -- ) >r drop 0 r> aaa ; inline recursive -[ ] [ [ bbb ] build-tree normalize check-nodes ] unit-test +[ ] [ [ bbb ] test-normalization ] unit-test : ccc ( -- ) ccc drop 1 ; inline recursive -[ ] [ [ ccc ] build-tree normalize check-nodes ] unit-test +[ ] [ [ ccc ] test-normalization ] unit-test DEFER: eee : ddd ( -- ) eee ; inline recursive : eee ( -- ) swap ddd ; inline recursive -[ ] [ [ eee ] build-tree normalize check-nodes ] unit-test +[ ] [ [ eee ] test-normalization ] unit-test : call-recursive-5 ( -- ) call-recursive-5 ; inline recursive -[ ] [ [ call-recursive-5 swap ] build-tree normalize check-nodes ] unit-test +[ ] [ [ call-recursive-5 swap ] test-normalization ] unit-test diff --git a/basis/compiler/tree/normalization/normalization.factor b/basis/compiler/tree/normalization/normalization.factor index b826a1590b..bebe2e91b6 100644 --- a/basis/compiler/tree/normalization/normalization.factor +++ b/basis/compiler/tree/normalization/normalization.factor @@ -6,7 +6,9 @@ stack-checker.backend stack-checker.branches stack-checker.inlining compiler.tree -compiler.tree.combinators ; +compiler.tree.combinators +compiler.tree.normalization.introductions +compiler.tree.normalization.renaming ; IN: compiler.tree.normalization ! A transform pass done before optimization can begin to @@ -16,9 +18,6 @@ IN: compiler.tree.normalization ! replaced with a single one, at the beginning of a program. ! This simplifies subsequent analysis. ! -! - We collect #return-recursive and #call-recursive nodes and -! store them in the #recursive's label slot. -! ! - We normalize #call-recursive as follows. The stack checker ! says that the inputs of a #call-recursive are the entire stack ! at the time of the call. This is a conservative estimate; we @@ -28,93 +27,6 @@ IN: compiler.tree.normalization ! #call-recursive into a #copy of the unchanged values and a ! #call-recursive with trimmed inputs and outputs. -! Collect introductions -SYMBOL: introductions - -GENERIC: count-introductions* ( node -- ) - -: count-introductions ( nodes -- n ) - #! Note: we use each, not each-node, since the #branch - #! method recurses into children directly and we don't - #! recurse into #recursive at all. - [ - 0 introductions set - [ count-introductions* ] each - introductions get - ] with-scope ; - -: introductions+ ( n -- ) introductions [ + ] change ; - -M: #introduce count-introductions* - out-d>> length introductions+ ; - -M: #branch count-introductions* - children>> - [ count-introductions ] map supremum - introductions+ ; - -M: #recursive count-introductions* - [ label>> ] [ child>> count-introductions ] bi - >>introductions - drop ; - -M: node count-introductions* drop ; - -! Collect label info -GENERIC: collect-label-info ( node -- ) - -M: #return-recursive collect-label-info - dup label>> (>>return) ; - -M: #call-recursive collect-label-info - dup label>> calls>> push ; - -M: #recursive collect-label-info - label>> V{ } clone >>calls drop ; - -M: node collect-label-info drop ; - -! Rename -SYMBOL: rename-map - -: rename-value ( value -- value' ) - [ rename-map get at ] keep or ; - -: rename-values ( values -- values' ) - rename-map get '[ [ _ at ] keep or ] map ; - -GENERIC: rename-node-values* ( node -- node ) - -M: #introduce rename-node-values* ; - -M: #shuffle rename-node-values* - [ rename-values ] change-in-d - [ [ rename-value ] assoc-map ] change-mapping ; - -M: #push rename-node-values* ; - -M: #r> rename-node-values* - [ rename-values ] change-in-r ; - -M: #terminate rename-node-values* - [ rename-values ] change-in-d - [ rename-values ] change-in-r ; - -M: #phi rename-node-values* - [ [ rename-values ] map ] change-phi-in-d ; - -M: #declare rename-node-values* - [ [ [ rename-value ] dip ] assoc-map ] change-declaration ; - -M: #alien-callback rename-node-values* ; - -M: node rename-node-values* - [ rename-values ] change-in-d ; - -: rename-node-values ( nodes -- nodes' ) - dup [ rename-node-values* drop ] each-node ; - -! Normalize GENERIC: normalize* ( node -- node' ) SYMBOL: introduction-stack @@ -125,10 +37,6 @@ SYMBOL: introduction-stack : pop-introductions ( n -- values ) introduction-stack [ swap cut* swap ] change ; -: add-renamings ( old new -- ) - [ rename-values ] dip - rename-map get '[ _ set-at ] 2each ; - M: #introduce normalize* out-d>> [ length pop-introductions ] keep add-renamings f ; @@ -201,9 +109,8 @@ M: #call-recursive normalize* M: node normalize* ; : normalize ( nodes -- nodes' ) - H{ } clone rename-map set - dup [ collect-label-info ] each-node dup count-introductions make-values + H{ } clone rename-map set [ (normalize) ] [ nip ] 2bi [ #introduce prefix ] unless-empty rename-node-values ; diff --git a/basis/compiler/tree/normalization/renaming/renaming.factor b/basis/compiler/tree/normalization/renaming/renaming.factor new file mode 100644 index 0000000000..3050df2611 --- /dev/null +++ b/basis/compiler/tree/normalization/renaming/renaming.factor @@ -0,0 +1,48 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces assocs kernel accessors sequences fry +compiler.tree compiler.tree.combinators ; +IN: compiler.tree.normalization.renaming + +SYMBOL: rename-map + +: rename-value ( value -- value' ) + [ rename-map get at ] keep or ; + +: rename-values ( values -- values' ) + rename-map get '[ [ _ at ] keep or ] map ; + +: add-renamings ( old new -- ) + [ rename-values ] dip + rename-map get '[ _ set-at ] 2each ; + +GENERIC: rename-node-values* ( node -- node ) + +M: #introduce rename-node-values* ; + +M: #shuffle rename-node-values* + [ rename-values ] change-in-d + [ [ rename-value ] assoc-map ] change-mapping ; + +M: #push rename-node-values* ; + +M: #r> rename-node-values* + [ rename-values ] change-in-r ; + +M: #terminate rename-node-values* + [ rename-values ] change-in-d + [ rename-values ] change-in-r ; + +M: #phi rename-node-values* + [ [ rename-values ] map ] change-phi-in-d ; + +M: #declare rename-node-values* + [ [ [ rename-value ] dip ] assoc-map ] change-declaration ; + +M: #alien-callback rename-node-values* ; + +M: node rename-node-values* + [ rename-values ] change-in-d ; + +: rename-node-values ( nodes -- nodes' ) + dup [ rename-node-values* drop ] each-node ; diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor index aafc7f137b..3196253d45 100644 --- a/basis/compiler/tree/optimizer/optimizer.factor +++ b/basis/compiler/tree/optimizer/optimizer.factor @@ -1,15 +1,16 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces +compiler.tree.recursive compiler.tree.normalization compiler.tree.propagation compiler.tree.cleanup compiler.tree.escape-analysis compiler.tree.tuple-unboxing +compiler.tree.identities compiler.tree.def-use compiler.tree.dead-code compiler.tree.strength-reduction -compiler.tree.loop.detection compiler.tree.finalization compiler.tree.checker ; IN: compiler.tree.optimizer @@ -17,12 +18,13 @@ IN: compiler.tree.optimizer SYMBOL: check-optimizer? : optimize-tree ( nodes -- nodes' ) + analyze-recursive normalize propagate cleanup - detect-loops escape-analysis unbox-tuples + apply-identities compute-def-use remove-dead-code ! strength-reduce diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 4f93769b7f..48864d8782 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -6,11 +6,20 @@ classes.algebra classes.union sets quotations assocs combinators words namespaces compiler.tree compiler.tree.builder +compiler.tree.recursive +compiler.tree.combinators compiler.tree.normalization compiler.tree.propagation.info compiler.tree.propagation.nodes ; IN: compiler.tree.propagation.inlining +! We count nodes up-front; if there are relatively few nodes, +! we are more eager to inline +SYMBOL: node-count + +: count-nodes ( nodes -- ) + 0 swap [ drop 1+ ] each-node node-count set ; + ! Splicing nodes GENERIC: splicing-nodes ( #call word/quot/f -- nodes ) @@ -18,7 +27,7 @@ M: word splicing-nodes [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ; M: quotation splicing-nodes - build-sub-tree normalize ; + build-sub-tree analyze-recursive normalize ; : propagate-body ( #call -- ) body>> (propagate) ; @@ -113,12 +122,13 @@ DEFER: (flat-length) [ classes-known? 2 0 ? ] [ { + [ drop node-count get 45 swap [-] 8 /i ] [ flat-length 24 swap [-] 4 /i ] [ "default" word-prop -4 0 ? ] [ "specializer" word-prop 1 0 ? ] [ method-body? 1 0 ? ] } cleave - ] bi* + + + + ; + ] bi* + + + + + ; : should-inline? ( #call word -- ? ) inlining-rank 5 >= ; diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index f04460f32a..a115ee53c2 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -1,5 +1,5 @@ USING: kernel compiler.tree.builder compiler.tree -compiler.tree.propagation +compiler.tree.propagation compiler.tree.recursive compiler.tree.normalization tools.test math math.order accessors sequences arrays kernel.private vectors alien.accessors alien.c-types sequences.private @@ -14,6 +14,7 @@ IN: compiler.tree.propagation.tests : final-info ( quot -- seq ) build-tree + analyze-recursive normalize propagate compute-def-use diff --git a/basis/compiler/tree/propagation/propagation.factor b/basis/compiler/tree/propagation/propagation.factor index f184418d43..d82ebed433 100755 --- a/basis/compiler/tree/propagation/propagation.factor +++ b/basis/compiler/tree/propagation/propagation.factor @@ -6,6 +6,7 @@ compiler.tree.propagation.copy compiler.tree.propagation.info compiler.tree.propagation.nodes compiler.tree.propagation.simple +compiler.tree.propagation.inlining compiler.tree.propagation.branches compiler.tree.propagation.recursive compiler.tree.propagation.constraints @@ -18,4 +19,5 @@ IN: compiler.tree.propagation H{ } clone copies set H{ } clone constraints set H{ } clone value-infos set + dup count-nodes dup (propagate) ; diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor index 649eaa763e..53dce813a3 100644 --- a/basis/compiler/tree/propagation/recursive/recursive.factor +++ b/basis/compiler/tree/propagation/recursive/recursive.factor @@ -70,7 +70,8 @@ M: #recursive propagate-around ( #recursive -- ) [ generalize-return-interval ] map ; : return-infos ( node -- infos ) - label>> return>> node-input-infos generalize-return ; + label>> [ return>> node-input-infos ] [ loop?>> ] bi + [ generalize-return ] unless ; M: #call-recursive propagate-before ( #call-recursive -- ) [ ] [ return-infos ] [ node-output-infos ] tri diff --git a/basis/compiler/tree/loop/detection/detection-tests.factor b/basis/compiler/tree/recursive/recursive-tests.factor similarity index 75% rename from basis/compiler/tree/loop/detection/detection-tests.factor rename to basis/compiler/tree/recursive/recursive-tests.factor index 5864dc368f..c66c182869 100644 --- a/basis/compiler/tree/loop/detection/detection-tests.factor +++ b/basis/compiler/tree/recursive/recursive-tests.factor @@ -1,5 +1,5 @@ -IN: compiler.tree.loop.detection.tests -USING: compiler.tree.loop.detection tools.test +IN: compiler.tree.recursive.tests +USING: compiler.tree.recursive tools.test kernel combinators.short-circuit math sequences accessors compiler.tree compiler.tree.builder @@ -10,7 +10,7 @@ compiler.tree.combinators ; [ { f t t t } ] [ t { f f t t } (tail-calls) ] unit-test [ { f f f t } ] [ t { f f t f } (tail-calls) ] unit-test -\ detect-loops must-infer +\ analyze-recursive must-infer : label-is-loop? ( nodes word -- ? ) [ @@ -38,22 +38,22 @@ compiler.tree.combinators ; dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive [ t ] [ - [ loop-test-1 ] build-tree detect-loops + [ loop-test-1 ] build-tree analyze-recursive \ loop-test-1 label-is-loop? ] unit-test [ t ] [ - [ loop-test-1 1 2 3 ] build-tree detect-loops + [ loop-test-1 1 2 3 ] build-tree analyze-recursive \ loop-test-1 label-is-loop? ] unit-test [ t ] [ - [ [ loop-test-1 ] each ] build-tree detect-loops + [ [ loop-test-1 ] each ] build-tree analyze-recursive \ loop-test-1 label-is-loop? ] unit-test [ t ] [ - [ [ loop-test-1 ] each ] build-tree detect-loops + [ [ loop-test-1 ] each ] build-tree analyze-recursive \ (each-integer) label-is-loop? ] unit-test @@ -61,7 +61,7 @@ compiler.tree.combinators ; dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive [ t ] [ - [ loop-test-2 ] build-tree detect-loops + [ loop-test-2 ] build-tree analyze-recursive \ loop-test-2 label-is-not-loop? ] unit-test @@ -69,7 +69,7 @@ compiler.tree.combinators ; dup [ [ loop-test-3 ] each ] [ drop ] if ; inline recursive [ t ] [ - [ loop-test-3 ] build-tree detect-loops + [ loop-test-3 ] build-tree analyze-recursive \ loop-test-3 label-is-not-loop? ] unit-test @@ -81,7 +81,7 @@ compiler.tree.combinators ; ] if ; inline recursive [ f ] [ - [ [ [ ] map ] map ] build-tree detect-loops + [ [ [ ] map ] map ] build-tree analyze-recursive [ dup #recursive? [ label>> loop?>> not ] [ drop f ] if ] contains-node? @@ -98,22 +98,22 @@ DEFER: a blah [ b ] [ a ] if ; inline recursive [ t ] [ - [ a ] build-tree detect-loops + [ a ] build-tree analyze-recursive \ a label-is-loop? ] unit-test [ t ] [ - [ a ] build-tree detect-loops + [ a ] build-tree analyze-recursive \ b label-is-loop? ] unit-test [ t ] [ - [ b ] build-tree detect-loops + [ b ] build-tree analyze-recursive \ a label-is-loop? ] unit-test [ t ] [ - [ a ] build-tree detect-loops + [ a ] build-tree analyze-recursive \ b label-is-loop? ] unit-test @@ -126,12 +126,12 @@ DEFER: a' blah [ b' ] [ a' ] if ; inline recursive [ f ] [ - [ a' ] build-tree detect-loops + [ a' ] build-tree analyze-recursive \ a' label-is-loop? ] unit-test [ f ] [ - [ b' ] build-tree detect-loops + [ b' ] build-tree analyze-recursive \ b' label-is-loop? ] unit-test @@ -140,11 +140,11 @@ DEFER: a' ! sound. [ t ] [ - [ b' ] build-tree detect-loops + [ b' ] build-tree analyze-recursive \ a' label-is-loop? ] unit-test [ f ] [ - [ a' ] build-tree detect-loops + [ a' ] build-tree analyze-recursive \ b' label-is-loop? ] unit-test diff --git a/basis/compiler/tree/loop/detection/detection.factor b/basis/compiler/tree/recursive/recursive.factor similarity index 80% rename from basis/compiler/tree/loop/detection/detection.factor rename to basis/compiler/tree/recursive/recursive.factor index 1f9e42530a..d1e4c7c70e 100644 --- a/basis/compiler/tree/loop/detection/detection.factor +++ b/basis/compiler/tree/recursive/recursive.factor @@ -1,14 +1,27 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences namespaces assocs accessors fry -compiler.tree deques search-deques ; -IN: compiler.tree.loop.detection +USING: kernel assocs namespaces accessors sequences deques +search-deques compiler.tree compiler.tree.combinators ; +IN: compiler.tree.recursive + +! Collect label info +GENERIC: collect-label-info ( node -- ) + +M: #return-recursive collect-label-info + dup label>> (>>return) ; + +M: #call-recursive collect-label-info + dup label>> calls>> push ; + +M: #recursive collect-label-info + label>> V{ } clone >>calls drop ; + +M: node collect-label-info drop ; ! A loop is a #recursive which only tail calls itself, and those ! calls are nested inside other loops only. We optimistically ! assume all #recursive nodes are loops, disqualifying them as ! we see evidence to the contrary. - : (tail-calls) ( tail? seq -- seq' ) reverse [ swap [ and ] keep ] map nip reverse ; @@ -84,5 +97,6 @@ M: node collect-loop-info* 2drop ; ] [ drop ] if ] slurp-deque ; -: detect-loops ( nodes -- nodes ) +: analyze-recursive ( nodes -- nodes ) + dup [ collect-label-info ] each-node dup collect-loop-info disqualify-loops ; diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor index 858e40347f..81ba01f1e2 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor @@ -1,16 +1,18 @@ IN: compiler.tree.tuple-unboxing.tests USING: tools.test compiler.tree.tuple-unboxing compiler.tree -compiler.tree.builder compiler.tree.normalization -compiler.tree.propagation compiler.tree.cleanup -compiler.tree.escape-analysis compiler.tree.tuple-unboxing -compiler.tree.checker compiler.tree.def-use kernel accessors -sequences math math.private sorting math.order binary-search -sequences.private slots.private ; +compiler.tree.builder compiler.tree.recursive +compiler.tree.normalization compiler.tree.propagation +compiler.tree.cleanup compiler.tree.escape-analysis +compiler.tree.tuple-unboxing compiler.tree.checker +compiler.tree.def-use kernel accessors sequences math +math.private sorting math.order binary-search sequences.private +slots.private ; \ unbox-tuples must-infer : test-unboxing ( quot -- ) build-tree + analyze-recursive normalize propagate cleanup diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 6f255893db..67a8ec8a2c 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -173,6 +173,9 @@ M: x86.32 %box-long-long ( n func -- ) [ (%box-long-long) ] [ f %alien-invoke ] bi* ] with-aligned-stack ; +: struct-return@ ( size n -- n ) + [ stack-frame* cell + + ] [ \ stack-frame get swap - ] ?if ; + M: x86.32 %box-large-struct ( n size -- ) ! Compute destination address [ swap struct-return@ ] keep diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 1eb4a7896b..4770c09a83 100755 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -116,6 +116,9 @@ M: x86.64 %box-small-struct ( size -- ) RDX swap MOV "box_small_struct" f %alien-invoke ; +: struct-return@ ( size n -- n ) + [ ] [ \ stack-frame get swap - ] ?if ; + M: x86.64 %box-large-struct ( n size -- ) ! Struct size is parameter 2 RSI over MOV diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index 13524aecc4..171e67bcfb 100755 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -141,13 +141,6 @@ M: x86 small-enough? ( n -- ? ) : temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ; -: struct-return@ ( size n -- n ) - [ - stack-frame* cell + + - ] [ - \ stack-frame get swap - - ] ?if ; - HOOK: %unbox-struct-1 cpu ( -- ) HOOK: %unbox-struct-2 cpu ( -- ) diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index 499267de7c..1138ad872a 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -91,7 +91,7 @@ IN: hints \ >string { sbuf } "specializer" set-word-prop -\ >array { { string } { vector } } "specializer" set-word-prop +\ >array { { vector } } "specializer" set-word-prop \ >vector { { array } { vector } } "specializer" set-word-prop @@ -101,7 +101,7 @@ IN: hints \ memq? { array } "specializer" set-word-prop -\ member? { fixnum string } "specializer" set-word-prop +\ member? { array } "specializer" set-word-prop \ assoc-stack { vector } "specializer" set-word-prop diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor index 6def4966a2..b162406e5a 100644 --- a/basis/math/partial-dispatch/partial-dispatch.factor +++ b/basis/math/partial-dispatch/partial-dispatch.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel kernel.private math math.private words sequences parser namespaces make assocs quotations arrays locals -generic generic.math hashtables effects compiler.units ; +generic generic.math hashtables effects compiler.units +classes.algebra ; IN: math.partial-dispatch ! Partial dispatch. @@ -96,19 +97,28 @@ SYMBOL: fast-math-ops [ drop math-class-max swap specific-method >boolean ] if ; : (derived-ops) ( word assoc -- words ) - swap [ rot first eq? nip ] curry assoc-filter values ; + swap [ rot first eq? nip ] curry assoc-filter ; : derived-ops ( word -- words ) - [ 1array ] - [ math-ops get (derived-ops) ] - bi append ; + [ 1array ] [ math-ops get (derived-ops) values ] bi append ; : fast-derived-ops ( word -- words ) - fast-math-ops get (derived-ops) ; + fast-math-ops get (derived-ops) values ; : all-derived-ops ( word -- words ) [ derived-ops ] [ fast-derived-ops ] bi append ; +: integer-derived-ops ( word -- words ) + [ math-ops get (derived-ops) ] [ fast-math-ops get (derived-ops) ] bi + [ + [ + drop + [ second integer class<= ] + [ third integer class<= ] + bi and + ] assoc-filter values + ] bi@ append ; + : each-derived-op ( word quot -- ) >r derived-ops r> each ; inline diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index dbb24c3168..6f755e5cb5 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -236,6 +236,10 @@ INSTANCE: repetition immutable-sequence r swap - r> new-sequence dup 0 ] 3keep - -rot drop roll length ; inline + -rot drop roll length check-length ; inline : check-copy ( src n dst -- ) over 0 < [ bounds-error ] when @@ -273,7 +278,8 @@ PRIVATE> : but-last ( seq -- headseq ) 1 head* ; : copy ( src i dst -- ) - pick length >r 3dup check-copy spin 0 r> + #! The check-length call forces partial dispatch + pick length check-length >r 3dup check-copy spin 0 r> (copy) drop ; inline M: sequence clone-like diff --git a/extra/benchmark/nsieve-bytes/nsieve-bytes.factor b/extra/benchmark/nsieve-bytes/nsieve-bytes.factor new file mode 100644 index 0000000000..11745e4463 --- /dev/null +++ b/extra/benchmark/nsieve-bytes/nsieve-bytes.factor @@ -0,0 +1,35 @@ +IN: benchmark.nsieve-bytes +USING: math math.parser sequences sequences.private kernel +byte-arrays make io ; + +: clear-flags ( step i seq -- ) + 2dup length >= [ + 3drop + ] [ + 0 2over set-nth-unsafe >r over + r> clear-flags + ] if ; inline recursive + +: (nsieve) ( count i seq -- count ) + 2dup length < [ + 2dup nth-unsafe 0 > [ + over dup 2 * pick clear-flags + rot 1+ -rot ! increment count + ] when >r 1+ r> (nsieve) + ] [ + 2drop + ] if ; inline recursive + +: nsieve ( m -- count ) + 0 2 rot 1+ dup [ drop 1 ] change-each (nsieve) ; + +: nsieve. ( m -- ) + [ "Primes up to " % dup # " " % nsieve # ] "" make print ; + +: nsieve-main ( n -- ) + dup 2^ 10000 * nsieve. + dup 1 - 2^ 10000 * nsieve. + 2 - 2^ 10000 * nsieve. ; + +: nsieve-main* ( -- ) 9 nsieve-main ; + +MAIN: nsieve-main* diff --git a/unmaintained/space-invaders/resources/invaders.rom b/unmaintained/space-invaders/resources/invaders.rom deleted file mode 100644 index 606ec01945..0000000000 Binary files a/unmaintained/space-invaders/resources/invaders.rom and /dev/null differ diff --git a/work/README.txt b/work/README.txt new file mode 100644 index 0000000000..fd1af07408 --- /dev/null +++ b/work/README.txt @@ -0,0 +1 @@ +The 'work' directory is for your own personal vocabularies.