steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

compiler.cfg.stacks.*: vacant-peek checking readded

db4
Björn Lindqvist 2015-01-01 16:13:47 +01:00 committed by Doug Coleman
parent 640759ffed
commit d4493858da
2 changed files with 13 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/compiler/cfg/stacks/clearing/clearing.factor
View File

@ -4,12 +4,12 @@ compiler.cfg.stacks.map kernel math sequences ;
IN: compiler.cfg.stacks.clearing IN: compiler.cfg.stacks.clearing
: state>replaces ( state -- replaces ) : state>replaces ( state -- replaces )
state>vacancies first2 [ stack>vacant ] map first2
[ [ <ds-loc> ] map ] [ [ <rs-loc> ] map ] bi* append [ [ <ds-loc> ] map ] [ [ <rs-loc> ] map ] bi* append
[ 17 swap f ##replace-imm boa ] map ; [ 17 swap f ##replace-imm boa ] map ;
: dangerous-insn? ( state insn -- ? ) : dangerous-insn? ( state insn -- ? )
{ [ nip ##peek? ] [ dangerous-peek? ] } 2&& ; { [ nip ##peek? ] [ underflowable-peek? ] } 2&& ;
: clearing-replaces ( assoc insn -- insns' ) : clearing-replaces ( assoc insn -- insns' )
[ of ] keep 2dup dangerous-insn? [ [ of ] keep 2dup dangerous-insn? [

19
basis/compiler/cfg/stacks/map/map.factor
View File

@ -1,4 +1,4 @@
USING: accessors arrays assocs compiler.cfg.dataflow-analysis USING: accessors arrays assocs combinators compiler.cfg.dataflow-analysis
compiler.cfg.instructions compiler.cfg.registers fry kernel math math.order compiler.cfg.instructions compiler.cfg.registers fry kernel math math.order
namespaces sequences ; namespaces sequences ;
QUALIFIED: sets QUALIFIED: sets
@ -14,6 +14,9 @@ IN: compiler.cfg.stacks.map
: stack>vacant ( stack -- seq ) : stack>vacant ( stack -- seq )
first2 [ 0 max iota ] dip sets:diff ; first2 [ 0 max iota ] dip sets:diff ;
: classify-read ( stack n -- val )
swap 2dup second member? [ 2drop 0 ] [ first >= [ 1 ] [ 2 ] if ] if ;
CONSTANT: initial-state { { 0 { } } { 0 { } } } CONSTANT: initial-state { { 0 { } } { 0 { } } }
: insn>location ( insn -- n ds? ) : insn>location ( insn -- n ds? )
@ -23,11 +26,8 @@ CONSTANT: initial-state { { 0 { } } { 0 { } } }
[ first2 ] dip insn>location [ first2 ] dip insn>location
[ rot register-write swap ] [ swap register-write ] if 2array ; [ rot register-write swap ] [ swap register-write ] if 2array ;
: state>vacancies ( state -- vacants )
[ stack>vacant ] map ;
: fill-vacancies ( state -- state' ) : fill-vacancies ( state -- state' )
dup state>vacancies [ [ first2 ] dip append 2array ] 2map ; [ [ first2 ] [ stack>vacant ] bi append 2array ] map ;
GENERIC: visit-insn ( state insn -- state' ) GENERIC: visit-insn ( state insn -- state' )
@ -45,11 +45,14 @@ M: ##call visit-insn ( state insn -- state' )
! to contain valid pointers anymore. ! to contain valid pointers anymore.
drop [ first2 [ 0 >= ] filter 2array ] map ; drop [ first2 [ 0 >= ] filter 2array ] map ;
: dangerous-peek? ( state peek -- ? ) ERROR: vacant-peek insn ;
loc>> [ ds-loc? 0 1 ? swap nth first ] keep n>> <= ;
: underflowable-peek? ( state peek -- ? )
2dup insn>location swap [ 0 1 ? swap nth ] dip classify-read
dup 2 = [ drop vacant-peek ] [ 2nip 1 = ] if ;
M: ##peek visit-insn ( state insn -- state' ) M: ##peek visit-insn ( state insn -- state' )
2dup dangerous-peek? [ [ fill-vacancies ] dip ] when mark-location ; 2dup underflowable-peek? [ [ fill-vacancies ] dip ] when mark-location ;
M: insn visit-insn ( state insn -- state' ) M: insn visit-insn ( state insn -- state' )
drop ; drop ;