diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
index d55266e6e4..4b504d97f5 100644
--- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
@@ -3,7 +3,6 @@
USING: accessors assocs heaps kernel namespaces sequences fry math
math.order combinators arrays sorting compiler.utilities
compiler.cfg.linear-scan.live-intervals
-compiler.cfg.linear-scan.allocation.coalescing
compiler.cfg.linear-scan.allocation.spilling
compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.allocation.state ;
@@ -29,13 +28,11 @@ IN: compiler.cfg.linear-scan.allocation
second 0 = ; inline
: assign-register ( new -- )
- dup coalesce? [ coalesce ] [
- dup register-status {
- { [ dup no-free-registers? ] [ drop assign-blocked-register ] }
- { [ 2dup register-available? ] [ register-available ] }
- [ drop assign-blocked-register ]
- } cond
- ] if ;
+ dup register-status {
+ { [ dup no-free-registers? ] [ drop assign-blocked-register ] }
+ { [ 2dup register-available? ] [ register-available ] }
+ [ drop assign-blocked-register ]
+ } cond ;
: handle-interval ( live-interval -- )
[
diff --git a/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor b/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor
deleted file mode 100644
index ef8a9c56f8..0000000000
--- a/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor
+++ /dev/null
@@ -1,35 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences namespaces assocs fry
-combinators.short-circuit
-compiler.cfg.linear-scan.live-intervals
-compiler.cfg.linear-scan.allocation.state ;
-IN: compiler.cfg.linear-scan.allocation.coalescing
-
-: active-interval ( vreg -- live-interval )
- dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
-
-: avoids-inactive-intervals? ( live-interval -- ? )
- dup vreg>> inactive-intervals-for
- [ intervals-intersect? not ] with all? ;
-
-: coalesce? ( live-interval -- ? )
- {
- [ copy-from>> active-interval ]
- [ [ start>> ] [ copy-from>> active-interval end>> ] bi = ]
- [ avoids-inactive-intervals? ]
- } 1&& ;
-
-: reuse-spill-slot ( old new -- )
- [ vreg>> spill-slots get at ] dip '[ _ vreg>> spill-slots get set-at ] when* ;
-
-: reuse-register ( old new -- )
- reg>> >>reg drop ;
-
-: (coalesce) ( old new -- )
- [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ;
-
-: coalesce ( live-interval -- )
- dup copy-from>> active-interval
- [ reuse-spill-slot ] [ reuse-register ] [ (coalesce) ] 2tri ;
-
\ No newline at end of file
diff --git a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor
index 874523d70a..1a2b0f2f2b 100644
--- a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor
@@ -45,7 +45,7 @@ ERROR: splitting-atomic-interval ;
f >>spill-to ; inline
: split-after ( after -- after' )
- f >>copy-from f >>reg f >>reload-from ; inline
+ f >>reg f >>reload-from ; inline
:: split-interval ( live-interval n -- before after )
live-interval n check-split
diff --git a/basis/compiler/cfg/linear-scan/debugger/debugger.factor b/basis/compiler/cfg/linear-scan/debugger/debugger.factor
index c9c1b77a0d..68ff8d4f88 100644
--- a/basis/compiler/cfg/linear-scan/debugger/debugger.factor
+++ b/basis/compiler/cfg/linear-scan/debugger/debugger.factor
@@ -18,9 +18,8 @@ IN: compiler.cfg.linear-scan.debugger
: interval-picture ( interval -- str )
[ uses>> picture ]
- [ copy-from>> unparse ]
[ vreg>> unparse ]
- tri 3array ;
+ bi 2array ;
: live-intervals. ( seq -- )
[ interval-picture ] map simple-table. ;
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index 2164cef429..7cca94c061 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -470,7 +470,6 @@ USING: math.private ;
clone dup [ start>> ] [ end>> ] bi <live-range> 1vector >>ranges
] map ;
-! Coalescing interacted badly with splitting
[ ] [
{
T{ live-interval
@@ -478,7 +477,6 @@ USING: math.private ;
{ start 14 }
{ end 17 }
{ uses V{ 14 15 16 17 } }
- { copy-from V int-regs 67 }
}
T{ live-interval
{ vreg V int-regs 67 }
@@ -503,7 +501,6 @@ USING: math.private ;
{ start 10 }
{ end 18 }
{ uses V{ 10 11 12 18 } }
- { copy-from V int-regs 56 }
}
T{ live-interval
{ vreg V int-regs 60 }
@@ -559,7 +556,6 @@ USING: math.private ;
{ start 44 }
{ end 56 }
{ uses V{ 44 45 45 46 56 } }
- { copy-from V int-regs 3686445 }
}
T{ live-interval
{ vreg V int-regs 3686198 }
@@ -572,7 +568,6 @@ USING: math.private ;
{ start 46 }
{ end 49 }
{ uses V{ 46 47 47 49 } }
- { copy-from V int-regs 3686449 }
}
T{ live-interval
{ vreg V int-regs 3686196 }
@@ -603,7 +598,6 @@ USING: math.private ;
{ start 49 }
{ end 52 }
{ uses V{ 49 50 50 52 } }
- { copy-from V int-regs 3686454 }
}
T{ live-interval
{ vreg V int-regs 3686461 }
@@ -622,42 +616,36 @@ USING: math.private ;
{ start 54 }
{ end 76 }
{ uses V{ 54 55 55 76 } }
- { copy-from V int-regs 3686464 }
}
T{ live-interval
{ vreg V int-regs 3686470 }
{ start 58 }
{ end 60 }
{ uses V{ 58 59 59 60 } }
- { copy-from V int-regs 3686469 }
}
T{ live-interval
{ vreg V int-regs 3686469 }
{ start 56 }
{ end 58 }
{ uses V{ 56 57 57 58 } }
- { copy-from V int-regs 3686449 }
}
T{ live-interval
{ vreg V int-regs 3686473 }
{ start 60 }
{ end 62 }
{ uses V{ 60 61 61 62 } }
- { copy-from V int-regs 3686470 }
}
T{ live-interval
{ vreg V int-regs 3686479 }
{ start 62 }
{ end 64 }
{ uses V{ 62 63 63 64 } }
- { copy-from V int-regs 3686473 }
}
T{ live-interval
{ vreg V int-regs 3686735 }
{ start 78 }
{ end 96 }
{ uses V{ 78 79 79 96 } }
- { copy-from V int-regs 3686372 }
}
T{ live-interval
{ vreg V int-regs 3686482 }
@@ -688,7 +676,6 @@ USING: math.private ;
{ start 66 }
{ end 75 }
{ uses V{ 66 67 67 75 } }
- { copy-from V int-regs 3686483 }
}
T{ live-interval
{ vreg V int-regs 3687509 }
@@ -719,7 +706,6 @@ USING: math.private ;
{ start 69 }
{ end 74 }
{ uses V{ 69 70 70 74 } }
- { copy-from V int-regs 3686491 }
}
T{ live-interval
{ vreg V int-regs 3687778 }
@@ -762,7 +748,6 @@ USING: math.private ;
{ start 72 }
{ end 74 }
{ uses V{ 72 73 73 74 } }
- { copy-from V int-regs 3686499 }
}
T{ live-interval
{ vreg V int-regs 3687780 }
@@ -877,7 +862,6 @@ USING: math.private ;
{ start 27 }
{ end 30 }
{ uses V{ 27 28 28 30 } }
- { copy-from V int-regs 3686300 }
}
T{ live-interval
{ vreg V int-regs 3686306 }
@@ -950,7 +934,6 @@ USING: math.private ;
{ start 243 }
{ end 245 }
{ uses V{ 243 244 244 245 } }
- { copy-from V int-regs 3687845 }
}
T{ live-interval
{ vreg V int-regs 3687850 }
@@ -1119,7 +1102,6 @@ USING: math.private ;
{ start 141 }
{ end 143 }
{ uses V{ 141 142 142 143 } }
- { copy-from V int-regs 3687377 }
}
T{ live-interval
{ vreg V int-regs 3687381 }
@@ -1174,7 +1156,6 @@ USING: math.private ;
{ start 293 }
{ end 295 }
{ uses V{ 293 294 294 295 } }
- { copy-from V int-regs 3687087 }
}
T{ live-interval
{ vreg V int-regs 3687403 }
@@ -1345,7 +1326,6 @@ USING: math.private ;
{ start 78 }
{ end 96 }
{ uses V{ 78 79 96 } }
- { copy-from V int-regs 6372 }
}
T{ live-interval
{ vreg V int-regs 6483 }
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 48bef197e6..8cc28e41e2 100644
--- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
+++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
@@ -13,8 +13,7 @@ C: <live-range> live-range
TUPLE: live-interval
vreg
reg spill-to reload-from
-start end ranges uses
-copy-from ;
+start end ranges uses ;
GENERIC: covers? ( insn# obj -- ? )
@@ -102,15 +101,6 @@ M: vreg-insn compute-live-intervals*
[ [ temp-vregs ] 2dip '[ [ _ ] dip _ handle-temp ] each ]
3tri ;
-: record-copy ( insn -- )
- [ dst>> live-intervals get at ] [ src>> ] bi >>copy-from drop ;
-
-M: ##copy compute-live-intervals*
- [ call-next-method ] [ record-copy ] bi ;
-
-M: ##copy-float compute-live-intervals*
- [ call-next-method ] [ record-copy ] bi ;
-
: handle-live-out ( bb -- )
live-out keys
basic-block get [ block-from ] [ block-to ] bi
diff --git a/basis/compiler/cfg/mr/mr.factor b/basis/compiler/cfg/mr/mr.factor
index cb198d5149..77d9f1ce18 100644
--- a/basis/compiler/cfg/mr/mr.factor
+++ b/basis/compiler/cfg/mr/mr.factor
@@ -1,12 +1,11 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.cfg.linearization compiler.cfg.two-operand
-compiler.cfg.gc-checks compiler.cfg.linear-scan
-compiler.cfg.build-stack-frame compiler.cfg.rpo ;
+USING: compiler.cfg.linearization compiler.cfg.gc-checks
+compiler.cfg.linear-scan compiler.cfg.build-stack-frame
+compiler.cfg.rpo ;
IN: compiler.cfg.mr
: build-mr ( cfg -- mr )
- convert-two-operand
insert-gc-checks
linear-scan
flatten-cfg
diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor
index 8e2df04cca..2026cdb4c3 100644
--- a/basis/compiler/cfg/optimizer/optimizer.factor
+++ b/basis/compiler/cfg/optimizer/optimizer.factor
@@ -11,6 +11,7 @@ compiler.cfg.value-numbering
compiler.cfg.copy-prop
compiler.cfg.dce
compiler.cfg.write-barrier
+compiler.cfg.two-operand
compiler.cfg.ssa.destruction
compiler.cfg.empty-blocks
compiler.cfg.predecessors
@@ -42,6 +43,7 @@ SYMBOL: check-optimizer?
copy-propagation
eliminate-dead-code
eliminate-write-barriers
+ convert-two-operand
destruct-ssa
delete-empty-blocks
?check
diff --git a/basis/compiler/cfg/ssa/destruction/destruction.factor b/basis/compiler/cfg/ssa/destruction/destruction.factor
index 3e6172229a..02e48962cb 100644
--- a/basis/compiler/cfg/ssa/destruction/destruction.factor
+++ b/basis/compiler/cfg/ssa/destruction/destruction.factor
@@ -58,9 +58,13 @@ SYMBOL: copies
GENERIC: prepare-insn ( insn -- )
-M: ##copy prepare-insn
+: prepare-copy ( insn -- )
[ dst>> ] [ src>> ] bi 2array copies get push ;
+M: ##copy prepare-insn prepare-copy ;
+
+M: ##copy-float prepare-insn prepare-copy ;
+
M: ##phi prepare-insn
[ dst>> ] [ inputs>> values ] bi
[ eliminate-copy ] with each ;
@@ -81,8 +85,10 @@ M: insn prepare-insn drop ;
[ 2drop ] [ eliminate-copy ] if
] assoc-each ;
+UNION: copy-insn ##copy ##copy-float ;
+
: useless-copy? ( ##copy -- ? )
- dup ##copy? [ [ dst>> ] [ src>> ] bi eq? ] [ drop f ] if ;
+ dup copy-insn? [ [ dst>> ] [ src>> ] bi eq? ] [ drop f ] if ;
: perform-renaming ( cfg -- )
leader-map get keys [ dup leader ] H{ } map>assoc renamings set
@@ -95,13 +101,11 @@ M: insn prepare-insn drop ;
] each-basic-block ;
: destruct-ssa ( cfg -- cfg' )
- dup cfg-has-phis? [
- dup construct-cssa
- dup compute-defs
- dup compute-dominance
- compute-ssa-live-sets
- dup compute-live-ranges
- dup prepare-coalescing
- process-copies
- dup perform-renaming
- ] when ;
\ No newline at end of file
+ dup construct-cssa
+ dup compute-defs
+ dup compute-dominance
+ compute-ssa-live-sets
+ dup compute-live-ranges
+ dup prepare-coalescing
+ process-copies
+ dup perform-renaming ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/ssa/interference/interference.factor b/basis/compiler/cfg/ssa/interference/interference.factor
index dd002ec977..a76b55cd83 100644
--- a/basis/compiler/cfg/ssa/interference/interference.factor
+++ b/basis/compiler/cfg/ssa/interference/interference.factor
@@ -6,6 +6,11 @@ compiler.cfg.def-use compiler.cfg.dominance
compiler.cfg.ssa.interference.live-ranges ;
IN: compiler.cfg.ssa.interference
+! Interference testing using SSA properties. Actually the only SSA property
+! used here is that definitions dominate uses; because of this, the input
+! is allowed to have multiple definitions of each vreg as long as they're
+! all in the same basic block. This is needed because two-operand conversion
+! runs before coalescing, which uses SSA interference testing.
<PRIVATE
:: kill-after-def? ( vreg1 vreg2 bb -- ? )
@@ -47,9 +52,10 @@ PRIVATE>
[ 2drop 2drop f ]
} cond ;
-! Debug this stuff later
<PRIVATE
+! Debug this stuff later
+
: quadratic-test? ( seq1 seq2 -- ? ) [ length ] bi@ + 10 < ;
: quadratic-test ( seq1 seq2 -- ? )
diff --git a/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor b/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor
index 151af8bea4..c094b18ce9 100644
--- a/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor
+++ b/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor
@@ -11,8 +11,13 @@ IN: compiler.cfg.ssa.interference.live-ranges
SYMBOLS: local-def-indices local-kill-indices ;
-: record-def ( n vregs -- )
- dup [ local-def-indices get set-at ] [ 2drop ] if ;
+: record-def ( n vreg -- )
+ ! We allow multiple defs of a vreg as long as they're
+ ! all in the same basic block
+ dup [
+ local-def-indices get 2dup key?
+ [ 3drop ] [ set-at ] if
+ ] [ 2drop ] if ;
: record-uses ( n vregs -- )
local-kill-indices get '[ _ set-at ] with each ;
diff --git a/basis/compiler/cfg/two-operand/two-operand-tests.factor b/basis/compiler/cfg/two-operand/two-operand-tests.factor
index 0717f1c536..fb0ab6ff03 100644
--- a/basis/compiler/cfg/two-operand/two-operand-tests.factor
+++ b/basis/compiler/cfg/two-operand/two-operand-tests.factor
@@ -14,25 +14,3 @@ compiler.cfg.registers cpu.architecture namespaces tools.test ;
T{ ##sub f V int-regs 1 V int-regs 2 V int-regs 3 }
} (convert-two-operand)
] unit-test
-
-[
- V{
- T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 2 }
- }
-] [
- {
- T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 2 }
- } (convert-two-operand)
-] unit-test
-
-[
- V{
- T{ ##copy f V int-regs 4 V int-regs 1 }
- T{ ##copy f V int-regs 1 V int-regs 2 }
- T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 4 }
- }
-] [
- {
- T{ ##sub f V int-regs 1 V int-regs 2 V int-regs 1 }
- } (convert-two-operand)
-] unit-test
diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor
index 7a8b160acd..729c476cc4 100644
--- a/basis/compiler/cfg/two-operand/two-operand.factor
+++ b/basis/compiler/cfg/two-operand/two-operand.factor
@@ -5,27 +5,17 @@ compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.rpo cpu.architecture ;
IN: compiler.cfg.two-operand
-! This pass runs after SSA coalescing and normalizes instructions
-! to fit the x86 two-address scheme. Possibilities are:
-
-! 1) x = x op y
-! 2) x = y op x
-! 3) x = y op z
-
-! In case 1, there is nothing to do.
-
-! In case 2, we convert to
-! z = y
-! z = z op x
-! x = z
-
-! In case 3, we convert to
+! This pass runs before SSA coalescing and normalizes instructions
+! to fit the x86 two-address scheme. Since the input is in SSA,
+! it suffices to convert
+!
+! x = y op z
+!
+! to
+!
! x = y
! x = x op z
-
-! In case 2 and case 3, linear scan coalescing will eliminate a
-! copy if the value y is never used again.
-
+!
! We don't bother with ##add, ##add-imm, ##sub-imm or ##mul-imm
! since x86 has LEA and IMUL instructions which are effectively
! three-operand addition and multiplication, respectively.
@@ -59,37 +49,15 @@ GENERIC: convert-two-operand* ( insn -- )
{ double-float-regs [ ##copy-float ] }
} case ; inline
-: case-1? ( insn -- ? ) [ dst>> ] [ src1>> ] bi = ; inline
-
-: case-1 ( insn -- ) , ; inline
-
-: case-2? ( insn -- ? ) [ dst>> ] [ src2>> ] bi = ; inline
-
-: case-2 ( insn -- )
- dup dst>> reg-class>> next-vreg
- [ swap src2>> emit-copy ]
- [ drop [ src2>> ] [ src1>> ] bi emit-copy ]
- [ >>src2 dup dst>> >>src1 , ]
- 2tri ; inline
-
-: case-3 ( insn -- )
+M: two-operand-insn convert-two-operand*
[ [ dst>> ] [ src1>> ] bi emit-copy ]
[ dup dst>> >>src1 , ]
- bi ; inline
-
-M: two-operand-insn convert-two-operand*
- {
- { [ dup case-1? ] [ case-1 ] }
- { [ dup case-2? ] [ case-2 ] }
- [ case-3 ]
- } cond ; inline
+ bi ;
M: ##not convert-two-operand*
- dup [ dst>> ] [ src>> ] bi = [
- [ [ dst>> ] [ src>> ] bi ##copy ]
- [ dup dst>> >>src ]
- bi
- ] unless , ;
+ [ [ dst>> ] [ src>> ] bi emit-copy ]
+ [ dup dst>> >>src , ]
+ bi ;
M: insn convert-two-operand* , ;
diff --git a/basis/compiler/tree/checker/checker.factor b/basis/compiler/tree/checker/checker.factor
index e25f152aef..0b3b46fe33 100755
--- a/basis/compiler/tree/checker/checker.factor
+++ b/basis/compiler/tree/checker/checker.factor
@@ -5,6 +5,7 @@ arrays combinators continuations columns math vectors
grouping stack-checker.branches
compiler.tree
compiler.tree.def-use
+compiler.tree.recursive
compiler.tree.combinators ;
IN: compiler.tree.checker
diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor
index 1b0343faa9..3232e965db 100644
--- a/basis/compiler/tree/cleanup/cleanup.factor
+++ b/basis/compiler/tree/cleanup/cleanup.factor
@@ -20,7 +20,7 @@ IN: compiler.tree.cleanup
GENERIC: delete-node ( node -- )
M: #call-recursive delete-node
- dup label>> [ [ eq? not ] with filter ] change-calls drop ;
+ dup label>> calls>> [ node>> eq? not ] with filter-here ;
M: #return-recursive delete-node
label>> f >>return drop ;
diff --git a/basis/compiler/tree/dead-code/recursive/recursive.factor b/basis/compiler/tree/dead-code/recursive/recursive.factor
index 71830d07e7..b0ab864c80 100644
--- a/basis/compiler/tree/dead-code/recursive/recursive.factor
+++ b/basis/compiler/tree/dead-code/recursive/recursive.factor
@@ -3,6 +3,7 @@
USING: accessors arrays assocs sequences kernel locals fry
combinators stack-checker.backend
compiler.tree
+compiler.tree.recursive
compiler.tree.dead-code.branches
compiler.tree.dead-code.liveness
compiler.tree.dead-code.simple ;
diff --git a/basis/compiler/tree/escape-analysis/recursive/recursive.factor b/basis/compiler/tree/escape-analysis/recursive/recursive.factor
index 5aece23d17..ad6572a35c 100644
--- a/basis/compiler/tree/escape-analysis/recursive/recursive.factor
+++ b/basis/compiler/tree/escape-analysis/recursive/recursive.factor
@@ -3,6 +3,7 @@
USING: kernel sequences math combinators accessors namespaces
fry disjoint-sets
compiler.tree
+compiler.tree.recursive
compiler.tree.combinators
compiler.tree.escape-analysis.nodes
compiler.tree.escape-analysis.branches
@@ -67,5 +68,5 @@ M: #return-recursive escape-analysis* ( #return-recursive -- )
[ call-next-method ]
[
[ in-d>> ] [ label>> calls>> ] bi
- [ out-d>> escaping-values get '[ _ equate ] 2each ] with each
+ [ node>> out-d>> escaping-values get '[ _ equate ] 2each ] with each
] bi ;
diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor
index b8d1760a0b..64b7ba4609 100644
--- a/basis/compiler/tree/propagation/recursive/recursive.factor
+++ b/basis/compiler/tree/propagation/recursive/recursive.factor
@@ -21,7 +21,7 @@ IN: compiler.tree.propagation.recursive
in-d>> [ value-info ] map ;
: recursive-stacks ( #enter-recursive -- stacks initial )
- [ label>> calls>> [ node-input-infos ] map flip ]
+ [ label>> calls>> [ node>> node-input-infos ] map flip ]
[ latest-input-infos ] bi ;
: generalize-counter-interval ( interval initial-interval -- interval' )
diff --git a/basis/compiler/tree/recursive/recursive-tests.factor b/basis/compiler/tree/recursive/recursive-tests.factor
index 80edae076f..8157084805 100644
--- a/basis/compiler/tree/recursive/recursive-tests.factor
+++ b/basis/compiler/tree/recursive/recursive-tests.factor
@@ -1,9 +1,10 @@
IN: compiler.tree.recursive.tests
-USING: compiler.tree.recursive tools.test
-kernel combinators.short-circuit math sequences accessors
+USING: tools.test kernel combinators.short-circuit math sequences accessors
compiler.tree
compiler.tree.builder
-compiler.tree.combinators ;
+compiler.tree.combinators
+compiler.tree.recursive
+compiler.tree.recursive.private ;
[ { f f f f } ] [ f { f t f f } (tail-calls) ] unit-test
[ { f f f t } ] [ t { f t f f } (tail-calls) ] unit-test
@@ -67,13 +68,6 @@ compiler.tree.combinators ;
\ loop-test-3 label-is-not-loop?
] unit-test
-: loop-test-4 ( a -- )
- dup [
- loop-test-4
- ] [
- drop
- ] if ; inline recursive
-
[ f ] [
[ [ [ ] map ] map ] build-tree analyze-recursive
[
@@ -145,17 +139,32 @@ DEFER: a'
DEFER: a''
-: b'' ( -- )
+: b'' ( a -- b )
a'' ; inline recursive
-: a'' ( -- )
- b'' a'' ; inline recursive
+: a'' ( a -- b )
+ dup [ b'' a'' ] when ; inline recursive
[ t ] [
[ a'' ] build-tree analyze-recursive
\ a'' label-is-not-loop?
] unit-test
+[ t ] [
+ [ a'' ] build-tree analyze-recursive
+ \ b'' label-is-loop?
+] unit-test
+
+[ t ] [
+ [ b'' ] build-tree analyze-recursive
+ \ a'' label-is-loop?
+] unit-test
+
+[ t ] [
+ [ b'' ] build-tree analyze-recursive
+ \ b'' label-is-not-loop?
+] unit-test
+
: loop-in-non-loop ( x quot: ( i -- ) -- )
over 0 > [
[ [ 1 - ] dip loop-in-non-loop ] [ call ] 2bi
@@ -166,3 +175,27 @@ DEFER: a''
build-tree analyze-recursive
\ (each-integer) label-is-loop?
] unit-test
+
+DEFER: a'''
+
+: b''' ( -- )
+ blah [ b''' ] [ a''' b''' ] if ; inline recursive
+
+: a''' ( -- )
+ blah [ b''' ] [ a''' ] if ; inline recursive
+
+[ t ] [
+ [ b''' ] build-tree analyze-recursive
+ \ a''' label-is-loop?
+] unit-test
+
+DEFER: b4
+
+: a4 ( a -- b ) dup [ b4 ] when ; inline recursive
+
+: b4 ( a -- b ) dup [ a4 reverse ] when ; inline recursive
+
+[ t ] [ [ b4 ] build-tree analyze-recursive \ a4 label-is-loop? ] unit-test
+[ t ] [ [ b4 ] build-tree analyze-recursive \ b4 label-is-not-loop? ] unit-test
+[ t ] [ [ a4 ] build-tree analyze-recursive \ a4 label-is-not-loop? ] unit-test
+[ t ] [ [ a4 ] build-tree analyze-recursive \ b4 label-is-loop? ] unit-test
\ No newline at end of file
diff --git a/basis/compiler/tree/recursive/recursive.factor b/basis/compiler/tree/recursive/recursive.factor
index 2e40693e69..bc6243e138 100644
--- a/basis/compiler/tree/recursive/recursive.factor
+++ b/basis/compiler/tree/recursive/recursive.factor
@@ -1,104 +1,133 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs arrays namespaces accessors sequences deques
-search-deques dlists compiler.tree compiler.tree.combinators ;
+USING: kernel assocs arrays namespaces accessors sequences deques fry
+search-deques dlists combinators.short-circuit make sets compiler.tree ;
IN: compiler.tree.recursive
-! Collect label info
-GENERIC: collect-label-info ( node -- )
+TUPLE: call-site tail? node label ;
-M: #return-recursive collect-label-info
- dup label>> (>>return) ;
+: recursive-phi-in ( #enter-recursive -- seq )
+ [ label>> calls>> [ node>> in-d>> ] map ] [ in-d>> ] bi suffix ;
-M: #call-recursive collect-label-info
- dup label>> calls>> push ;
+<PRIVATE
-M: #recursive collect-label-info
- label>> V{ } clone >>calls drop ;
+TUPLE: call-graph-node tail? label children calls ;
-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 ;
: tail-calls ( tail? node -- seq )
[
- [ #phi? ]
- [ #return? ]
- [ #return-recursive? ]
- tri or or
+ {
+ [ #phi? ]
+ [ #return? ]
+ [ #return-recursive? ]
+ } 1||
] map (tail-calls) ;
-SYMBOL: loop-heights
-SYMBOL: loop-calls
-SYMBOL: loop-stack
-SYMBOL: work-list
+SYMBOLS: children calls ;
-GENERIC: collect-loop-info* ( tail? node -- )
+GENERIC: node-call-graph ( tail? node -- )
-: non-tail-label-info ( nodes -- )
- [ f swap collect-loop-info* ] each ;
+: (build-call-graph) ( tail? nodes -- )
+ [ tail-calls ] keep
+ [ node-call-graph ] 2each ;
-: (collect-loop-info) ( tail? nodes -- )
- [ tail-calls ] keep [ collect-loop-info* ] 2each ;
-
-: remember-loop-info ( label -- )
- loop-stack get length swap loop-heights get set-at ;
-
-M: #recursive collect-loop-info*
+: build-call-graph ( nodes -- labels calls )
[
- [
- label>>
- [ swap 2array loop-stack [ swap suffix ] change ]
- [ remember-loop-info ]
- [ t >>loop? drop ]
- tri
- ]
- [ t swap child>> (collect-loop-info) ] bi
+ V{ } clone children set
+ V{ } clone calls set
+ [ t ] dip (build-call-graph)
+ children get
+ calls get
] with-scope ;
-: current-loop-nesting ( label -- alist )
- loop-stack get swap loop-heights get at tail ;
+M: #return-recursive node-call-graph
+ nip dup label>> (>>return) ;
-: disqualify-loop ( label -- )
- work-list get push-front ;
+M: #call-recursive node-call-graph
+ [ dup label>> call-site boa ] keep
+ [ drop calls get push ]
+ [ label>> calls>> push ] 2bi ;
-M: #call-recursive collect-loop-info*
- label>>
- swap [ dup disqualify-loop ] unless
- dup current-loop-nesting
- [ keys [ loop-calls get push-at ] with each ]
- [ [ nip not ] assoc-filter keys [ disqualify-loop ] each ]
+M: #recursive node-call-graph
+ [ label>> V{ } clone >>calls drop ]
+ [
+ [ label>> ] [ child>> build-call-graph ] bi
+ call-graph-node boa children get push
+ ] bi ;
+
+M: #branch node-call-graph
+ children>> [ (build-call-graph) ] with each ;
+
+M: node node-call-graph 2drop ;
+
+SYMBOLS: not-loops recursive-nesting ;
+
+: not-a-loop ( label -- ) not-loops get conjoin ;
+
+: not-a-loop? ( label -- ? ) not-loops get key? ;
+
+: non-tail-calls ( call-graph-node -- seq )
+ calls>> [ tail?>> not ] filter ;
+
+: visit-back-edges ( call-graph -- )
+ [
+ [ non-tail-calls [ label>> not-a-loop ] each ]
+ [ children>> visit-back-edges ]
+ bi
+ ] each ;
+
+SYMBOL: changed?
+
+: check-cross-frame-call ( call-site -- )
+ label>> dup not-a-loop? [ drop ] [
+ recursive-nesting get <reversed> [
+ 2dup label>> eq? [ 2drop f ] [
+ [ label>> not-a-loop? ] [ tail?>> not ] bi or
+ [ not-a-loop changed? on ] [ drop ] if t
+ ] if
+ ] with all? drop
+ ] if ;
+
+: detect-cross-frame-calls ( call-graph -- )
+ ! Suppose we have a nesting of recursives A --> B --> C
+ ! B tail-calls A, and C non-tail-calls B. Then A cannot be
+ ! a loop, it needs its own procedure, since the call from
+ ! C to A crosses a call-frame boundary.
+ [
+ [ recursive-nesting get push ]
+ [ calls>> [ check-cross-frame-call ] each ]
+ [ children>> detect-cross-frame-calls ] tri
+ recursive-nesting get pop*
+ ] each ;
+
+: while-changing ( quot: ( -- ) -- )
+ changed? off
+ [ call ] [ changed? get [ while-changing ] [ drop ] if ] bi ;
+ inline recursive
+
+: detect-loops ( call-graph -- )
+ H{ } clone not-loops set
+ V{ } clone recursive-nesting set
+ [ visit-back-edges ]
+ [ '[ _ detect-cross-frame-calls ] while-changing ]
bi ;
-M: #if collect-loop-info*
- children>> [ (collect-loop-info) ] with each ;
+: mark-loops ( call-graph -- )
+ [
+ [ label>> dup not-a-loop? [ t >>loop? ] unless drop ]
+ [ children>> mark-loops ]
+ bi
+ ] each ;
-M: #dispatch collect-loop-info*
- children>> [ (collect-loop-info) ] with each ;
+PRIVATE>
-M: node collect-loop-info* 2drop ;
-
-: collect-loop-info ( node -- )
- { } loop-stack set
- H{ } clone loop-calls set
- H{ } clone loop-heights set
- <hashed-dlist> work-list set
- t swap (collect-loop-info) ;
-
-: disqualify-loops ( -- )
- work-list get [
- dup loop?>> [
- [ f >>loop? drop ]
- [ loop-calls get at [ disqualify-loop ] each ]
- bi
- ] [ drop ] if
- ] slurp-deque ;
+SYMBOL: call-graph
: analyze-recursive ( nodes -- nodes )
- dup [ collect-label-info ] each-node
- dup collect-loop-info disqualify-loops ;
+ dup build-call-graph drop
+ [ call-graph set ]
+ [ detect-loops ]
+ [ mark-loops ]
+ tri ;
diff --git a/basis/compiler/tree/tree.factor b/basis/compiler/tree/tree.factor
index c73f2211f0..7fa096b623 100644
--- a/basis/compiler/tree/tree.factor
+++ b/basis/compiler/tree/tree.factor
@@ -165,9 +165,6 @@ M: #shuffle inputs/outputs mapping>> unzip swap ;
M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
-: recursive-phi-in ( #enter-recursive -- seq )
- [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
-
: ends-with-terminate? ( nodes -- ? )
[ f ] [ last #terminate? ] if-empty ;
diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor
index 2b99513fc1..b2de0cc6e4 100644
--- a/basis/cpu/x86/assembler/assembler.factor
+++ b/basis/cpu/x86/assembler/assembler.factor
@@ -606,6 +606,8 @@ ALIAS: PINSRQ PINSRD
: PSHUFLW ( dest src imm -- ) HEX: 70 HEX: f2 3-operand-rm-sse ;
: PSHUFHW ( dest src imm -- ) HEX: 70 HEX: f3 3-operand-rm-sse ;
+<PRIVATE
+
: (PSRLW-imm) ( dest imm -- ) BIN: 010 HEX: 71 HEX: 66 2-operand-sse-shift ;
: (PSRAW-imm) ( dest imm -- ) BIN: 100 HEX: 71 HEX: 66 2-operand-sse-shift ;
: (PSLLW-imm) ( dest imm -- ) BIN: 110 HEX: 71 HEX: 66 2-operand-sse-shift ;
@@ -624,6 +626,8 @@ ALIAS: PINSRQ PINSRD
: (PSLLD-reg) ( dest src -- ) HEX: f2 HEX: 66 2-operand-rm-sse ;
: (PSLLQ-reg) ( dest src -- ) HEX: f3 HEX: 66 2-operand-rm-sse ;
+PRIVATE>
+
: PSRLW ( dest src -- ) dup integer? [ (PSRLW-imm) ] [ (PSRLW-reg) ] if ;
: PSRAW ( dest src -- ) dup integer? [ (PSRAW-imm) ] [ (PSRAW-reg) ] if ;
: PSLLW ( dest src -- ) dup integer? [ (PSLLW-imm) ] [ (PSLLW-reg) ] if ;
diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor
index da6a589031..4a6dd9b5be 100644
--- a/basis/editors/editors.factor
+++ b/basis/editors/editors.factor
@@ -47,43 +47,12 @@ M: cannot-find-source error.
: edit-vocab ( name -- )
>vocab-link edit ;
-GENERIC: error-file ( error -- file )
-
-GENERIC: error-line ( error -- line )
-
-M: lexer-error error-file
- error>> error-file ;
-
-M: lexer-error error-line
- [ error>> error-line ] [ line>> ] bi or ;
-
-M: source-file-error error-file
- [ error>> error-file ] [ file>> ] bi or ;
-
-M: source-file-error error-line
- error>> error-line ;
-
-M: condition error-file
- error>> error-file ;
-
-M: condition error-line
- error>> error-line ;
-
-M: object error-file
- drop f ;
-
-M: object error-line
- drop f ;
-
-: (:edit) ( error -- )
+: edit-error ( error -- )
[ error-file ] [ error-line ] bi
2dup and [ edit-location ] [ 2drop ] if ;
: :edit ( -- )
- error get (:edit) ;
-
-: edit-error ( error -- )
- [ file>> ] [ line#>> ] bi 2dup and [ edit-location ] [ 2drop ] if ;
+ error get edit-error ;
: edit-each ( seq -- )
[
diff --git a/basis/furnace/sessions/sessions-tests.factor b/basis/furnace/sessions/sessions-tests.factor
index 99855c76fa..392d43e89b 100644
--- a/basis/furnace/sessions/sessions-tests.factor
+++ b/basis/furnace/sessions/sessions-tests.factor
@@ -53,7 +53,7 @@ M: foo call-responder*
"auth-test.db" temp-file <sqlite-db> [
- <request> init-request
+ <request> "GET" >>method init-request
session ensure-table
"127.0.0.1" 1234 <inet4> remote-address set
diff --git a/basis/http/server/rewrite/rewrite-docs.factor b/basis/http/server/rewrite/rewrite-docs.factor
index 478adbab69..9ded10bded 100644
--- a/basis/http/server/rewrite/rewrite-docs.factor
+++ b/basis/http/server/rewrite/rewrite-docs.factor
@@ -39,7 +39,7 @@ HELP: <vhost-rewrite>
" <show-blogs-action> >>default"
" <display-blog-action> >>child"
" \"blog_id\" >>param"
- " \"blogs.vegan.net >>suffix"
+ " \"blogs.vegan.net\" >>suffix"
}
} ;
diff --git a/basis/stuff.factor b/basis/stuff.factor
deleted file mode 100644
index 2e5fa2dfae..0000000000
--- a/basis/stuff.factor
+++ /dev/null
@@ -1,20 +0,0 @@
-
-: spill-integer-base ( -- n )
- stack-frame get spill-counts>> double-float-regs swap at
- double-float-regs reg-size * ;
-
-: spill-integer@ ( n -- offset )
- cells spill-integer-base + param@ ;
-
-: spill-float@ ( n -- offset )
- double-float-regs reg-size * param@ ;
-
-: (stack-frame-size) ( stack-frame -- n )
- [
- {
- [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
- [ gc-roots>> cells ]
- [ params>> ]
- [ return>> ]
- } cleave
- ] sum-outputs ;
\ No newline at end of file
diff --git a/basis/tools/errors/errors.factor b/basis/tools/errors/errors.factor
index b53d4ef7a2..963ea7592c 100644
--- a/basis/tools/errors/errors.factor
+++ b/basis/tools/errors/errors.factor
@@ -14,14 +14,16 @@ M: source-file-error error-help error>> error-help ;
CONSTANT: +listener-input+ "<Listener input>"
-M: source-file-error summary
+: error-location ( error -- string )
[
- [ file>> [ % ": " % ] [ +listener-input+ % ] if* ]
- [ line#>> [ # ] when* ] bi
+ [ file>> [ % ] [ +listener-input+ % ] if* ]
+ [ line#>> [ ": " % # ] when* ] bi
] "" make ;
+M: source-file-error summary error>> summary ;
+
M: source-file-error error.
- [ summary print nl ]
+ [ error-location print nl ]
[ asset>> [ "Asset: " write short. nl ] when* ]
[ error>> error. ]
tri ;
diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor
index 7b07311ded..b6d56b18c0 100644
--- a/basis/tools/test/test.factor
+++ b/basis/tools/test/test.factor
@@ -130,7 +130,7 @@ TEST: must-fail
M: test-failure error. ( error -- )
{
- [ summary print nl ]
+ [ error-location print nl ]
[ asset>> [ experiment. nl ] when* ]
[ error>> error. ]
[ traceback-button. ]
diff --git a/basis/ui/gadgets/tables/tables-tests.factor b/basis/ui/gadgets/tables/tables-tests.factor
index 3191753324..b92f72a2dd 100644
--- a/basis/ui/gadgets/tables/tables-tests.factor
+++ b/basis/ui/gadgets/tables/tables-tests.factor
@@ -1,6 +1,6 @@
IN: ui.gadgets.tables.tests
USING: ui.gadgets.tables ui.gadgets.scrollers ui.gadgets.debug accessors
-models namespaces tools.test kernel combinators ;
+models namespaces tools.test kernel combinators prettyprint arrays ;
SINGLETON: test-renderer
@@ -44,4 +44,19 @@ M: test-renderer column-titles drop { "First" "Last" } ;
[ selected-row drop ]
} cleave
] with-grafted-gadget
-] unit-test
\ No newline at end of file
+] unit-test
+
+SINGLETON: silly-renderer
+
+M: silly-renderer row-columns drop unparse 1array ;
+
+M: silly-renderer column-titles drop { "Foo" } ;
+
+: test-table-2 ( -- table )
+ { 1 2 f } <model> silly-renderer <table> ;
+
+[ f f ] [
+ test-table dup [
+ selected-row
+ ] with-grafted-gadget
+] unit-test
diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor
index 081e5267b9..f548c10606 100644
--- a/basis/ui/gadgets/tables/tables.factor
+++ b/basis/ui/gadgets/tables/tables.factor
@@ -1,13 +1,12 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays colors colors.constants fry kernel math
-math.functions math.ranges math.rectangles math.order math.vectors
-models.illusion namespaces opengl sequences ui.gadgets
+USING: accessors assocs hashtables arrays colors colors.constants fry
+kernel math math.functions math.ranges math.rectangles math.order
+math.vectors namespaces opengl sequences ui.gadgets
ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.worlds
ui.gestures ui.render ui.pens.solid ui.text ui.commands ui.images
-ui.gadgets.menus ui.gadgets.line-support models
-combinators combinators.short-circuit
-fonts locals strings sequences.extras sets ;
+ui.gadgets.menus ui.gadgets.line-support models combinators
+combinators.short-circuit fonts locals strings sets sorting ;
IN: ui.gadgets.tables
! Row rendererer protocol
@@ -54,15 +53,23 @@ M: table output-model selection>> ;
<PRIVATE
-: push-selected-index ( table n -- table ) swap
- [ insert-sorted prune >array ] change-selected-indices ;
-: multiple>single ( values -- value/f ? ) [ f f ] [ first t ] if-empty ;
-: multiple>single* ( values -- value/f ) multiple>single drop ;
-: selected-index ( table -- n ) selected-indices>> multiple>single* ;
-: set-selected-index ( table n -- table ) 1array >>selected-indices ;
+: add-selected-index ( table n -- table )
+ over selected-indices>> conjoin ;
+
+: multiple>single ( values -- value/f ? )
+ dup assoc-empty? [ drop f f ] [ values first t ] if ;
+
+: selected-index ( table -- n )
+ selected-indices>> multiple>single drop ;
+
+: set-selected-index ( table n -- table )
+ dup associate >>selected-indices ;
+
PRIVATE>
-: selected ( table -- index/indices ) dup multiple-selection?>>
- [ selected-indices>> ] [ selected-index ] if ;
+
+: selected ( table -- index/indices )
+ [ selected-indices>> ] [ multiple-selection?>> ] bi
+ [ multiple>single drop ] unless ;
: new-table ( rows renderer class -- table )
new-line-gadget
@@ -72,7 +79,8 @@ PRIVATE>
focus-border-color >>focus-border-color
transparent >>column-line-color
f <model> >>selection-index
- f <model> >>selection ;
+ f <model> >>selection
+ H{ } clone >>selected-indices ;
: <table> ( rows renderer -- table ) table new-table ;
@@ -154,9 +162,9 @@ M: table layout*
: draw-selected-rows ( table -- )
{
- { [ dup selected-indices>> empty? ] [ drop ] }
+ { [ dup selected-indices>> assoc-empty? ] [ drop ] }
[
- [ selected-indices>> ] [ selection-color>> gl-color ] [ ] tri
+ [ selected-indices>> keys ] [ selection-color>> gl-color ] [ ] tri
[ swap row-bounds gl-fill-rect ] curry each
]
} cond ;
@@ -213,7 +221,8 @@ M: table layout*
:: row-font ( row ind table -- font )
table font>> clone
row table renderer>> row-color [ >>foreground ] when*
- ind table selected-indices>> index [ table selection-color>> >>background ] when ;
+ ind table selected-indices>> key?
+ [ table selection-color>> >>background ] when ;
: draw-columns ( columns widths alignment font gap -- )
'[ [ _ ] 3dip _ draw-column ] 3each ;
@@ -257,24 +266,34 @@ M: table pref-dim*
PRIVATE>
-: (selected-rows) ( table -- {row} )
+: (selected-rows) ( table -- assoc )
[ selected-indices>> ] keep
- [ nth-row [ 1array ] [ drop { } ] if ] curry map concat ;
+ '[ _ nth-row drop ] assoc-map ;
+
+: selected-rows ( table -- assoc )
+ [ selected-indices>> ] [ ] [ renderer>> ] tri
+ '[ _ nth-row drop _ row-value ] assoc-map ;
-: selected-rows ( table -- {value} )
- [ (selected-rows) ] [ renderer>> ] bi [ row-value ] curry map ;
: (selected-row) ( table -- value/f ? ) (selected-rows) multiple>single ;
+
: selected-row ( table -- value/f ? ) selected-rows multiple>single ;
<PRIVATE
: set-table-model ( model value multiple? -- )
- [ multiple>single* ] unless swap set-model ;
+ [ multiple>single drop ] unless swap set-model ;
: update-selected ( table -- )
- [ [ selection>> ] [ selected-rows ] [ multiple-selection?>> ] tri set-table-model ]
[
- [ selection-index>> ] [ selected-indices>> ] [ multiple-selection?>> ] tri
+ [ selection>> ]
+ [ selected-rows ]
+ [ multiple-selection?>> ] tri
+ set-table-model
+ ]
+ [
+ [ selection-index>> ]
+ [ selected-indices>> ]
+ [ multiple-selection?>> ] tri
set-table-model
] bi ;
@@ -288,29 +307,30 @@ PRIVATE>
f >>mouse-index [ hide-status ] [ relayout-1 ] bi ;
: find-row-index ( value table -- n/f )
- [ model>> value>> ] [ renderer>> '[ _ row-value ] map index ] bi ;
+ [ model>> value>> ] [ renderer>> ] bi
+ '[ _ row-value eq? ] with find drop ;
-: initial-selected-indices ( table -- {n}/f )
+: (update-selected-indices) ( table -- set )
+ [ selection>> value>> dup [ array? not ] [ ] bi and [ 1array ] when ] keep
+ '[ _ find-row-index ] map sift unique f assoc-like ;
+
+: initial-selected-indices ( table -- set )
{
[ model>> value>> empty? not ]
[ selection-required?>> ]
- [ drop { 0 } ]
+ [ drop { 0 } unique ]
} 1&& ;
-: (update-selected-indices) ( table -- {n}/f )
- [ selection>> value>> dup array? [ 1array ] unless ] keep
- [ find-row-index ] curry map [ ] filter [ f ] when-empty ;
-
-: update-selected-indices ( table -- {n}/f )
+: update-selected-indices ( table -- set )
{
[ (update-selected-indices) ]
[ initial-selected-indices ]
} 1|| ;
M: table model-changed
- nip dup update-selected-indices [ { } ] unless* {
+ nip dup update-selected-indices {
[ >>selected-indices f >>mouse-index drop ]
- [ [ f ] [ first ] if-empty show-row-summary ]
+ [ multiple>single drop show-row-summary ]
[ drop update-selected ]
[ drop relayout ]
} 2cleave ;
@@ -323,7 +343,7 @@ M: table model-changed
: add-selected-row ( table n -- )
[ scroll-to-row ]
- [ push-selected-index relayout-1 ] 2bi ;
+ [ add-selected-index relayout-1 ] 2bi ;
: (select-row) ( table n -- )
[ scroll-to-row ]
@@ -341,12 +361,17 @@ M: table model-changed
dup takes-focus?>> [ dup request-focus ] when swap
'[ swap [ >>mouse-index ] _ bi ] [ drop ] if-mouse-row ; inline
-: table-button-down ( table -- ) [ (select-row) ] swap (table-button-down) ;
-: continued-button-down ( table -- ) dup multiple-selection?>>
+: table-button-down ( table -- )
+ [ (select-row) ] swap (table-button-down) ;
+
+: continued-button-down ( table -- )
+ dup multiple-selection?>>
[ [ add-selected-row ] swap (table-button-down) ] [ table-button-down ] if ;
-: thru-button-down ( table -- ) dup multiple-selection?>> [
+
+: thru-button-down ( table -- )
+ dup multiple-selection?>> [
[ 2dup over selected-index (a,b) swap
- [ swap push-selected-index drop ] curry each add-selected-row ]
+ [ swap add-selected-index drop ] curry each add-selected-row ]
swap (table-button-down)
] [ table-button-down ] if ;
diff --git a/basis/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor
index 024442a264..a4fda6600e 100755
--- a/basis/ui/tools/debugger/debugger.factor
+++ b/basis/ui/tools/debugger/debugger.factor
@@ -79,7 +79,7 @@ debugger "gestures" f {
: com-help ( debugger -- ) error>> error-help-window ;
-: com-edit ( debugger -- ) error>> (:edit) ;
+: com-edit ( debugger -- ) error>> edit-error ;
\ com-edit H{ { +listener+ t } } define-command
diff --git a/basis/ui/tools/profiler/profiler.factor b/basis/ui/tools/profiler/profiler.factor
index 8be357b409..c3fbdb88cd 100644
--- a/basis/ui/tools/profiler/profiler.factor
+++ b/basis/ui/tools/profiler/profiler.factor
@@ -147,7 +147,7 @@ M: method-renderer column-titles drop { "" "Method" "Count" } ;
horizontal <track>
{ 3 3 } >>gap
profiler vocabs>> vocab-renderer <profiler-table>
- profiler vocab>> >>selected-value
+ profiler vocab>> >>selection
10 >>min-rows
10 >>max-rows
"Vocabularies" <labeled-gadget>
@@ -164,11 +164,11 @@ M: method-renderer column-titles drop { "" "Method" "Count" } ;
horizontal <track>
{ 3 3 } >>gap
profiler <generic-model> word-renderer <profiler-table>
- profiler generic>> >>selected-value
+ profiler generic>> >>selection
"Generic words" <labeled-gadget>
1/2 track-add
profiler <class-model> word-renderer <profiler-table>
- profiler class>> >>selected-value
+ profiler class>> >>selection
"Classes" <labeled-gadget>
1/2 track-add
1/2 track-add
diff --git a/basis/vocabs/hierarchy/hierarchy.factor b/basis/vocabs/hierarchy/hierarchy.factor
index aa3e619660..b840b5ab9d 100644
--- a/basis/vocabs/hierarchy/hierarchy.factor
+++ b/basis/vocabs/hierarchy/hierarchy.factor
@@ -107,7 +107,8 @@ MEMO: all-vocabs-recursive ( -- assoc )
PRIVATE>
: (load) ( prefix -- failures )
- child-vocabs-recursive no-roots no-prefixes
+ [ child-vocabs-recursive no-roots no-prefixes ]
+ [ dup find-vocab-root [ >vocab-link prefix ] [ drop ] if ] bi
filter-unportable
require-all ;
diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor
index 99e6f05c6c..036c7d9721 100644
--- a/core/lexer/lexer.factor
+++ b/core/lexer/lexer.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors namespaces math words strings
-io vectors arrays math.parser combinators continuations ;
+io vectors arrays math.parser combinators continuations
+source-files.errors ;
IN: lexer
TUPLE: lexer text line line-text line-length column ;
@@ -24,11 +25,8 @@ TUPLE: lexer text line line-text line-length column ;
ERROR: unexpected want got ;
-PREDICATE: unexpected-tab < unexpected
- got>> CHAR: \t = ;
-
: forbid-tab ( c -- c )
- [ CHAR: \t eq? [ "[space]" "[tab]" unexpected ] when ] keep ;
+ [ CHAR: \t eq? [ "[space]" "[tab]" unexpected ] when ] keep ; inline
: skip ( i seq ? -- n )
over length
@@ -96,6 +94,9 @@ PREDICATE: unexpected-eof < unexpected
TUPLE: lexer-error line column line-text error ;
+M: lexer-error error-file error>> error-file ;
+M: lexer-error error-line [ error>> error-line ] [ line>> ] bi or ;
+
: <lexer-error> ( msg -- error )
\ lexer-error new
lexer get
diff --git a/core/source-files/errors/errors.factor b/core/source-files/errors/errors.factor
index 86a8354071..93078c162b 100644
--- a/core/source-files/errors/errors.factor
+++ b/core/source-files/errors/errors.factor
@@ -1,11 +1,23 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel math.order sorting sequences definitions
-namespaces arrays splitting io math.parser math init ;
+namespaces arrays splitting io math.parser math init continuations ;
IN: source-files.errors
+GENERIC: error-file ( error -- file )
+GENERIC: error-line ( error -- line )
+
+M: object error-file drop f ;
+M: object error-line drop f ;
+
+M: condition error-file error>> error-file ;
+M: condition error-line error>> error-line ;
+
TUPLE: source-file-error error asset file line# ;
+M: source-file-error error-file [ error>> error-file ] [ file>> ] bi or ;
+M: source-file-error error-line [ error>> error-line ] [ line#>> ] bi or ;
+
: sort-errors ( errors -- alist )
[ [ line#>> ] sort-with ] { } assoc-map-as sort-keys ;
diff --git a/extra/compiler/cfg/graphviz/graphviz.factor b/extra/compiler/cfg/graphviz/graphviz.factor
deleted file mode 100644
index 0aade1301f..0000000000
--- a/extra/compiler/cfg/graphviz/graphviz.factor
+++ /dev/null
@@ -1,44 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license
-USING: accessors compiler.cfg.rpo compiler.cfg.dominance
-compiler.cfg.dominance.private compiler.cfg.predecessors images.viewer
-io io.encodings.ascii io.files io.files.unique io.launcher kernel
-math.parser sequences assocs arrays make namespaces ;
-IN: compiler.cfg.graphviz
-
-: render-graph ( edges -- )
- "cfg" "dot" make-unique-file
- [
- ascii [
- "digraph CFG {" print
- [ [ number>> number>string ] bi@ " -> " glue write ";" print ] assoc-each
- "}" print
- ] with-file-writer
- ]
- [ { "dot" "-Tpng" "-O" } swap suffix try-process ]
- [ ".png" append { "open" } swap suffix try-process ]
- tri ;
-
-: cfg-edges ( cfg -- edges )
- [
- [
- dup successors>> [
- 2array ,
- ] with each
- ] each-basic-block
- ] { } make ;
-
-: render-cfg ( cfg -- ) cfg-edges render-graph ;
-
-: dom-edges ( cfg -- edges )
- [
- compute-predecessors
- compute-dominance
- dom-childrens get [
- [
- 2array ,
- ] with each
- ] assoc-each
- ] { } make ;
-
-: render-dom ( cfg -- ) dom-edges render-graph ;
\ No newline at end of file
diff --git a/extra/compiler/graphviz/graphviz.factor b/extra/compiler/graphviz/graphviz.factor
new file mode 100644
index 0000000000..353a134375
--- /dev/null
+++ b/extra/compiler/graphviz/graphviz.factor
@@ -0,0 +1,139 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license
+USING: accessors compiler.tree.builder compiler.cfg compiler.cfg.rpo
+compiler.cfg.dominance compiler.cfg.dominance.private
+compiler.cfg.predecessors compiler.cfg.debugger compiler.cfg.optimizer
+compiler.cfg.utilities compiler.tree.recursive images.viewer
+images.png io io.encodings.ascii io.files io.files.unique io.launcher
+kernel math.parser sequences assocs arrays make math namespaces
+quotations combinators locals words ;
+IN: compiler.graphviz
+
+: quotes ( str -- str' ) "\"" "\"" surround ;
+
+: graph, ( quot title -- )
+ [
+ quotes "digraph " " {" surround ,
+ call
+ "}" ,
+ ] { } make , ; inline
+
+: render-graph ( quot -- )
+ { } make
+ "cfg" ".dot" make-unique-file
+ dup "Wrote " prepend print
+ [ [ concat ] dip ascii set-file-lines ]
+ [ { "dot" "-Tpng" "-O" } swap suffix try-process ]
+ [ ".png" append image. ]
+ tri ; inline
+
+: attrs>string ( seq -- str )
+ [ "" ] [ "," join "[" "]" surround ] if-empty ;
+
+: edge,* ( from to attrs -- )
+ [
+ [ quotes % " -> " % ] [ quotes % " " % ] [ attrs>string % ] tri*
+ ";" %
+ ] "" make , ;
+
+: edge, ( from to -- )
+ { } edge,* ;
+
+: bb-edge, ( from to -- )
+ [ number>> number>string ] bi@ edge, ;
+
+: node-style, ( str attrs -- )
+ [ [ quotes % " " % ] [ attrs>string % ";" % ] bi* ] "" make , ;
+
+: cfg-title ( cfg/mr -- string )
+ [
+ "=== word: " %
+ [ word>> name>> % ", label: " % ]
+ [ label>> name>> % ]
+ bi
+ ] "" make ;
+
+: cfg-vertex, ( bb -- )
+ [ number>> number>string ]
+ [ kill-block? { "color=grey" "style=filled" } { } ? ]
+ bi node-style, ;
+
+: cfgs ( cfgs -- )
+ [
+ [
+ [ [ cfg-vertex, ] each-basic-block ]
+ [
+ [
+ dup successors>> [
+ bb-edge,
+ ] with each
+ ] each-basic-block
+ ] bi
+ ] over cfg-title graph,
+ ] each ;
+
+: optimized-cfg ( quot -- cfgs )
+ {
+ { [ dup cfg? ] [ 1array ] }
+ { [ dup quotation? ] [ test-cfg [ optimize-cfg ] map ] }
+ { [ dup word? ] [ test-cfg [ optimize-cfg ] map ] }
+ [ ]
+ } cond ;
+
+: render-cfg ( cfg -- )
+ optimized-cfg [ cfgs ] render-graph ;
+
+: dom-trees ( cfgs -- )
+ [
+ [
+ compute-predecessors
+ compute-dominance
+ dom-childrens get [
+ [
+ bb-edge,
+ ] with each
+ ] assoc-each
+ ] over cfg-title graph,
+ ] each ;
+
+: render-dom ( cfg -- )
+ optimized-cfg [ dom-trees ] render-graph ;
+
+SYMBOL: word-counts
+SYMBOL: vertex-names
+
+: vertex-name ( call-graph-node -- string )
+ label>> vertex-names get [
+ word>> name>>
+ dup word-counts get [ 0 or 1 + dup ] change-at number>string " #" glue
+ ] cache ;
+
+: vertex-attrs ( obj -- string )
+ tail?>> { "style=bold,label=\"tail\"" } { } ? ;
+
+: call-graph-edge, ( from to attrs -- )
+ [ [ vertex-name ] [ vertex-attrs ] bi ] dip append edge,* ;
+
+: (call-graph-back-edges) ( string calls -- )
+ [ { "color=red" } call-graph-edge, ] with each ;
+
+: (call-graph-edges) ( string children -- )
+ [
+ {
+ [ { } call-graph-edge, ]
+ [ [ vertex-name ] [ label>> loop?>> { "shape=box" } { } ? ] bi node-style, ]
+ [ [ vertex-name ] [ calls>> ] bi (call-graph-back-edges) ]
+ [ [ vertex-name ] [ children>> ] bi (call-graph-edges) ]
+ } cleave
+ ] with each ;
+
+: call-graph-edges ( call-graph-node -- )
+ H{ } clone word-counts set
+ H{ } clone vertex-names set
+ [ "ROOT" ] dip (call-graph-edges) ;
+
+: render-call-graph ( tree -- )
+ dup quotation? [ build-tree ] when
+ analyze-recursive drop
+ [ [ call-graph get call-graph-edges ] "Call graph" graph, ]
+ render-graph ;
\ No newline at end of file
diff --git a/extra/modules/rpc-server/rpc-server.factor b/extra/modules/rpc-server/rpc-server.factor
index 073804fa8c..d82f13f715 100644
--- a/extra/modules/rpc-server/rpc-server.factor
+++ b/extra/modules/rpc-server/rpc-server.factor
@@ -20,12 +20,12 @@ SYMBOL: serving-vocabs serving-vocabs [ V{ } clone ] initialize
PRIVATE>
SYNTAX: service current-vocab name>> serving-vocabs get-global adjoin ;
-[ [ binary <threaded-server>
+: start-rpc-server ( -- )
+ binary <threaded-server>
"rpcs" >>name 9012 >>insecure
[ deserialize {
{ "getter" [ getter ] }
{ "doer" [ doer ] }
{ "loader" [ deserialize vocab serialize flush ] }
} case ] >>handler
- start-server ] in-thread
-] "modules.rpc-server" add-init-hook
\ No newline at end of file
+ start-server ;