2010-01-02 07:03:30 -05:00
|
|
|
! Copyright (C) 2009, 2010 Slava Pestov.
|
2009-05-25 20:16:58 -04:00
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
2009-09-09 14:44:54 -04:00
|
|
|
USING: kernel combinators.short-circuit accessors math sequences
|
|
|
|
sets assocs compiler.cfg.instructions compiler.cfg.rpo
|
|
|
|
compiler.cfg.def-use compiler.cfg.linearization
|
2010-05-02 18:48:41 -04:00
|
|
|
compiler.cfg.utilities compiler.cfg.finalization
|
2010-04-28 04:47:38 -04:00
|
|
|
compiler.utilities ;
|
2009-05-25 20:16:58 -04:00
|
|
|
IN: compiler.cfg.checker
|
|
|
|
|
2009-09-09 14:44:54 -04:00
|
|
|
! Check invariants
|
|
|
|
|
2009-07-19 21:12:04 -04:00
|
|
|
ERROR: bad-kill-block bb ;
|
|
|
|
|
|
|
|
: check-kill-block ( bb -- )
|
2009-09-09 14:44:54 -04:00
|
|
|
dup instructions>> dup penultimate ##epilogue? [
|
|
|
|
{
|
|
|
|
[ length 2 = ]
|
2010-01-02 07:03:30 -05:00
|
|
|
[ last { [ ##return? ] [ ##jump? ] } 1|| ]
|
2009-09-09 14:44:54 -04:00
|
|
|
} 1&&
|
|
|
|
] [ last ##branch? ] if
|
2009-07-19 21:12:04 -04:00
|
|
|
[ drop ] [ bad-kill-block ] if ;
|
|
|
|
|
|
|
|
ERROR: last-insn-not-a-jump bb ;
|
2009-05-25 20:16:58 -04:00
|
|
|
|
2009-05-27 19:58:14 -04:00
|
|
|
: check-last-instruction ( bb -- )
|
2009-07-19 21:12:04 -04:00
|
|
|
dup instructions>> last {
|
2009-05-25 20:16:58 -04:00
|
|
|
[ ##branch? ]
|
2009-05-29 02:39:14 -04:00
|
|
|
[ ##dispatch? ]
|
2010-04-27 10:51:00 -04:00
|
|
|
[ conditional-branch-insn? ]
|
2009-07-01 00:17:33 -04:00
|
|
|
[ ##no-tco? ]
|
2009-05-25 20:16:58 -04:00
|
|
|
} 1|| [ drop ] [ last-insn-not-a-jump ] if ;
|
|
|
|
|
2009-07-19 21:12:04 -04:00
|
|
|
ERROR: bad-kill-insn bb ;
|
|
|
|
|
|
|
|
: check-kill-instructions ( bb -- )
|
|
|
|
dup instructions>> [ kill-vreg-insn? ] any?
|
|
|
|
[ bad-kill-insn ] [ drop ] if ;
|
|
|
|
|
|
|
|
: check-normal-block ( bb -- )
|
|
|
|
[ check-last-instruction ]
|
|
|
|
[ check-kill-instructions ]
|
2009-07-22 07:05:17 -04:00
|
|
|
bi ;
|
2009-05-27 19:58:14 -04:00
|
|
|
|
2009-05-28 03:49:51 -04:00
|
|
|
ERROR: bad-successors ;
|
|
|
|
|
|
|
|
: check-successors ( bb -- )
|
2009-10-28 16:02:00 -04:00
|
|
|
dup successors>> [ predecessors>> member-eq? ] with all?
|
2009-05-28 03:49:51 -04:00
|
|
|
[ bad-successors ] unless ;
|
|
|
|
|
2009-05-27 19:58:14 -04:00
|
|
|
: check-basic-block ( bb -- )
|
2009-07-19 21:12:04 -04:00
|
|
|
[ dup kill-block? [ check-kill-block ] [ check-normal-block ] if ]
|
2009-05-28 03:49:51 -04:00
|
|
|
[ check-successors ]
|
2009-07-19 21:12:04 -04:00
|
|
|
bi ;
|
2009-05-28 03:49:51 -04:00
|
|
|
|
2009-05-25 20:16:58 -04:00
|
|
|
: check-cfg ( cfg -- )
|
2010-05-02 18:48:41 -04:00
|
|
|
[ check-basic-block ] each-basic-block ;
|