git @ Cat's Eye Technologies SixtyPical / 8acde17
mergeRoutCtxs does not need to throw poisoning errors. Cat's Eye Technologies 8 years ago
3 changed file(s) with 55 addition(s) and 42 deletion(s). Raw diff Collapse all Expand all
2525 reserve byte value
2626 reserve word compare_target
2727
28 routine reset_position {
29 copy #$0400 position
30 }
28 reserve byte[16] actor_pos_hi
29 reserve byte[16] actor_pos_lo
3130
32 routine advance_pos {
31 routine calculate_new_position outputs (new_position) {
3332 clc
3433 lda <position
3534 adc <delta
3736 lda >position
3837 adc >delta
3938 sta >new_position
40 }
41
42 routine install_new_position {
43 copy new_position position
4439 }
4540
4641 routine compare_new_pos {
116111 if beq {
117112 lda #255 // -1
118113 sta <delta
119 lda #255
120114 sta >delta
121115 } else {
122116 txa
131125 }
132126
133127 routine our_cinv {
134 lda #32
135128 ldy #0
136 sta (position), y
129 lda actor_pos_hi, y
130 sta >position
131 lda actor_pos_lo, y
132 sta <position
133
137134 jsr read_stick
138 jsr advance_pos
135 jsr calculate_new_position
139136 jsr check_new_position_in_bounds
140137 if bcs {
141 jsr install_new_position
138 lda #32
139 ldy #0
140 sta (position), y
141 copy new_position position
142 lda #81
143 ldy #0
144 sta (position), y
142145 } else { }
143146
144 lda #81
145147 ldy #0
146 sta (position), y
148 lda >position
149 sta actor_pos_hi, y
150 lda <position
151 sta actor_pos_lo, y
147152
148153 jmp (save_cinv)
149154 }
153158 sta vic_border
154159 lda #0
155160 sta vic_bg
156 jsr reset_position
161 // copy #$0400 position
162
163 ldy #0
164 lda #$04
165 sta actor_pos_hi, y
166 lda #$00
167 sta actor_pos_lo, y
168
157169 jsr clear_screen
158170 with sei {
159171 copy cinv save_cinv
3636 -- -- -- -- -- -- -- -- -- -- -- --
3737
3838 checkInstr nm (COPY src dst) progCtx routCtx =
39 updateRoutCtx nm dst (UpdatedWith src) routCtx
39 updateRoutCtxPoison nm dst (UpdatedWith src) routCtx
4040 checkInstr nm (DELTA dst val) progCtx routCtx =
41 updateRoutCtx nm dst (UpdatedWith (Immediate val)) routCtx
41 updateRoutCtxPoison nm dst (UpdatedWith (Immediate val)) routCtx
4242 checkInstr nm (ADD dst src) progCtx routCtx =
43 updateRoutCtx nm dst (UpdatedWith src) routCtx
43 updateRoutCtxPoison nm dst (UpdatedWith src) routCtx
4444 checkInstr nm (SUB dst src) progCtx routCtx =
45 updateRoutCtx nm dst (UpdatedWith src) routCtx
45 updateRoutCtxPoison nm dst (UpdatedWith src) routCtx
4646
4747 checkInstr nm (AND dst src) progCtx routCtx =
48 updateRoutCtx nm dst (UpdatedWith src) routCtx
48 updateRoutCtxPoison nm dst (UpdatedWith src) routCtx
4949 checkInstr nm (OR dst src) progCtx routCtx =
50 updateRoutCtx nm dst (UpdatedWith src) routCtx
50 updateRoutCtxPoison nm dst (UpdatedWith src) routCtx
5151 checkInstr nm (XOR dst src) progCtx routCtx =
52 updateRoutCtx nm dst (UpdatedWith src) routCtx
52 updateRoutCtxPoison nm dst (UpdatedWith src) routCtx
5353
5454 checkInstr nm (JSR name) progCtx routCtx =
5555 case lookupRoutine program name of
7676 mergeAlternateRoutCtxs nm routCtx1 routCtx2
7777 checkInstr nm (REPEAT _ branch blk) progCtx routCtx =
7878 -- 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.)
8080 let
8181 routCtx' = checkBlock nm blk progCtx routCtx
8282 routCtx'' = checkBlock nm blk progCtx routCtx'
8888 checkBlock nm blk progCtx routCtx
8989
9090 checkInstr nm (BIT dst) progCtx routCtx =
91 updateRoutCtx nm dst (UpdatedWith (Immediate 0)) routCtx
91 updateRoutCtxPoison nm dst (UpdatedWith (Immediate 0)) routCtx
9292
9393 checkInstr nm (SHR dst flg) progCtx routCtx =
94 updateRoutCtx nm dst (UpdatedWith flg) routCtx
94 updateRoutCtxPoison nm dst (UpdatedWith flg) routCtx
9595 checkInstr nm (SHL dst flg) progCtx routCtx =
96 updateRoutCtx nm dst (UpdatedWith flg) routCtx
96 updateRoutCtxPoison nm dst (UpdatedWith flg) routCtx
9797
9898 checkInstr nm (COPYROUTINE name dst) progCtx routCtx =
99 updateRoutCtx nm dst (UpdatedWith (Immediate 7)) routCtx
99 updateRoutCtxPoison nm dst (UpdatedWith (Immediate 7)) routCtx
100100
101101 checkInstr nm (JMPVECTOR dst) progCtx routCtx =
102102 routCtx
113113 -- Take 2 routine contexts -- the current routine and a routine that was just
114114 -- JSR'ed to (immediately previously) -- and merge them to create a new
115115 -- 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.
116119 --
117120 mergeRoutCtxs nm routCtx calledRoutCtx calledRout@(Routine name outputs _) =
118121 let
164167 updateRoutCtx nm location newUsage routCtxAccum
165168 in
166169 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
3737 NamedLocation Nothing name
3838 untypedLocation x = x
3939
40 updateRoutCtx :: String -> StorageLocation -> Usage -> RoutineContext -> RoutineContext
41 updateRoutCtx nm dst (UpdatedWith src) routCtx =
40 updateRoutCtxPoison :: String -> StorageLocation -> Usage -> RoutineContext -> RoutineContext
41 updateRoutCtxPoison nm dst (UpdatedWith src) routCtx =
4242 let
4343 s = untypedLocation src
4444 d = untypedLocation dst
4949 (show s) ++ "' (in context: " ++ (show routCtx) ++ ")")
5050 _ ->
5151 Map.insert d (UpdatedWith s) routCtx
52 updateRoutCtxPoison nm dst (PoisonedWith src) routCtx =
53 Map.insert (untypedLocation dst) (PoisonedWith $ untypedLocation src) routCtx
54
55 updateRoutCtx nm dst (UpdatedWith src) routCtx =
56 let
57 s = untypedLocation src
58 d = untypedLocation dst
59 in
60 Map.insert d (UpdatedWith s) routCtx
5261 updateRoutCtx nm dst (PoisonedWith src) routCtx =
5362 Map.insert (untypedLocation dst) (PoisonedWith $ untypedLocation src) routCtx
54
63
5564 -- pretty printing
5665
5766 ppAnalysis :: Program -> ProgramContext -> IO ()