: <date> ( year month day -- timestamp )
0 0 0 gmt-offset-duration <timestamp> ;
-ERROR: not-a-month n ;
+ERROR: not-a-month ;
M: not-a-month summary
drop "Months are indexed starting at 1" ;
<PRIVATE
: check-month ( n -- n )
- dup zero? [ not-a-month ] when ;
+ [ not-a-month ] when-zero ;
PRIVATE>
{ [ 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 ;
[ 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 ;
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 )
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
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 -- )
drop instructions>> transfer-liveness ;
M: live-analysis join-sets
- drop assoc-combine ;
\ No newline at end of file
+ 2drop assoc-combine ;
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
[ compute-dead-sets ]
[ compute-avail-sets ]
[ ]
- } cleave ;
\ No newline at end of file
+ } cleave ;
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 [
[ [ <ds-loc> ] (uninitialized-locs) ]
[ [ <rs-loc> ] (uninitialized-locs) ]
bi* append
- ] when ;
\ No newline at end of file
+ ] when ;
--- /dev/null
+Slava Pestov
+Daniel Ehrenberg
+! 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 )
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
-! 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.
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 ;
{ 5 5 } >>gap
error-list <error-list-toolbar> f track-add
error-list source-file-table>> <scroller> "Source files" <labeled-gadget> 1/4 track-add
- error-list error-table>> <scroller> "Errors" <labeled-gadget> 1/2 track-add
- error-list error-display>> "Details" <labeled-gadget> 1/4 track-add
+ error-list error-table>> <scroller> "Errors" <labeled-gadget> 1/4 track-add
+ error-list error-display>> "Details" <labeled-gadget> 1/2 track-add
{ 5 5 } <filled-border> 1 track-add ;
M: error-list-gadget focusable-child*