From 8e58f5e5aa974eda52e263b60d6e4304461b50d4 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 15 Jul 2009 22:39:23 -0500 Subject: [PATCH 01/12] in kazakhstan, they say that a world is like a context-world --- basis/ui/gadgets/worlds/worlds-docs.factor | 3 --- basis/ui/gadgets/worlds/worlds.factor | 6 ++---- 2 files changed, 2 insertions(+), 7 deletions(-) diff --git a/basis/ui/gadgets/worlds/worlds-docs.factor b/basis/ui/gadgets/worlds/worlds-docs.factor index ddaad93b1b..fe662b898c 100755 --- a/basis/ui/gadgets/worlds/worlds-docs.factor +++ b/basis/ui/gadgets/worlds/worlds-docs.factor @@ -29,9 +29,6 @@ HELP: set-title { $description "Sets the title bar of the native window containing the world." } { $notes "This word should not be called directly by user code. Instead, change the " { $snippet "title" } " slot model; see " { $link "models" } "." } ; -HELP: context-world -{ $var-description "Holds the " { $link world } " whose OpenGL context was most recently made active by " { $link set-gl-context } "." } ; - HELP: set-gl-context { $values { "world" world } } { $description "Selects an OpenGL context to be the implicit destination for subsequent GL rendering calls. This word is called automatically by the UI before drawing a " { $link world } "." } ; diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 0c59af95d6..91666c4e7a 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -78,13 +78,11 @@ TUPLE: world-attributes '[ f _ [ (>>status-owner) ] [ status>> set-model ] 2bi ] when ] [ 2drop ] if ; -SYMBOL: context-world - : window-resource ( resource -- resource ) - dup context-world get-global window-resources>> push ; + dup world get-global window-resources>> push ; : set-gl-context ( world -- ) - [ context-world set-global ] + [ world set-global ] [ handle>> select-gl-context ] bi ; : with-gl-context ( world quot -- ) From e90c947062fb0d91e07ce5fb7dd48fb99f43049a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 15 Jul 2009 22:44:03 -0500 Subject: [PATCH 02/12] gl-break word and interactive debugging aids --- basis/opengl/debug/authors.txt | 1 + basis/opengl/debug/debug-docs.factor | 36 ++++++++++++++++++++++++++++ basis/opengl/debug/debug.factor | 23 ++++++++++++++++++ basis/opengl/debug/summary.txt | 1 + 4 files changed, 61 insertions(+) create mode 100644 basis/opengl/debug/authors.txt create mode 100644 basis/opengl/debug/debug-docs.factor create mode 100644 basis/opengl/debug/debug.factor create mode 100644 basis/opengl/debug/summary.txt diff --git a/basis/opengl/debug/authors.txt b/basis/opengl/debug/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/basis/opengl/debug/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/basis/opengl/debug/debug-docs.factor b/basis/opengl/debug/debug-docs.factor new file mode 100644 index 0000000000..7cb8f9b246 --- /dev/null +++ b/basis/opengl/debug/debug-docs.factor @@ -0,0 +1,36 @@ +! (c)2009 Joe Groff bsd license +USING: help.markup help.syntax multiline tools.continuations ; +IN: opengl.debug + +HELP: G +{ $description "Makes the OpenGL context associated with " { $link G-world } " active for subsequent OpenGL calls. This is intended to be used from the listener, where interactively entered OpenGL calls can be directed to any window. Note that the Factor UI resets the OpenGL context every time a window is updated, so every code snippet entered in the listener must be prefixed with " { $snippet "G" } " in this use case." } +{ $examples { $code <" USING: opengl.debug ui ; + +[ drop t ] find-window G-world set +G 0.0 0.0 1.0 1.0 glClearColor +G GL_COLOR_BUFFER_BIT glClear +"> } } ; + +HELP: F +{ $description "Flushes the OpenGL context associated with " { $link G-world } ", thereby committing any outstanding drawing operations." } ; + +HELP: G-world +{ $var-description "The world whose OpenGL context is made active by " { $link G } "." } ; + +HELP: GB +{ $description "A shorthand for " { $link gl-break } "." } ; + +HELP: gl-break +{ $description "Suspends the current thread and activates the walker like " { $link break } ", but also preserves the current OpenGL context, saves it to " { $link G-world } " for interactive use through " { $link G } ", and restores the current context when the suspended thread is continued. The shorthand word " { $link POSTPONE: GB } " can also be used." } ; + +{ G F G-world POSTPONE: GB gl-break } related-words + +ARTICLE: "opengl.debug" "Interactive debugging of OpenGL applications" +"The " { $vocab-link "opengl.debug" } " vocabulary provides words to assist with interactive debugging of OpenGL applications in the Factor UI." +{ $subsection G-world } +{ $subsection G } +{ $subsection F } +{ $subsection GB } +{ $subsection gl-break } ; + +ABOUT: "opengl.debug" diff --git a/basis/opengl/debug/debug.factor b/basis/opengl/debug/debug.factor new file mode 100644 index 0000000000..7cbdf62346 --- /dev/null +++ b/basis/opengl/debug/debug.factor @@ -0,0 +1,23 @@ +! (c)2009 Joe Groff bsd license +USING: accessors kernel namespaces parser tools.continuations +ui.backend ui.gadgets.worlds words ; +IN: opengl.debug + +SYMBOL: G-world + +: G ( -- ) + G-world get set-gl-context ; + +: F ( -- ) + G-world get handle>> flush-gl-context ; + +: gl-break ( -- ) + world get dup G-world set-global + [ break ] dip + set-gl-context ; + +<< \ gl-break t "break?" set-word-prop >> + +SYNTAX: GB + \ gl-break parsed ; + diff --git a/basis/opengl/debug/summary.txt b/basis/opengl/debug/summary.txt new file mode 100644 index 0000000000..3a85f2f3c8 --- /dev/null +++ b/basis/opengl/debug/summary.txt @@ -0,0 +1 @@ +Helper words for breaking and interactively manipulating OpenGL applications From 9f926ab88cd2388d7e7a3b9c55bac9cd4e628a39 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 16 Jul 2009 02:17:58 -0500 Subject: [PATCH 03/12] compiler.cfg.block-joining: join basic blocks connected by a single edge to improve effectiveness of local optimizations --- .../cfg/block-joining/block-joining.factor | 44 +++++++++++++++++++ .../cfg/instructions/instructions.factor | 22 ++++++++++ basis/compiler/cfg/optimizer/optimizer.factor | 3 ++ basis/compiler/cfg/tco/tco.factor | 3 +- basis/compiler/utilities/utilities.factor | 4 +- 5 files changed, 73 insertions(+), 3 deletions(-) create mode 100644 basis/compiler/cfg/block-joining/block-joining.factor diff --git a/basis/compiler/cfg/block-joining/block-joining.factor b/basis/compiler/cfg/block-joining/block-joining.factor new file mode 100644 index 0000000000..39d9a64c41 --- /dev/null +++ b/basis/compiler/cfg/block-joining/block-joining.factor @@ -0,0 +1,44 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators.short-circuit kernel sequences math +compiler.utilities compiler.cfg compiler.cfg.instructions compiler.cfg.rpo +compiler.cfg.utilities ; +IN: compiler.cfg.block-joining + +! Joining blocks that are not calls and are connected by a single CFG edge. +! Predecessors must be recomputed after this. Also this pass does not +! update ##phi nodes and should therefore only run before stack analysis. + +: kill-vreg-block? ( bb -- ? ) + instructions>> { + [ length 2 >= ] + [ penultimate kill-vreg-insn? ] + } 1&& ; + +: predecessor ( bb -- pred ) + predecessors>> first ; inline + +: join-block? ( bb -- ? ) + { + [ kill-vreg-block? not ] + [ predecessors>> length 1 = ] + [ predecessor kill-vreg-block? not ] + [ predecessor successors>> length 1 = ] + [ [ predecessor ] keep back-edge? not ] + } 1&& ; + +: join-instructions ( bb pred -- ) + [ instructions>> ] bi@ dup pop* push-all ; + +: update-successors ( bb pred -- ) + [ successors>> ] dip (>>successors) ; + +: join-block ( bb pred -- ) + [ join-instructions ] [ update-successors ] 2bi ; + +: join-blocks ( cfg -- cfg' ) + dup post-order [ + dup join-block? + [ dup predecessor join-block ] [ drop ] if + ] each + cfg-changed ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 910cb1992b..2f2668df8b 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -223,3 +223,25 @@ INSN: _reload dst class n ; INSN: _copy dst src class ; INSN: _spill-counts counts ; +! Instructions that poison the stack state +UNION: poison-insn + ##jump + ##return + ##callback-return + ##fixnum-mul-tail + ##fixnum-add-tail + ##fixnum-sub-tail ; + +! Instructions that kill all live vregs +UNION: kill-vreg-insn + poison-insn + ##stack-frame + ##call + ##prologue + ##epilogue + ##fixnum-mul + ##fixnum-add + ##fixnum-sub + ##alien-invoke + ##alien-indirect + ##alien-callback ; diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index e16fb734e1..1af0fcbc53 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -6,6 +6,7 @@ compiler.cfg.predecessors compiler.cfg.useless-conditionals compiler.cfg.stack-analysis compiler.cfg.branch-splitting +compiler.cfg.block-joining compiler.cfg.alias-analysis compiler.cfg.value-numbering compiler.cfg.dce @@ -31,6 +32,8 @@ SYMBOL: check-optimizer? delete-useless-conditionals compute-predecessors split-branches + join-blocks + compute-predecessors stack-analysis compute-liveness alias-analysis diff --git a/basis/compiler/cfg/tco/tco.factor b/basis/compiler/cfg/tco/tco.factor index 5fa2e1b042..8be9c15b04 100644 --- a/basis/compiler/cfg/tco/tco.factor +++ b/basis/compiler/cfg/tco/tco.factor @@ -2,6 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators.short-circuit kernel math namespaces sequences fry combinators +compiler.utilities compiler.cfg compiler.cfg.rpo compiler.cfg.hats @@ -19,8 +20,6 @@ IN: compiler.cfg.tco [ second ##return? ] } 1&& ; -: penultimate ( seq -- elt ) [ length 2 - ] keep nth ; - : tail-call? ( bb -- ? ) { [ instructions>> { [ length 2 >= ] [ last ##branch? ] } 1&& ] diff --git a/basis/compiler/utilities/utilities.factor b/basis/compiler/utilities/utilities.factor index ac276b6e41..c21be39adb 100644 --- a/basis/compiler/utilities/utilities.factor +++ b/basis/compiler/utilities/utilities.factor @@ -27,4 +27,6 @@ SYMBOL: yield-hook yield-hook [ [ ] ] initialize : alist-max ( alist -- pair ) - [ ] [ [ [ second ] bi@ > ] most ] map-reduce ; \ No newline at end of file + [ ] [ [ [ second ] bi@ > ] most ] map-reduce ; + +: penultimate ( seq -- elt ) [ length 2 - ] keep nth ; From 884e41dd9c0d18c794a3e61a2a4da36ca59a734e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 16 Jul 2009 02:42:01 -0500 Subject: [PATCH 04/12] compiler.cfg.linear-scan.live-intervals: remove bogus assertion --- .../linear-scan/live-intervals/live-intervals.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index bf7e8bc042..d2fa661136 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -122,10 +122,10 @@ M: ##copy-float compute-live-intervals* dup ranges>> [ first from>> ] [ last to>> ] bi [ >>start ] [ >>end ] bi* drop ; -: check-start/end ( live-interval -- ) - [ [ start>> ] [ uses>> first ] bi assert= ] - [ [ end>> ] [ uses>> last ] bi assert= ] - bi ; +ERROR: bad-live-interval live-interval ; + +: check-start ( live-interval -- ) + dup start>> -1 = [ bad-live-interval ] [ drop ] if ; : finish-live-intervals ( live-intervals -- ) ! Since live intervals are computed in a backward order, we have @@ -135,7 +135,7 @@ M: ##copy-float compute-live-intervals* [ ranges>> reverse-here ] [ uses>> reverse-here ] [ compute-start/end ] - [ check-start/end ] + [ check-start ] } cleave ] each ; From 7596b3288c82e99fcc485664843abd327d8382c7 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Thu, 16 Jul 2009 19:55:08 +1200 Subject: [PATCH 05/12] alien.marshall.syntax-tests: use alien.inline.syntax vocab --- extra/alien/marshall/syntax/syntax-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/alien/marshall/syntax/syntax-tests.factor b/extra/alien/marshall/syntax/syntax-tests.factor index 6ea6488167..3945924a57 100644 --- a/extra/alien/marshall/syntax/syntax-tests.factor +++ b/extra/alien/marshall/syntax/syntax-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Jeremy Hughes. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.inline alien.marshall.syntax destructors +USING: alien.inline.syntax alien.marshall.syntax destructors tools.test accessors kernel ; IN: alien.marshall.syntax.tests From 5ae07b3168fa4f010a14dd15d800bed5501c59fb Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Thu, 16 Jul 2009 19:57:47 +1200 Subject: [PATCH 06/12] help lint fixes --- extra/alien/inline/syntax/syntax-docs.factor | 4 ++-- extra/alien/marshall/syntax/syntax-docs.factor | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/alien/inline/syntax/syntax-docs.factor b/extra/alien/inline/syntax/syntax-docs.factor index 2453d98cf6..0fc5a5140b 100644 --- a/extra/alien/inline/syntax/syntax-docs.factor +++ b/extra/alien/inline/syntax/syntax-docs.factor @@ -18,7 +18,7 @@ HELP: C-FUNCTION: { $description "Appends a function to the C library in scope and defines an FFI word that calls it." } { $examples { $example - "USING: alien.inline prettyprint ;" + "USING: alien.inline.syntax prettyprint ;" "IN: cmath.ffi" "" "C-LIBRARY: cmathlib" @@ -44,7 +44,7 @@ HELP: C-LIBRARY: { $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " syntax can be used after this word." } { $examples { $example - "USING: alien.inline ;" + "USING: alien.inline.syntax ;" "IN: rectangle.ffi" "" "C-LIBRARY: rectlib" diff --git a/extra/alien/marshall/syntax/syntax-docs.factor b/extra/alien/marshall/syntax/syntax-docs.factor index c432ec2ad5..864ae92c29 100644 --- a/extra/alien/marshall/syntax/syntax-docs.factor +++ b/extra/alien/marshall/syntax/syntax-docs.factor @@ -12,7 +12,7 @@ HELP: CM-FUNCTION: } { $examples { $example - "USING: alien.inline alien.marshall.syntax prettyprint ;" + "USING: alien.inline.syntax alien.marshall.syntax prettyprint ;" "IN: example" "" "C-LIBRARY: exlib" From 8c892380fe658a24524f4ec8fb7e9372c37eebcd Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Thu, 16 Jul 2009 20:22:41 +1200 Subject: [PATCH 07/12] alien.marshall.syntax: fixed CM-FUNCTION: example --- extra/alien/marshall/syntax/syntax-docs.factor | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/extra/alien/marshall/syntax/syntax-docs.factor b/extra/alien/marshall/syntax/syntax-docs.factor index 864ae92c29..401934e736 100644 --- a/extra/alien/marshall/syntax/syntax-docs.factor +++ b/extra/alien/marshall/syntax/syntax-docs.factor @@ -28,10 +28,8 @@ HELP: CM-FUNCTION: "" ";C-LIBRARY" "" - "8 5 0 0 sum_diff .s" - "\"sum 13, diff 3\"" - "13" - "3" + "8 5 0 0 sum_diff . . ." + "3\n13\n\"sum 13, diff 3\"" } } { $see-also define-c-marshalled POSTPONE: C-FUNCTION: POSTPONE: M-FUNCTION: } ; From 4931ab0d5fa05c0a35f5be016d73a6d93c0f5683 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 16 Jul 2009 03:30:11 -0500 Subject: [PATCH 08/12] benchmark: run each benchmark 5 times and take the best time --- extra/benchmark/benchmark.factor | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index ca71e22e9f..23809f2744 100755 --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel vocabs vocabs.loader tools.time vocabs.hierarchy arrays assocs io.styles io help.markup prettyprint sequences -continuations debugger math namespaces memory ; +continuations debugger math namespaces memory fry ; IN: benchmark +: (run-benchmark) ( vocab -- time ) + [ 5 ] dip '[ gc [ _ run ] benchmark ] replicate infimum ; + : run-benchmark ( vocab -- ) [ "=== " write print flush ] [ - [ [ require ] [ gc [ run ] benchmark ] [ ] tri timings ] + [ [ require ] [ (run-benchmark) ] [ ] tri timings ] [ swap errors ] recover get set-at ] bi ; @@ -24,6 +27,7 @@ PRIVATE> V{ } clone timings set V{ } clone errors set "benchmark" child-vocab-names + [ find-vocab-root ] filter [ run-benchmark ] each timings get errors get From fc0e0f19245f522e7064dcf7e12bc0540bb97432 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 16 Jul 2009 05:50:44 -0500 Subject: [PATCH 09/12] compiler.cfg.block-joining: relax join heuristic --- basis/compiler/cfg/block-joining/block-joining.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/basis/compiler/cfg/block-joining/block-joining.factor b/basis/compiler/cfg/block-joining/block-joining.factor index 39d9a64c41..982f0866e6 100644 --- a/basis/compiler/cfg/block-joining/block-joining.factor +++ b/basis/compiler/cfg/block-joining/block-joining.factor @@ -20,7 +20,6 @@ IN: compiler.cfg.block-joining : join-block? ( bb -- ? ) { - [ kill-vreg-block? not ] [ predecessors>> length 1 = ] [ predecessor kill-vreg-block? not ] [ predecessor successors>> length 1 = ] From 685e32b091f754ac53fcaac0c5f6800a34f33e81 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 16 Jul 2009 16:43:14 -0500 Subject: [PATCH 10/12] compiler.cfg.stack-analysis: global optimization work in progress --- .../cfg/stack-analysis/merge/merge.factor | 1 + .../cfg/stack-analysis/stack-analysis.factor | 42 +++---------------- .../cfg/stack-analysis/state/state.factor | 6 ++- 3 files changed, 11 insertions(+), 38 deletions(-) diff --git a/basis/compiler/cfg/stack-analysis/merge/merge.factor b/basis/compiler/cfg/stack-analysis/merge/merge.factor index cb0ad7d615..a53fd7494e 100644 --- a/basis/compiler/cfg/stack-analysis/merge/merge.factor +++ b/basis/compiler/cfg/stack-analysis/merge/merge.factor @@ -92,6 +92,7 @@ SYMBOL: added-phis :: multiple-predecessors ( bb states -- state ) states [ not ] any? [ + bb add-to-work-list ] [ [ H{ } clone added-instructions set diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor index 48a4b79783..51baea71a9 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor @@ -14,9 +14,7 @@ compiler.cfg.stack-analysis.merge compiler.cfg.utilities ; IN: compiler.cfg.stack-analysis -SYMBOL: work-list - -: add-to-work-list ( bb -- ) work-list get push-front ; +SYMBOL: global-optimization? : redundant-replace? ( vreg loc -- ? ) dup state get untranslate-loc n>> 0 < @@ -70,7 +68,8 @@ UNION: sync-if-back-edge [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any? ; M: sync-if-back-edge visit - sync-state? [ sync-state ] when , ; + global-optimization? get [ sync-state? [ sync-state ] when ] unless + , ; : eliminate-peek ( dst src -- ) ! the requested stack location is already in 'src' @@ -87,31 +86,8 @@ M: ##replace visit M: ##copy visit [ call-next-method ] [ record-copy ] bi ; -! Instructions that poison the stack state -UNION: poison-insn - ##jump - ##return - ##callback-return - ##fixnum-mul-tail - ##fixnum-add-tail - ##fixnum-sub-tail ; - M: poison-insn visit call-next-method poison-state ; -! Instructions that kill all live vregs -UNION: kill-vreg-insn - poison-insn - ##stack-frame - ##call - ##prologue - ##epilogue - ##fixnum-mul - ##fixnum-add - ##fixnum-sub - ##alien-invoke - ##alien-indirect - ##alien-callback ; - M: kill-vreg-insn visit sync-state , ; ! Maps basic-blocks to states @@ -142,21 +118,13 @@ SYMBOLS: state-in state-out ; ] 2bi ] V{ } make >>instructions drop ; -: visit-successors ( bb -- ) - dup successors>> [ - 2dup back-edge? [ 2drop ] [ nip add-to-work-list ] if - ] with each ; - -: process-work-list ( -- ) - work-list get [ visit-block ] slurp-deque ; - : stack-analysis ( cfg -- cfg' ) [ work-list set H{ } clone copies set H{ } clone state-in set H{ } clone state-out set - dup [ add-to-work-list ] each-basic-block - process-work-list + dup [ visit-block ] each-basic-block + global-optimization? get [ work-list get [ visit-block ] slurp-deque ] when cfg-changed ] with-scope ; diff --git a/basis/compiler/cfg/stack-analysis/state/state.factor b/basis/compiler/cfg/stack-analysis/state/state.factor index f701b84763..25fa249853 100644 --- a/basis/compiler/cfg/stack-analysis/state/state.factor +++ b/basis/compiler/cfg/stack-analysis/state/state.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors namespaces assocs sets math +USING: kernel accessors namespaces assocs sets math deques compiler.cfg.registers ; IN: compiler.cfg.stack-analysis.state @@ -47,3 +47,7 @@ M: rs-loc translate-loc [ n>> ] [ rs-height>> ] bi* - ; GENERIC# untranslate-loc 1 ( loc state -- loc' ) M: ds-loc untranslate-loc [ n>> ] [ ds-height>> ] bi* + ; M: rs-loc untranslate-loc [ n>> ] [ rs-height>> ] bi* + ; + +SYMBOL: work-list + +: add-to-work-list ( bb -- ) work-list get push-front ; From e76dce8aff2a2b4950343f58a3fc22b26410a7a9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 16 Jul 2009 18:29:40 -0500 Subject: [PATCH 11/12] Overflowing fixnum intrinsics now expand into several CFG nodes. This speeds up the common case since only the uncommon case is now a stack syncpoint --- .../branch-splitting-tests.factor | 40 ++-- .../branch-splitting/branch-splitting.factor | 4 +- .../build-stack-frame.factor | 8 +- basis/compiler/cfg/builder/builder.factor | 11 +- basis/compiler/cfg/checker/checker.factor | 6 +- basis/compiler/cfg/def-use/def-use.factor | 3 +- basis/compiler/cfg/hats/hats.factor | 4 +- .../cfg/instructions/instructions.factor | 30 ++- .../cfg/intrinsics/fixnum/fixnum.factor | 30 ++- .../compiler/cfg/intrinsics/intrinsics.factor | 6 +- .../cfg/linear-scan/linear-scan-tests.factor | 207 +----------------- .../cfg/linearization/linearization.factor | 17 +- basis/compiler/cfg/renaming/renaming.factor | 10 - .../cfg/stack-analysis/stack-analysis.factor | 3 +- basis/compiler/cfg/tco/tco.factor | 17 -- .../cfg/two-operand/two-operand.factor | 2 + basis/compiler/cfg/utilities/utilities.factor | 12 + basis/compiler/codegen/codegen.factor | 16 +- basis/compiler/tree/debugger/debugger.factor | 17 +- .../tree/finalization/finalization.factor | 3 + .../modular-arithmetic-tests.factor | 4 +- basis/cpu/architecture/architecture.factor | 9 +- basis/cpu/x86/32/32.factor | 2 - basis/cpu/x86/64/64.factor | 5 - basis/cpu/x86/x86.factor | 81 +------ 25 files changed, 143 insertions(+), 404 deletions(-) diff --git a/basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor b/basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor index fbaaf92203..89f26f7928 100644 --- a/basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor +++ b/basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor @@ -1,6 +1,6 @@ USING: accessors assocs compiler.cfg compiler.cfg.branch-splitting compiler.cfg.debugger -compiler.cfg.predecessors compiler.cfg.rpo fry kernel +compiler.cfg.predecessors compiler.cfg.rpo compiler.cfg.instructions fry kernel tools.test namespaces sequences vectors ; IN: compiler.cfg.branch-splitting.tests @@ -20,31 +20,31 @@ IN: compiler.cfg.branch-splitting.tests : test-branch-splitting ( -- ) cfg new 0 get >>entry check-branch-splitting ; -V{ } 0 test-bb +V{ T{ ##branch } } 0 test-bb -V{ } 1 test-bb +V{ T{ ##branch } } 1 test-bb -V{ } 2 test-bb +V{ T{ ##branch } } 2 test-bb -V{ } 3 test-bb +V{ T{ ##branch } } 3 test-bb -V{ } 4 test-bb +V{ T{ ##branch } } 4 test-bb test-diamond [ ] [ test-branch-splitting ] unit-test -V{ } 0 test-bb +V{ T{ ##branch } } 0 test-bb -V{ } 1 test-bb +V{ T{ ##branch } } 1 test-bb -V{ } 2 test-bb +V{ T{ ##branch } } 2 test-bb -V{ } 3 test-bb +V{ T{ ##branch } } 3 test-bb -V{ } 4 test-bb +V{ T{ ##branch } } 4 test-bb -V{ } 5 test-bb +V{ T{ ##branch } } 5 test-bb 0 get 1 get 2 get V{ } 2sequence >>successors drop @@ -54,15 +54,15 @@ V{ } 5 test-bb [ ] [ test-branch-splitting ] unit-test -V{ } 0 test-bb +V{ T{ ##branch } } 0 test-bb -V{ } 1 test-bb +V{ T{ ##branch } } 1 test-bb -V{ } 2 test-bb +V{ T{ ##branch } } 2 test-bb -V{ } 3 test-bb +V{ T{ ##branch } } 3 test-bb -V{ } 4 test-bb +V{ T{ ##branch } } 4 test-bb 0 get 1 get 2 get V{ } 2sequence >>successors drop @@ -72,11 +72,11 @@ V{ } 4 test-bb [ ] [ test-branch-splitting ] unit-test -V{ } 0 test-bb +V{ T{ ##branch } } 0 test-bb -V{ } 1 test-bb +V{ T{ ##branch } } 1 test-bb -V{ } 2 test-bb +V{ T{ ##branch } } 2 test-bb 0 get 1 get 2 get V{ } 2sequence >>successors drop diff --git a/basis/compiler/cfg/branch-splitting/branch-splitting.factor b/basis/compiler/cfg/branch-splitting/branch-splitting.factor index 9d6e59e4da..2ab476e20c 100644 --- a/basis/compiler/cfg/branch-splitting/branch-splitting.factor +++ b/basis/compiler/cfg/branch-splitting/branch-splitting.factor @@ -63,7 +63,9 @@ IN: compiler.cfg.branch-splitting UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ; : split-instructions? ( insns -- ? ) - [ irrelevant? not ] count 5 <= ; + [ [ irrelevant? not ] count 5 <= ] + [ last ##fixnum-overflow? not ] + bi and ; : split-branch? ( bb -- ? ) { diff --git a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor index e5be2d9eb9..71798da6fc 100644 --- a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor +++ b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces accessors math.order assocs kernel sequences combinators make classes words cpu.architecture @@ -36,12 +36,6 @@ M: insn compute-stack-frame* ] when ; \ _spill t frame-required? set-word-prop -\ ##fixnum-add t frame-required? set-word-prop -\ ##fixnum-sub t frame-required? set-word-prop -\ ##fixnum-mul t frame-required? set-word-prop -\ ##fixnum-add-tail f frame-required? set-word-prop -\ ##fixnum-sub-tail f frame-required? set-word-prop -\ ##fixnum-mul-tail f frame-required? set-word-prop : compute-stack-frame ( insns -- ) frame-required? off diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 991fd2e20d..c866835ac5 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -98,17 +98,10 @@ M: #recursive emit-node ! #if : emit-branch ( obj -- final-bb ) - [ - begin-basic-block - emit-nodes - basic-block get dup [ ##branch ] when - ] with-scope ; + [ emit-nodes ] with-branch ; : emit-if ( node -- ) - children>> [ emit-branch ] map - end-basic-block - begin-basic-block - basic-block get '[ [ _ swap successors>> push ] when* ] each ; + children>> [ emit-branch ] map emit-conditional ; : ##branch-t ( vreg -- ) \ f tag-number cc/= ##compare-imm-branch ; diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index e7d9dbdd9c..49ea775600 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -16,9 +16,9 @@ ERROR: last-insn-not-a-jump insn ; [ ##return? ] [ ##callback-return? ] [ ##jump? ] - [ ##fixnum-add-tail? ] - [ ##fixnum-sub-tail? ] - [ ##fixnum-mul-tail? ] + [ ##fixnum-add? ] + [ ##fixnum-sub? ] + [ ##fixnum-mul? ] [ ##no-tco? ] } 1|| [ drop ] [ last-insn-not-a-jump ] if ; diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index 43ea89f284..c8a9d1861b 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -8,6 +8,7 @@ GENERIC: temp-vregs ( insn -- seq ) GENERIC: uses-vregs ( insn -- seq ) M: ##flushable defs-vregs dst>> 1array ; +M: ##fixnum-overflow defs-vregs dst>> 1array ; M: insn defs-vregs drop f ; M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ; @@ -21,8 +22,6 @@ M: ##set-string-nth-fast temp-vregs temp>> 1array ; M: ##compare temp-vregs temp>> 1array ; M: ##compare-imm temp-vregs temp>> 1array ; M: ##compare-float temp-vregs temp>> 1array ; -M: ##fixnum-mul temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ; -M: ##fixnum-mul-tail temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ; M: ##gc temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ; M: _dispatch temp-vregs temp>> 1array ; M: insn temp-vregs drop f ; diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index b61f091fad..986438d055 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -73,5 +73,7 @@ IN: compiler.cfg.hats : ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline : ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline : ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline - +: ^^fixnum-add ( src1 src2 -- dst ) ^^i2 ##fixnum-add ; inline +: ^^fixnum-sub ( src1 src2 -- dst ) ^^i2 ##fixnum-sub ; inline +: ^^fixnum-mul ( src1 src2 -- dst ) ^^i2 ##fixnum-mul ; inline : ^^phi ( inputs -- dst ) ^^i1 ##phi ; inline \ No newline at end of file diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 2f2668df8b..8d4b0f40ad 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -92,15 +92,6 @@ INSN: ##sar-imm < ##binary-imm ; INSN: ##not < ##unary ; INSN: ##log2 < ##unary ; -! Overflowing arithmetic -TUPLE: ##fixnum-overflow < insn src1 src2 ; -INSN: ##fixnum-add < ##fixnum-overflow ; -INSN: ##fixnum-add-tail < ##fixnum-overflow ; -INSN: ##fixnum-sub < ##fixnum-overflow ; -INSN: ##fixnum-sub-tail < ##fixnum-overflow ; -INSN: ##fixnum-mul < ##fixnum-overflow temp1 temp2 ; -INSN: ##fixnum-mul-tail < ##fixnum-overflow temp1 temp2 ; - : ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline : ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline @@ -181,6 +172,7 @@ INSN: ##loop-entry ; INSN: ##phi < ##pure inputs ; +! Conditionals TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ; INSN: ##compare-branch < ##conditional-branch ; @@ -192,6 +184,12 @@ INSN: ##compare-imm < ##binary-imm cc temp ; INSN: ##compare-float-branch < ##conditional-branch ; INSN: ##compare-float < ##binary cc temp ; +! Overflowing arithmetic +TUPLE: ##fixnum-overflow < insn { dst vreg } { src1 vreg } { src2 vreg } ; +INSN: ##fixnum-add < ##fixnum-overflow ; +INSN: ##fixnum-sub < ##fixnum-overflow ; +INSN: ##fixnum-mul < ##fixnum-overflow ; + INSN: ##gc { temp1 vreg } { temp2 vreg } live-values ; ! Instructions used by machine IR only. @@ -212,6 +210,12 @@ INSN: _compare-imm-branch label { src1 vreg } { src2 integer } cc ; INSN: _compare-float-branch < _conditional-branch ; +! Overflowing arithmetic +TUPLE: _fixnum-overflow < insn label { dst vreg } { src1 vreg } { src2 vreg } ; +INSN: _fixnum-add < _fixnum-overflow ; +INSN: _fixnum-sub < _fixnum-overflow ; +INSN: _fixnum-mul < _fixnum-overflow ; + TUPLE: spill-slot n ; C: spill-slot INSN: _gc { temp1 vreg } { temp2 vreg } gc-roots gc-root-count gc-root-size ; @@ -227,10 +231,7 @@ INSN: _spill-counts counts ; UNION: poison-insn ##jump ##return - ##callback-return - ##fixnum-mul-tail - ##fixnum-add-tail - ##fixnum-sub-tail ; + ##callback-return ; ! Instructions that kill all live vregs UNION: kill-vreg-insn @@ -239,9 +240,6 @@ UNION: kill-vreg-insn ##call ##prologue ##epilogue - ##fixnum-mul - ##fixnum-add - ##fixnum-sub ##alien-invoke ##alien-indirect ##alien-callback ; diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index 2a82139e13..57eb7fb63c 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: sequences accessors layouts kernel math namespaces -combinators fry +combinators fry arrays compiler.tree.propagation.info compiler.cfg.hats compiler.cfg.stacks @@ -54,6 +54,28 @@ IN: compiler.cfg.intrinsics.fixnum : emit-fixnum>bignum ( -- ) ds-pop ^^untag-fixnum ^^integer>bignum ds-push ; -: emit-fixnum-overflow-op ( quot -- next ) - [ 2inputs 1 ##inc-d ] dip call ##branch - begin-basic-block ; inline +: emit-no-overflow-case ( dst -- final-bb ) + [ -2 ##inc-d ds-push ] with-branch ; + +: emit-overflow-case ( word -- final-bb ) + [ ##call ] with-branch ; + +: emit-fixnum-overflow-op ( quot word -- ) + [ [ D 1 ^^peek D 0 ^^peek ] dip call ] dip + [ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array + emit-conditional ; inline + +: fixnum+overflow ( x y -- z ) [ >bignum ] bi@ + ; + +: fixnum-overflow ( x y -- z ) [ >bignum ] bi@ - ; + +: fixnum*overflow ( x y -- z ) [ >bignum ] bi@ * ; + +: emit-fixnum+ ( -- ) + [ ^^fixnum-add ] \ fixnum+overflow emit-fixnum-overflow-op ; + +: emit-fixnum- ( -- ) + [ ^^fixnum-sub ] \ fixnum-overflow emit-fixnum-overflow-op ; + +: emit-fixnum* ( -- ) + [ ^^untag-fixnum ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ; \ No newline at end of file diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index ed94ec36d9..e4a7b8972a 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -100,9 +100,9 @@ IN: compiler.cfg.intrinsics { \ kernel.private:tag [ drop emit-tag ] } { \ kernel.private:getenv [ emit-getenv ] } { \ math.private:both-fixnums? [ drop emit-both-fixnums? ] } - { \ math.private:fixnum+ [ drop [ ##fixnum-add ] emit-fixnum-overflow-op ] } - { \ math.private:fixnum- [ drop [ ##fixnum-sub ] emit-fixnum-overflow-op ] } - { \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] emit-fixnum-overflow-op ] } + { \ math.private:fixnum+ [ drop emit-fixnum+ ] } + { \ math.private:fixnum- [ drop emit-fixnum- ] } + { \ math.private:fixnum* [ drop emit-fixnum* ] } { \ math.private:fixnum+fast [ drop [ ^^add ] emit-fixnum-op ] } { \ math.private:fixnum-fast [ drop [ ^^sub ] emit-fixnum-op ] } { \ math.private:fixnum-bitand [ drop [ ^^and ] emit-fixnum-op ] } diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index fd95a3e09c..63da100b02 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -2159,12 +2159,7 @@ V{ T{ ##replace { src V int-regs 85 } { loc D 1 } } T{ ##replace { src V int-regs 89 } { loc D 4 } } T{ ##replace { src V int-regs 96 } { loc R 0 } } - T{ ##fixnum-mul - { src1 V int-regs 128 } - { src2 V int-regs 129 } - { temp1 V int-regs 132 } - { temp2 V int-regs 133 } - } + T{ ##replace { src V int-regs 129 } { loc R 0 } } T{ ##branch } } 2 test-bb @@ -2255,206 +2250,6 @@ V{ [ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test -! Another push-all reduction to demonstrate numbering anamoly -V{ T{ ##prologue } T{ ##branch } } -0 test-bb - -V{ - T{ ##peek { dst V int-regs 1 } { loc D 0 } } - T{ ##slot-imm - { dst V int-regs 5 } - { obj V int-regs 1 } - { slot 3 } - { tag 7 } - } - T{ ##peek { dst V int-regs 7 } { loc D 1 } } - T{ ##slot-imm - { dst V int-regs 12 } - { obj V int-regs 7 } - { slot 1 } - { tag 6 } - } - T{ ##add - { dst V int-regs 25 } - { src1 V int-regs 5 } - { src2 V int-regs 12 } - } - T{ ##compare-branch - { src1 V int-regs 25 } - { src2 V int-regs 5 } - { cc cc> } - } -} -1 test-bb - -V{ - T{ ##slot-imm - { dst V int-regs 41 } - { obj V int-regs 1 } - { slot 2 } - { tag 7 } - } - T{ ##slot-imm - { dst V int-regs 44 } - { obj V int-regs 41 } - { slot 1 } - { tag 6 } - } - T{ ##compare-branch - { src1 V int-regs 25 } - { src2 V int-regs 44 } - { cc cc> } - } -} -2 test-bb - -V{ - T{ ##add-imm - { dst V int-regs 54 } - { src1 V int-regs 25 } - { src2 8 } - } - T{ ##load-immediate { dst V int-regs 55 } { val 24 } } - T{ ##inc-d { n 4 } } - T{ ##inc-r { n 1 } } - T{ ##replace { src V int-regs 25 } { loc D 2 } } - T{ ##replace { src V int-regs 1 } { loc D 3 } } - T{ ##replace { src V int-regs 5 } { loc D 4 } } - T{ ##replace { src V int-regs 1 } { loc D 1 } } - T{ ##replace { src V int-regs 54 } { loc D 0 } } - T{ ##replace { src V int-regs 12 } { loc R 0 } } - T{ ##fixnum-mul - { src1 V int-regs 54 } - { src2 V int-regs 55 } - { temp1 V int-regs 58 } - { temp2 V int-regs 59 } - } - T{ ##branch } -} -3 test-bb - -V{ - T{ ##peek { dst V int-regs 60 } { loc D 1 } } - T{ ##slot-imm - { dst V int-regs 66 } - { obj V int-regs 60 } - { slot 2 } - { tag 7 } - } - T{ ##inc-d { n 1 } } - T{ ##inc-r { n 1 } } - T{ ##replace { src V int-regs 66 } { loc D 0 } } - T{ ##replace { src V int-regs 60 } { loc R 0 } } - T{ ##call { word resize-string } } - T{ ##branch } -} -4 test-bb - -V{ - T{ ##peek { dst V int-regs 67 } { loc R 0 } } - T{ ##peek { dst V int-regs 68 } { loc D 0 } } - T{ ##set-slot-imm - { src V int-regs 68 } - { obj V int-regs 67 } - { slot 2 } - { tag 7 } - } - T{ ##write-barrier - { src V int-regs 67 } - { card# V int-regs 75 } - { table V int-regs 76 } - } - T{ ##inc-d { n -1 } } - T{ ##inc-r { n -1 } } - T{ ##peek { dst V int-regs 94 } { loc D 0 } } - T{ ##peek { dst V int-regs 96 } { loc D 1 } } - T{ ##peek { dst V int-regs 98 } { loc D 2 } } - T{ ##peek { dst V int-regs 100 } { loc D 3 } } - T{ ##peek { dst V int-regs 102 } { loc D 4 } } - T{ ##peek { dst V int-regs 106 } { loc R 0 } } - T{ ##copy { dst V int-regs 95 } { src V int-regs 94 } } - T{ ##copy { dst V int-regs 97 } { src V int-regs 96 } } - T{ ##copy { dst V int-regs 99 } { src V int-regs 98 } } - T{ ##copy { dst V int-regs 101 } { src V int-regs 100 } } - T{ ##copy { dst V int-regs 103 } { src V int-regs 102 } } - T{ ##copy { dst V int-regs 107 } { src V int-regs 106 } } - T{ ##branch } -} -5 test-bb - -V{ - T{ ##inc-d { n 3 } } - T{ ##inc-r { n 1 } } - T{ ##copy { dst V int-regs 95 } { src V int-regs 1 } } - T{ ##copy { dst V int-regs 97 } { src V int-regs 25 } } - T{ ##copy { dst V int-regs 99 } { src V int-regs 1 } } - T{ ##copy { dst V int-regs 101 } { src V int-regs 5 } } - T{ ##copy { dst V int-regs 103 } { src V int-regs 7 } } - T{ ##copy { dst V int-regs 107 } { src V int-regs 12 } } - T{ ##branch } -} -6 test-bb - -V{ - T{ ##load-immediate - { dst V int-regs 78 } - { val 4611686018427387896 } - } - T{ ##and - { dst V int-regs 81 } - { src1 V int-regs 97 } - { src2 V int-regs 78 } - } - T{ ##set-slot-imm - { src V int-regs 81 } - { obj V int-regs 95 } - { slot 3 } - { tag 7 } - } - T{ ##inc-d { n -2 } } - T{ ##copy { dst V int-regs 110 } { src V int-regs 99 } } - T{ ##copy { dst V int-regs 111 } { src V int-regs 101 } } - T{ ##copy { dst V int-regs 112 } { src V int-regs 103 } } - T{ ##copy { dst V int-regs 117 } { src V int-regs 107 } } - T{ ##branch } -} -7 test-bb - -V{ - T{ ##inc-d { n 1 } } - T{ ##inc-r { n 1 } } - T{ ##copy { dst V int-regs 110 } { src V int-regs 1 } } - T{ ##copy { dst V int-regs 111 } { src V int-regs 5 } } - T{ ##copy { dst V int-regs 112 } { src V int-regs 7 } } - T{ ##copy { dst V int-regs 117 } { src V int-regs 12 } } - T{ ##branch } -} -8 test-bb - -V{ - T{ ##inc-d { n 1 } } - T{ ##inc-r { n -1 } } - T{ ##replace { src V int-regs 117 } { loc D 0 } } - T{ ##replace { src V int-regs 110 } { loc D 1 } } - T{ ##replace { src V int-regs 111 } { loc D 2 } } - T{ ##replace { src V int-regs 112 } { loc D 3 } } - T{ ##epilogue } - T{ ##return } -} -9 test-bb - -0 get 1 get 1vector >>successors drop -1 get 2 get 8 get V{ } 2sequence >>successors drop -2 get 3 get 6 get V{ } 2sequence >>successors drop -3 get 4 get 1vector >>successors drop -4 get 5 get 1vector >>successors drop -5 get 7 get 1vector >>successors drop -6 get 7 get 1vector >>successors drop -7 get 9 get 1vector >>successors drop -8 get 9 get 1vector >>successors drop - -[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test - ! Fencepost error in assignment pass V{ T{ ##branch } } 0 test-bb diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index a75ac064d9..9faa1e9e38 100755 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -31,8 +31,10 @@ M: insn linearize-insn , drop ; M: ##branch linearize-insn drop dup successors>> first emit-branch ; +: successors ( bb -- first second ) successors>> first2 ; inline + : (binary-conditional) ( basic-block insn -- basic-block successor1 successor2 src1 src2 cc ) - [ dup successors>> first2 ] + [ dup successors ] [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline : binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc ) @@ -52,6 +54,19 @@ M: ##compare-imm-branch linearize-insn M: ##compare-float-branch linearize-insn [ binary-conditional _compare-float-branch ] with-regs emit-branch ; +: overflow-conditional ( basic-block insn -- basic-block successor label2 dst src1 src2 ) + [ dup successors number>> ] + [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline + +M: ##fixnum-add linearize-insn + [ overflow-conditional _fixnum-add ] with-regs emit-branch ; + +M: ##fixnum-sub linearize-insn + [ overflow-conditional _fixnum-sub ] with-regs emit-branch ; + +M: ##fixnum-mul linearize-insn + [ overflow-conditional _fixnum-mul ] with-regs emit-branch ; + M: ##dispatch linearize-insn swap [ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ] diff --git a/basis/compiler/cfg/renaming/renaming.factor b/basis/compiler/cfg/renaming/renaming.factor index 228d72483c..efc841e21f 100644 --- a/basis/compiler/cfg/renaming/renaming.factor +++ b/basis/compiler/cfg/renaming/renaming.factor @@ -136,16 +136,6 @@ M: ##compare-imm fresh-insn-temps M: ##compare-float fresh-insn-temps [ fresh-vreg ] change-temp drop ; -M: ##fixnum-mul fresh-insn-temps - [ fresh-vreg ] change-temp1 - [ fresh-vreg ] change-temp2 - drop ; - -M: ##fixnum-mul-tail fresh-insn-temps - [ fresh-vreg ] change-temp1 - [ fresh-vreg ] change-temp2 - drop ; - M: ##gc fresh-insn-temps [ fresh-vreg ] change-temp1 [ fresh-vreg ] change-temp2 diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor index 51baea71a9..e46460a741 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor @@ -61,7 +61,8 @@ UNION: sync-if-back-edge ##conditional-branch ##compare-imm-branch ##dispatch - ##loop-entry ; + ##loop-entry + ##fixnum-overflow ; : sync-state? ( -- ? ) basic-block get successors>> diff --git a/basis/compiler/cfg/tco/tco.factor b/basis/compiler/cfg/tco/tco.factor index 8be9c15b04..3dbdf148e9 100644 --- a/basis/compiler/cfg/tco/tco.factor +++ b/basis/compiler/cfg/tco/tco.factor @@ -53,28 +53,11 @@ IN: compiler.cfg.tco [ [ cfg get entry>> successors>> first ] dip successors>> push ] tri ; -: fixnum-tail-call? ( bb -- ? ) - instructions>> penultimate - { [ ##fixnum-add? ] [ ##fixnum-sub? ] [ ##fixnum-mul? ] } 1|| ; - -GENERIC: convert-fixnum-tail-call* ( src1 src2 insn -- insn' ) - -M: ##fixnum-add convert-fixnum-tail-call* drop \ ##fixnum-add-tail new-insn ; -M: ##fixnum-sub convert-fixnum-tail-call* drop \ ##fixnum-sub-tail new-insn ; -M: ##fixnum-mul convert-fixnum-tail-call* drop i i \ ##fixnum-mul-tail new-insn ; - -: convert-fixnum-tail-call ( bb -- ) - [ - [ src1>> ] [ src2>> ] [ ] tri - convert-fixnum-tail-call* - ] convert-tail-call ; - : optimize-tail-call ( bb -- ) dup tail-call? [ { { [ dup loop-tail-call? ] [ convert-loop-tail-call ] } { [ dup word-tail-call? ] [ convert-word-tail-call ] } - { [ dup fixnum-tail-call? ] [ convert-fixnum-tail-call ] } [ drop ] } cond ] [ drop ] if ; diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor index d30a02b0d3..98bbfb9cd0 100644 --- a/basis/compiler/cfg/two-operand/two-operand.factor +++ b/basis/compiler/cfg/two-operand/two-operand.factor @@ -44,6 +44,8 @@ M: ##shl-imm convert-two-operand* convert-two-operand/integer ; M: ##shr-imm convert-two-operand* convert-two-operand/integer ; M: ##sar-imm convert-two-operand* convert-two-operand/integer ; +M: ##fixnum-overflow convert-two-operand* convert-two-operand/integer ; + M: ##add-float convert-two-operand* convert-two-operand/float ; M: ##sub-float convert-two-operand* convert-two-operand/float ; M: ##mul-float convert-two-operand* convert-two-operand/float ; diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index 288fa403dd..9cb8bf26f9 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -36,6 +36,18 @@ IN: compiler.cfg.utilities : emit-primitive ( node -- ) word>> ##call ##branch begin-basic-block ; +: with-branch ( quot -- final-bb ) + [ + begin-basic-block + call + basic-block get dup [ ##branch ] when + ] with-scope ; inline + +: emit-conditional ( branches -- ) + end-basic-block + begin-basic-block + basic-block get '[ [ _ swap successors>> push ] when* ] each ; + : back-edge? ( from to -- ? ) [ number>> ] bi@ >= ; diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index df6e91aec9..42c6bf45cb 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -171,18 +171,12 @@ M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ; M: ##not generate-insn dst/src %not ; M: ##log2 generate-insn dst/src %log2 ; -: src1/src2 ( insn -- src1 src2 ) - [ src1>> register ] [ src2>> register ] bi ; inline +: label/dst/src1/src2 ( insn -- label dst src1 src2 ) + [ label>> lookup-label ] [ dst/src1/src2 ] bi ; inline -: src1/src2/temp1/temp2 ( insn -- src1 src2 temp1 temp2 ) - [ src1/src2 ] [ temp1>> register ] [ temp2>> register ] tri ; inline - -M: ##fixnum-add generate-insn src1/src2 %fixnum-add ; -M: ##fixnum-add-tail generate-insn src1/src2 %fixnum-add-tail ; -M: ##fixnum-sub generate-insn src1/src2 %fixnum-sub ; -M: ##fixnum-sub-tail generate-insn src1/src2 %fixnum-sub-tail ; -M: ##fixnum-mul generate-insn src1/src2/temp1/temp2 %fixnum-mul ; -M: ##fixnum-mul-tail generate-insn src1/src2/temp1/temp2 %fixnum-mul-tail ; +M: _fixnum-add generate-insn label/dst/src1/src2 %fixnum-add ; +M: _fixnum-sub generate-insn label/dst/src1/src2 %fixnum-sub ; +M: _fixnum-mul generate-insn label/dst/src1/src2 %fixnum-mul ; : dst/src/temp ( insn -- dst src temp ) [ dst/src ] [ temp>> register ] bi ; inline diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 4fc4f4814b..d6906d6348 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006, 2008 Slava Pestov. +! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel assocs match fry accessors namespaces make effects sequences sequences.private quotations generic macros arrays @@ -15,7 +15,9 @@ compiler.tree.def-use compiler.tree.builder compiler.tree.optimizer compiler.tree.combinators -compiler.tree.checker ; +compiler.tree.checker +compiler.tree.dead-code +compiler.tree.modular-arithmetic ; FROM: fry => _ ; RENAME: _ match => __ IN: compiler.tree.debugger @@ -201,8 +203,15 @@ SYMBOL: node-count : cleaned-up-tree ( quot -- nodes ) [ - check-optimizer? on - build-tree optimize-tree + build-tree + analyze-recursive + normalize + propagate + cleanup + compute-def-use + remove-dead-code + compute-def-use + optimize-modular-arithmetic ] with-scope ; : inlined? ( quot seq/word -- ? ) diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor index 0e72deb6fa..4c17399c95 100644 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/basis/compiler/tree/finalization/finalization.factor @@ -46,6 +46,9 @@ M: predicate finalize-word [ drop ] } cond ; +M: math-partial finalize-word + dup primitive? [ drop ] [ nip cached-expansion ] if ; + M: word finalize-word drop ; M: #call finalize* diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor index 7fb1b3d5ac..13555d45f7 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor @@ -4,12 +4,12 @@ IN: compiler.tree.modular-arithmetic.tests USING: kernel kernel.private tools.test math math.partial-dispatch math.private accessors slots.private sequences strings sbufs compiler.tree.builder -compiler.tree.optimizer +compiler.tree.normalization compiler.tree.debugger alien.accessors layouts combinators byte-arrays ; : test-modular-arithmetic ( quot -- quot' ) - build-tree optimize-tree nodes>quot ; + cleaned-up-tree nodes>quot ; [ [ >R >fixnum R> >fixnum fixnum+fast ] ] [ [ { integer integer } declare + >fixnum ] test-modular-arithmetic ] unit-test diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 556424f50c..41dd53fa8a 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -82,12 +82,9 @@ HOOK: %sar-imm cpu ( dst src1 src2 -- ) HOOK: %not cpu ( dst src -- ) HOOK: %log2 cpu ( dst src -- ) -HOOK: %fixnum-add cpu ( src1 src2 -- ) -HOOK: %fixnum-add-tail cpu ( src1 src2 -- ) -HOOK: %fixnum-sub cpu ( src1 src2 -- ) -HOOK: %fixnum-sub-tail cpu ( src1 src2 -- ) -HOOK: %fixnum-mul cpu ( src1 src2 temp1 temp2 -- ) -HOOK: %fixnum-mul-tail cpu ( src1 src2 temp1 temp2 -- ) +HOOK: %fixnum-add cpu ( label dst src1 src2 -- ) +HOOK: %fixnum-sub cpu ( label dst src1 src2 -- ) +HOOK: %fixnum-mul cpu ( label dst src1 src2 -- ) HOOK: %integer>bignum cpu ( dst src temp -- ) HOOK: %bignum>integer cpu ( dst src temp -- ) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 96a99f4d5e..727131aa25 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -51,8 +51,6 @@ M: x86.32 reserved-area-size 0 ; M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ; -M: x86.32 %alien-invoke-tail 0 JMP rc-relative rel-dlsym ; - M: x86.32 return-struct-in-registers? ( c-type -- ? ) c-type [ return-in-registers?>> ] diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 5390d7e0c8..8eb04eb2b5 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -167,11 +167,6 @@ M: x86.64 %alien-invoke rc-absolute-cell rel-dlsym R11 CALL ; -M: x86.64 %alien-invoke-tail - R11 0 MOV - rc-absolute-cell rel-dlsym - R11 JMP ; - M: x86.64 %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke RBP RAX MOV ; diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index bb2ee620e3..bd39549973 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -129,83 +129,18 @@ M: x86 %log2 BSR ; : ?MOV ( dst src -- ) 2dup = [ 2drop ] [ MOV ] if ; inline -:: move>args ( src1 src2 -- ) - { - { [ src1 param-reg-2 = ] [ param-reg-1 src2 ?MOV param-reg-1 param-reg-2 XCHG ] } - { [ src1 param-reg-1 = ] [ param-reg-2 src2 ?MOV ] } - { [ src2 param-reg-1 = ] [ param-reg-2 src1 ?MOV param-reg-1 param-reg-2 XCHG ] } - { [ src2 param-reg-2 = ] [ param-reg-1 src1 ?MOV ] } - [ - param-reg-1 src1 MOV - param-reg-2 src2 MOV - ] - } cond ; - -HOOK: %alien-invoke-tail cpu ( func dll -- ) - -:: overflow-template ( src1 src2 insn inverse func -- ) -