diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 81bcff03c1..a8bb60cbf3 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -34,14 +34,14 @@ C: timestamp : ( year month day -- timestamp ) 0 0 0 gmt-offset-duration ; -ERROR: not-a-month n ; +ERROR: not-a-month ; M: not-a-month summary drop "Months are indexed starting at 1" ; @@ -186,9 +186,6 @@ GENERIC: +second ( timestamp x -- timestamp ) { [ day>> 29 = ] [ month>> 2 = ] [ leap-year? not ] } 1&& [ 3 >>month 1 >>day ] when ; -: unless-zero ( n quot -- ) - [ dup zero? [ drop ] ] dip if ; inline - M: integer +year ( timestamp n -- timestamp ) [ [ + ] curry change-year adjust-leap-year ] unless-zero ; @@ -196,7 +193,7 @@ M: real +year ( timestamp n -- timestamp ) [ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ; : months/years ( n -- months years ) - 12 /rem dup zero? [ drop 1 - 12 ] when swap ; inline + 12 /rem [ 1 - 12 ] when-zero swap ; inline M: integer +month ( timestamp n -- timestamp ) [ over month>> + months/years [ >>month ] dip +year ] unless-zero ; diff --git a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor index 62043fb413..275a4585b0 100644 --- a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor +++ b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor @@ -5,7 +5,7 @@ namespaces functors compiler.cfg.rpo compiler.cfg.utilities compiler.cfg.predecessors compiler.cfg ; IN: compiler.cfg.dataflow-analysis -GENERIC: join-sets ( sets dfa -- set ) +GENERIC: join-sets ( sets bb dfa -- set ) GENERIC: transfer-set ( in-set bb dfa -- out-set ) GENERIC: block-order ( cfg dfa -- bbs ) GENERIC: successors ( bb dfa -- seq ) @@ -23,7 +23,7 @@ GENERIC# compute-in-set 2 ( bb out-sets dfa -- set ) M: kill-block compute-in-set 3drop f ; M:: basic-block compute-in-set ( bb out-sets dfa -- set ) - bb dfa predecessors [ out-sets at ] map dfa join-sets ; + bb dfa predecessors [ out-sets at ] map bb dfa join-sets ; :: update-in-set ( bb in-sets out-sets dfa -- ? ) bb out-sets dfa compute-in-set @@ -56,7 +56,7 @@ M:: basic-block compute-out-set ( bb in-sets dfa -- set ) in-sets out-sets ; inline -M: dataflow-analysis join-sets drop assoc-refine ; +M: dataflow-analysis join-sets 2drop assoc-refine ; FUNCTOR: define-analysis ( name -- ) diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor index 6c67769a45..a10b48cc0c 100644 --- a/basis/compiler/cfg/liveness/liveness.factor +++ b/basis/compiler/cfg/liveness/liveness.factor @@ -28,4 +28,4 @@ M: live-analysis transfer-set drop instructions>> transfer-liveness ; M: live-analysis join-sets - drop assoc-combine ; \ No newline at end of file + 2drop assoc-combine ; diff --git a/basis/compiler/cfg/stacks/global/global.factor b/basis/compiler/cfg/stacks/global/global.factor index c0ca385d90..30a999064a 100644 --- a/basis/compiler/cfg/stacks/global/global.factor +++ b/basis/compiler/cfg/stacks/global/global.factor @@ -21,7 +21,7 @@ BACKWARD-ANALYSIS: live M: live-analysis transfer-set drop transfer-peeked-locs ; -M: live-analysis join-sets drop assoc-combine ; +M: live-analysis join-sets 2drop assoc-combine ; ! A stack location is available at a location if all paths from ! the entry block to the location load the location into a @@ -56,4 +56,4 @@ M: dead-analysis transfer-set [ compute-dead-sets ] [ compute-avail-sets ] [ ] - } cleave ; \ No newline at end of file + } cleave ; diff --git a/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor index 97211eb8e8..ce0e98de5f 100644 --- a/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor +++ b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor @@ -65,7 +65,7 @@ M: uninitialized-analysis transfer-set ( pair bb analysis -- pair' ) drop [ prepare ] dip visit-block finish ; M: uninitialized-analysis join-sets ( sets analysis -- pair ) - drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ; + 2drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ; : uninitialized-locs ( bb -- locs ) uninitialized-in dup [ @@ -73,4 +73,4 @@ M: uninitialized-analysis join-sets ( sets analysis -- pair ) [ [ ] (uninitialized-locs) ] [ [ ] (uninitialized-locs) ] bi* append - ] when ; \ No newline at end of file + ] when ; diff --git a/basis/compiler/cfg/write-barrier/authors.txt b/basis/compiler/cfg/write-barrier/authors.txt new file mode 100644 index 0000000000..a44f8d7f8d --- /dev/null +++ b/basis/compiler/cfg/write-barrier/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Daniel Ehrenberg diff --git a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor index c09f404d4c..dd010f0dbc 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor @@ -1,7 +1,9 @@ +! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. USING: compiler.cfg.write-barrier compiler.cfg.instructions compiler.cfg.registers compiler.cfg.debugger cpu.architecture arrays tools.test vectors compiler.cfg kernel accessors -compiler.cfg.utilities ; +compiler.cfg.utilities namespaces sequences ; IN: compiler.cfg.write-barrier.tests : test-write-barrier ( insns -- insns ) @@ -70,3 +72,71 @@ IN: compiler.cfg.write-barrier.tests T{ ##write-barrier f 19 30 3 } } test-write-barrier ] unit-test + +V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} 1 test-bb +V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} 2 test-bb +1 get 2 get 1vector >>successors drop +cfg new 1 get >>entry 0 set + +[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test +[ V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} ] [ 1 get instructions>> ] unit-test +[ V{ + T{ ##set-slot-imm f 2 1 3 4 } +} ] [ 2 get instructions>> ] unit-test + +V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} 1 test-bb +V{ + T{ ##allot } + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} 2 test-bb +1 get 2 get 1vector >>successors drop +cfg new 1 get >>entry 0 set + +[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test +[ V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} ] [ 1 get instructions>> ] unit-test +[ V{ + T{ ##allot } + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} ] [ 2 get instructions>> ] unit-test + +V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} 1 test-bb +V{ + T{ ##allot } +} 2 test-bb +1 get 2 get 1vector >>successors drop +V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} 3 test-bb +2 get 3 get 1vector >>successors drop +cfg new 1 get >>entry 0 set +[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test +[ V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} ] [ 1 get instructions>> ] unit-test +[ V{ T{ ##allot } } ] [ 2 get instructions>> ] unit-test +[ V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} ] [ 3 get instructions>> ] unit-test diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor index 2f32a4ca81..2375075df5 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier.factor @@ -1,7 +1,8 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors namespaces assocs sets sequences -compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ; +compiler.cfg compiler.cfg.instructions compiler.cfg.rpo +compiler.cfg.dataflow-analysis fry combinators.short-circuit ; IN: compiler.cfg.write-barrier ! Eliminate redundant write barrier hits. @@ -30,10 +31,27 @@ M: ##set-slot-imm eliminate-write-barrier M: insn eliminate-write-barrier drop t ; +FORWARD-ANALYSIS: safe + +: has-allocation? ( bb -- ? ) + instructions>> [ { [ ##allocation? ] [ ##call? ] } 1|| ] any? ; + +M: safe-analysis transfer-set + drop [ H{ } assoc-clone-like ] dip + instructions>> over '[ + dup ##write-barrier? [ + src>> _ conjoin + ] [ drop ] if + ] each ; + +M: safe-analysis join-sets + drop has-allocation? [ drop H{ } clone ] [ assoc-refine ] if ; + : write-barriers-step ( bb -- ) - H{ } clone safe set + dup safe-in H{ } assoc-clone-like safe set H{ } clone mutated set instructions>> [ eliminate-write-barrier ] filter-here ; : eliminate-write-barriers ( cfg -- cfg' ) + dup compute-safe-sets dup [ write-barriers-step ] each-basic-block ; diff --git a/basis/ui/tools/error-list/error-list.factor b/basis/ui/tools/error-list/error-list.factor index 1193ca237c..a1da59fe39 100644 --- a/basis/ui/tools/error-list/error-list.factor +++ b/basis/ui/tools/error-list/error-list.factor @@ -165,8 +165,8 @@ error-display "toolbar" f { { 5 5 } >>gap error-list f track-add error-list source-file-table>> "Source files" 1/4 track-add - error-list error-table>> "Errors" 1/2 track-add - error-list error-display>> "Details" 1/4 track-add + error-list error-table>> "Errors" 1/4 track-add + error-list error-display>> "Details" 1/2 track-add { 5 5 } 1 track-add ; M: error-list-gadget focusable-child*