basis/compiler/cfg/checker/checker.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel compiler.cfg.instructions compiler.cfg.rpo
   4 compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.utilities
   5 compiler.cfg.mr combinators.short-circuit accessors math
   6 sequences sets assocs ;
   7 IN: compiler.cfg.checker
   8
   9 ERROR: bad-kill-block bb ;
  10
  11 : check-kill-block ( bb -- )
  12     dup instructions>> first2
  13     swap ##epilogue? [
  14         { [ ##return? ] [ ##callback-return? ] [ ##jump? ] } 1||
  15     ] [ ##branch? ] if
  16     [ drop ] [ bad-kill-block ] if ;
  17
  18 ERROR: last-insn-not-a-jump bb ;
  19
  20 : check-last-instruction ( bb -- )
  21     dup instructions>> last {
  22         [ ##branch? ]
  23         [ ##dispatch? ]
  24         [ ##conditional-branch? ]
  25         [ ##compare-imm-branch? ]
  26         [ ##fixnum-add? ]
  27         [ ##fixnum-sub? ]
  28         [ ##fixnum-mul? ]
  29         [ ##no-tco? ]
  30     } 1|| [ drop ] [ last-insn-not-a-jump ] if ;
  31
  32 ERROR: bad-kill-insn bb ;
  33
  34 : check-kill-instructions ( bb -- )
  35     dup instructions>> [ kill-vreg-insn? ] any?
  36     [ bad-kill-insn ] [ drop ] if ;
  37
  38 : check-normal-block ( bb -- )
  39     [ check-last-instruction ]
  40     [ check-kill-instructions ]
  41     bi ;
  42
  43 ERROR: bad-successors ;
  44
  45 : check-successors ( bb -- )
  46     dup successors>> [ predecessors>> memq? ] with all?
  47     [ bad-successors ] unless ;
  48
  49 : check-basic-block ( bb -- )
  50     [ dup kill-block? [ check-kill-block ] [ check-normal-block ] if ]
  51     [ check-successors ]
  52     bi ;
  53
  54 ERROR: bad-live-in ;
  55
  56 ERROR: undefined-values uses defs ;
  57
  58 : check-mr ( mr -- )
  59     ! Check that every used register has a definition
  60     instructions>>
  61     [ [ uses-vregs ] map concat ]
  62     [ [ [ temp-vregs ] [ defs-vreg ] bi [ suffix ] when* ] map concat ] bi
  63     2dup subset? [ 2drop ] [ undefined-values ] if ;
  64
  65 : check-cfg ( cfg -- )
  66     [ [ check-basic-block ] each-basic-block ]
  67     [ build-mr check-mr ]
  68     bi ;