basis/compiler/tree/checker/checker.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: sequences kernel sets namespaces accessors assocs
   4 arrays combinators continuations columns math vectors
   5 stack-checker.branches
   6 compiler.tree
   7 compiler.tree.def-use
   8 compiler.tree.combinators ;
   9 IN: compiler.tree.checker
  10
  11 ! Check some invariants; this can help catch compiler bugs.
  12
  13 ERROR: check-use-error value message ;
  14
  15 : check-use ( value uses -- )
  16     [ empty? [ "No use" check-use-error ] [ drop ] if ]
  17     [ all-unique? [ drop ] [ "Uses not all unique" check-use-error ] if ] 2bi ;
  18
  19 : check-def-use ( -- )
  20     def-use get [ uses>> check-use ] assoc-each ;
  21
  22 GENERIC: check-node* ( node -- )
  23
  24 M: #shuffle check-node*
  25     [ [ mapping>> values ] [ [ in-d>> ] [ in-r>> ] bi append ] bi subset? [ "Bad mapping inputs" throw ] unless ]
  26     [ [ mapping>> keys ] [ [ out-d>> ] [ out-r>> ] bi append ] bi set= [ "Bad mapping outputs" throw ] unless ]
  27     bi ;
  28
  29 : check-lengths ( seq -- )
  30     [ length ] map all-equal? [ "Bad lengths" throw ] unless ;
  31
  32 M: #copy check-node* inputs/outputs 2array check-lengths ;
  33
  34 M: #return-recursive check-node* inputs/outputs 2array check-lengths ;
  35
  36 M: #phi check-node*
  37     [ [ phi-in-d>> <flipped> ] [ out-d>> ] bi 2array check-lengths ]
  38     [ phi-in-d>> check-lengths ]
  39     bi ;
  40
  41 M: #enter-recursive check-node*
  42     [ [ label>> enter-out>> ] [ out-d>> ] bi assert= ]
  43     [ [ in-d>> ] [ out-d>> ] bi 2array check-lengths ]
  44     [ recursive-phi-in check-lengths ]
  45     tri ;
  46
  47 M: #push check-node*
  48     out-d>> length 1 = [ "Bad #push" throw ] unless ;
  49
  50 M: node check-node* drop ;
  51
  52 : check-values ( seq -- )
  53     [ integer? ] all? [ "Bad values" throw ] unless ;
  54
  55 ERROR: check-node-error node error ;
  56
  57 : check-node ( node -- )
  58     [
  59         [ node-uses-values check-values ]
  60         [ node-defs-values check-values ]
  61         [ check-node* ]
  62         tri
  63     ] [ check-node-error ] recover ;
  64
  65 SYMBOL: datastack
  66 SYMBOL: retainstack
  67 SYMBOL: terminated?
  68
  69 GENERIC: check-stack-flow* ( node -- )
  70
  71 : (check-stack-flow) ( nodes -- )
  72     [ check-stack-flow* terminated? get not ] all? drop ;
  73
  74 : init-stack-flow ( -- )
  75     V{ } clone datastack set
  76     V{ } clone retainstack set ;
  77
  78 : check-stack-flow ( nodes -- )
  79     [
  80         init-stack-flow
  81         (check-stack-flow)
  82     ] with-scope ;
  83
  84 : check-inputs ( seq var -- )
  85     [ dup length ] dip [ swap cut* swap ] change
  86     sequence= [ "Bad stack flow" throw ] unless ;
  87
  88 : check-in-d ( node -- )
  89     in-d>> datastack check-inputs ;
  90
  91 : check-in-r ( node -- )
  92     in-r>> retainstack check-inputs ;
  93
  94 : check-outputs ( node var -- )
  95     get push-all ;
  96
  97 : check-out-d ( node -- )
  98     out-d>> datastack check-outputs ;
  99
 100 : check-out-r ( node -- )
 101     out-r>> retainstack check-outputs ;
 102
 103 M: #introduce check-stack-flow* check-out-d ;
 104
 105 M: #push check-stack-flow* check-out-d ;
 106
 107 M: #call check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
 108
 109 M: #shuffle check-stack-flow*
 110     { [ check-in-d ] [ check-in-r ] [ check-out-d ] [ check-out-r ] } cleave ;
 111
 112 : assert-datastack-empty ( -- )
 113     datastack get empty? [ "Data stack not empty" throw ] unless ;
 114
 115 : assert-retainstack-empty ( -- )
 116     retainstack get empty? [ "Retain stack not empty" throw ] unless ;
 117
 118 M: #return check-stack-flow*
 119     check-in-d
 120     assert-datastack-empty
 121     terminated? get [ assert-retainstack-empty ] unless ;
 122
 123 M: #enter-recursive check-stack-flow*
 124     check-out-d ;
 125
 126 M: #return-recursive check-stack-flow*
 127     [ check-in-d ] [ check-out-d ] bi ;
 128
 129 M: #call-recursive check-stack-flow*
 130     [ check-in-d ] [ check-out-d ] bi ;
 131
 132 : check-terminate-in-d ( #terminate -- )
 133     in-d>> datastack get over length tail* sequence=
 134     [ "Bad terminate data stack" throw ] unless ;
 135
 136 : check-terminate-in-r ( #terminate -- )
 137     in-r>> retainstack get over length tail* sequence=
 138     [ "Bad terminate retain stack" throw ] unless ;
 139
 140 M: #terminate check-stack-flow*
 141     terminated? on
 142     [ check-terminate-in-d ]
 143     [ check-terminate-in-r ] bi ;
 144
 145 SYMBOL: branch-out
 146
 147 : check-branch ( nodes -- stack )
 148     [
 149         datastack [ clone ] change
 150         V{ } clone retainstack set
 151         (check-stack-flow)
 152         terminated? get [ assert-retainstack-empty ] unless
 153         terminated? get f datastack get ?
 154     ] with-scope ;
 155
 156 M: #branch check-stack-flow*
 157     [ check-in-d ]
 158     [ children>> [ check-branch ] map branch-out set ]
 159     bi ;
 160
 161 : check-phi-in ( #phi -- )
 162     phi-in-d>> branch-out get [
 163         dup [
 164             over length tail* sequence= [
 165                 "Branch outputs don't match phi inputs"
 166                 throw
 167             ] unless
 168         ] [
 169             2drop
 170         ] if
 171     ] 2each ;
 172
 173 : set-phi-datastack ( #phi -- )
 174     phi-in-d>> first length
 175     branch-out get [ ] find nip swap head* >vector datastack set ;
 176
 177 M: #phi check-stack-flow*
 178     branch-out get [ ] contains? [
 179         [ check-phi-in ] [ set-phi-datastack ] [ check-out-d ] tri
 180     ] [ drop terminated? on ] if ;
 181
 182 M: #recursive check-stack-flow*
 183     [ check-in-d ] [ child>> (check-stack-flow) ] bi ;
 184
 185 M: #copy check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
 186
 187 M: #alien-invoke check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
 188
 189 M: #alien-indirect check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
 190
 191 M: #alien-callback check-stack-flow* drop ;
 192
 193 M: #declare check-stack-flow* drop ;
 194
 195 : check-nodes ( nodes -- )
 196     compute-def-use
 197     check-def-use
 198     [ [ check-node ] each-node ]
 199     [ check-stack-flow ]
 200     bi ;