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