36 | 36 |
-- -- -- -- -- -- -- -- -- -- -- --
|
37 | 37 |
|
38 | 38 |
checkInstr nm (COPY src dst) progCtx routCtx =
|
39 | |
updateRoutCtx nm dst (UpdatedWith src) routCtx
|
|
39 |
updateRoutCtxPoison nm dst (UpdatedWith src) routCtx
|
40 | 40 |
checkInstr nm (DELTA dst val) progCtx routCtx =
|
41 | |
updateRoutCtx nm dst (UpdatedWith (Immediate val)) routCtx
|
|
41 |
updateRoutCtxPoison nm dst (UpdatedWith (Immediate val)) routCtx
|
42 | 42 |
checkInstr nm (ADD dst src) progCtx routCtx =
|
43 | |
updateRoutCtx nm dst (UpdatedWith src) routCtx
|
|
43 |
updateRoutCtxPoison nm dst (UpdatedWith src) routCtx
|
44 | 44 |
checkInstr nm (SUB dst src) progCtx routCtx =
|
45 | |
updateRoutCtx nm dst (UpdatedWith src) routCtx
|
|
45 |
updateRoutCtxPoison nm dst (UpdatedWith src) routCtx
|
46 | 46 |
|
47 | 47 |
checkInstr nm (AND dst src) progCtx routCtx =
|
48 | |
updateRoutCtx nm dst (UpdatedWith src) routCtx
|
|
48 |
updateRoutCtxPoison nm dst (UpdatedWith src) routCtx
|
49 | 49 |
checkInstr nm (OR dst src) progCtx routCtx =
|
50 | |
updateRoutCtx nm dst (UpdatedWith src) routCtx
|
|
50 |
updateRoutCtxPoison nm dst (UpdatedWith src) routCtx
|
51 | 51 |
checkInstr nm (XOR dst src) progCtx routCtx =
|
52 | |
updateRoutCtx nm dst (UpdatedWith src) routCtx
|
|
52 |
updateRoutCtxPoison nm dst (UpdatedWith src) routCtx
|
53 | 53 |
|
54 | 54 |
checkInstr nm (JSR name) progCtx routCtx =
|
55 | 55 |
case lookupRoutine program name of
|
|
76 | 76 |
mergeAlternateRoutCtxs nm routCtx1 routCtx2
|
77 | 77 |
checkInstr nm (REPEAT _ branch blk) progCtx routCtx =
|
78 | 78 |
-- we analyze the block twice, to simulate it being
|
79 | |
-- repeated. (see tests for a test case on this.
|
|
79 |
-- repeated. (see tests for a test case on this.)
|
80 | 80 |
let
|
81 | 81 |
routCtx' = checkBlock nm blk progCtx routCtx
|
82 | 82 |
routCtx'' = checkBlock nm blk progCtx routCtx'
|
|
88 | 88 |
checkBlock nm blk progCtx routCtx
|
89 | 89 |
|
90 | 90 |
checkInstr nm (BIT dst) progCtx routCtx =
|
91 | |
updateRoutCtx nm dst (UpdatedWith (Immediate 0)) routCtx
|
|
91 |
updateRoutCtxPoison nm dst (UpdatedWith (Immediate 0)) routCtx
|
92 | 92 |
|
93 | 93 |
checkInstr nm (SHR dst flg) progCtx routCtx =
|
94 | |
updateRoutCtx nm dst (UpdatedWith flg) routCtx
|
|
94 |
updateRoutCtxPoison nm dst (UpdatedWith flg) routCtx
|
95 | 95 |
checkInstr nm (SHL dst flg) progCtx routCtx =
|
96 | |
updateRoutCtx nm dst (UpdatedWith flg) routCtx
|
|
96 |
updateRoutCtxPoison nm dst (UpdatedWith flg) routCtx
|
97 | 97 |
|
98 | 98 |
checkInstr nm (COPYROUTINE name dst) progCtx routCtx =
|
99 | |
updateRoutCtx nm dst (UpdatedWith (Immediate 7)) routCtx
|
|
99 |
updateRoutCtxPoison nm dst (UpdatedWith (Immediate 7)) routCtx
|
100 | 100 |
|
101 | 101 |
checkInstr nm (JMPVECTOR dst) progCtx routCtx =
|
102 | 102 |
routCtx
|
|
113 | 113 |
-- Take 2 routine contexts -- the current routine and a routine that was just
|
114 | 114 |
-- JSR'ed to (immediately previously) -- and merge them to create a new
|
115 | 115 |
-- context for the current routine.
|
|
116 |
--
|
|
117 |
-- This can't, by itself, cause a poisoning error.
|
|
118 |
-- So we use a weaker version of updateRoutCtx to build the merged context.
|
116 | 119 |
--
|
117 | 120 |
mergeRoutCtxs nm routCtx calledRoutCtx calledRout@(Routine name outputs _) =
|
118 | 121 |
let
|
|
164 | 167 |
updateRoutCtx nm location newUsage routCtxAccum
|
165 | 168 |
in
|
166 | 169 |
Map.foldrWithKey (poison) routCtx1 routCtx2
|
167 | |
where
|
168 | |
-- a weaker version of updateRoutCtx, which does not error if
|
169 | |
-- we access a poisoned source
|
170 | |
updateRoutCtx nm dst (UpdatedWith src) routCtx =
|
171 | |
let
|
172 | |
s = untypedLocation src
|
173 | |
d = untypedLocation dst
|
174 | |
in
|
175 | |
Map.insert d (UpdatedWith s) routCtx
|
176 | |
updateRoutCtx nm dst (PoisonedWith src) routCtx =
|
177 | |
Map.insert (untypedLocation dst) (PoisonedWith $ untypedLocation src) routCtx
|