basis/compiler/tree/checker/checker.factor

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