From 8acde175ad044969f7a5a7d882b48ff0e9d8fe28 Mon Sep 17 00:00:00 2001
From: Cat's Eye Technologies <cpressey@catseye.tc>
Date: Sat, 12 Apr 2014 20:37:42 +0100
Subject: [PATCH] mergeRoutCtxs does not need to throw poisoning errors.

---
 eg/game.60p                | 44 ++++++++++++++++++++++++--------------
 src/SixtyPical/Analyzer.hs | 38 +++++++++++++-------------------
 src/SixtyPical/Context.hs  | 15 ++++++++++---
 3 files changed, 55 insertions(+), 42 deletions(-)

diff --git a/eg/game.60p b/eg/game.60p
index dbd0175..442f972 100644
--- a/eg/game.60p
+++ b/eg/game.60p
@@ -26,11 +26,10 @@ reserve word delta
 reserve byte value
 reserve word compare_target
 
-routine reset_position {
-    copy #$0400 position
-}
+reserve byte[16] actor_pos_hi
+reserve byte[16] actor_pos_lo
 
-routine advance_pos {
+routine calculate_new_position outputs (new_position) {
     clc
     lda <position
     adc <delta
@@ -40,10 +39,6 @@ routine advance_pos {
     sta >new_position
 }
 
-routine install_new_position {
-    copy new_position position
-}
-
 routine compare_new_pos {
     lda >new_position
     cmp >compare_target
@@ -117,7 +112,6 @@ routine read_stick {
             if beq {
                 lda #255     // -1
                 sta <delta
-                lda #255
                 sta >delta
             } else {
                 txa
@@ -132,19 +126,30 @@ routine read_stick {
 }
 
 routine our_cinv {
-    lda #32
     ldy #0
-    sta (position), y
+    lda actor_pos_hi, y
+    sta >position
+    lda actor_pos_lo, y
+    sta <position
+
     jsr read_stick
-    jsr advance_pos
+    jsr calculate_new_position
     jsr check_new_position_in_bounds
     if bcs {
-        jsr install_new_position
+        lda #32
+        ldy #0
+        sta (position), y
+        copy new_position position
+        lda #81
+        ldy #0
+        sta (position), y
     } else { }
 
-    lda #81
     ldy #0
-    sta (position), y
+    lda >position
+    sta actor_pos_hi, y
+    lda <position
+    sta actor_pos_lo, y
 
     jmp (save_cinv)
 }
@@ -154,7 +159,14 @@ routine main {
     sta vic_border
     lda #0
     sta vic_bg
-    jsr reset_position
+    // copy #$0400 position
+
+    ldy #0
+    lda #$04
+    sta actor_pos_hi, y
+    lda #$00
+    sta actor_pos_lo, y
+
     jsr clear_screen
     with sei {
         copy cinv save_cinv
diff --git a/src/SixtyPical/Analyzer.hs b/src/SixtyPical/Analyzer.hs
index fcebe7b..af2118b 100644
--- a/src/SixtyPical/Analyzer.hs
+++ b/src/SixtyPical/Analyzer.hs
@@ -37,20 +37,20 @@ analyzeProgram program@(Program decls routines) =
       -- -- -- -- -- -- -- -- -- -- -- --
       
       checkInstr nm (COPY src dst) progCtx routCtx =
-          updateRoutCtx nm dst (UpdatedWith src) routCtx
+          updateRoutCtxPoison nm dst (UpdatedWith src) routCtx
       checkInstr nm (DELTA dst val) progCtx routCtx =
-          updateRoutCtx nm dst (UpdatedWith (Immediate val)) routCtx
+          updateRoutCtxPoison nm dst (UpdatedWith (Immediate val)) routCtx
       checkInstr nm (ADD dst src) progCtx routCtx =
-          updateRoutCtx nm dst (UpdatedWith src) routCtx
+          updateRoutCtxPoison nm dst (UpdatedWith src) routCtx
       checkInstr nm (SUB dst src) progCtx routCtx =
-          updateRoutCtx nm dst (UpdatedWith src) routCtx
+          updateRoutCtxPoison nm dst (UpdatedWith src) routCtx
 
       checkInstr nm (AND dst src) progCtx routCtx =
-          updateRoutCtx nm dst (UpdatedWith src) routCtx
+          updateRoutCtxPoison nm dst (UpdatedWith src) routCtx
       checkInstr nm (OR dst src) progCtx routCtx =
-          updateRoutCtx nm dst (UpdatedWith src) routCtx
+          updateRoutCtxPoison nm dst (UpdatedWith src) routCtx
       checkInstr nm (XOR dst src) progCtx routCtx =
-          updateRoutCtx nm dst (UpdatedWith src) routCtx
+          updateRoutCtxPoison nm dst (UpdatedWith src) routCtx
 
       checkInstr nm (JSR name) progCtx routCtx =
           case lookupRoutine program name of
@@ -77,7 +77,7 @@ analyzeProgram program@(Program decls routines) =
               mergeAlternateRoutCtxs nm routCtx1 routCtx2
       checkInstr nm (REPEAT _ branch blk) progCtx routCtx =
           -- we analyze the block twice, to simulate it being
-          -- repeated.  (see tests for a test case on this.
+          -- repeated.  (see tests for a test case on this.)
           let
               routCtx' = checkBlock nm blk progCtx routCtx
               routCtx'' = checkBlock nm blk progCtx routCtx'
@@ -89,15 +89,15 @@ analyzeProgram program@(Program decls routines) =
           checkBlock nm blk progCtx routCtx
 
       checkInstr nm (BIT dst) progCtx routCtx =
-          updateRoutCtx nm dst (UpdatedWith (Immediate 0)) routCtx
+          updateRoutCtxPoison nm dst (UpdatedWith (Immediate 0)) routCtx
 
       checkInstr nm (SHR dst flg) progCtx routCtx =
-          updateRoutCtx nm dst (UpdatedWith flg) routCtx
+          updateRoutCtxPoison nm dst (UpdatedWith flg) routCtx
       checkInstr nm (SHL dst flg) progCtx routCtx =
-          updateRoutCtx nm dst (UpdatedWith flg) routCtx
+          updateRoutCtxPoison nm dst (UpdatedWith flg) routCtx
 
       checkInstr nm (COPYROUTINE name dst) progCtx routCtx =
-          updateRoutCtx nm dst (UpdatedWith (Immediate 7)) routCtx
+          updateRoutCtxPoison nm dst (UpdatedWith (Immediate 7)) routCtx
 
       checkInstr nm (JMPVECTOR dst) progCtx routCtx =
           routCtx
@@ -115,6 +115,9 @@ analyzeProgram program@(Program decls routines) =
 -- JSR'ed to (immediately previously) -- and merge them to create a new
 -- context for the current routine.
 --
+-- This can't, by itself, cause a poisoning error.
+-- So we use a weaker version of updateRoutCtx to build the merged context.
+--
 mergeRoutCtxs nm routCtx calledRoutCtx calledRout@(Routine name outputs _) =
     let
         -- go through all the Usages in the calledRoutCtx
@@ -165,14 +168,3 @@ mergeAlternateRoutCtxs nm routCtx1 routCtx2 =
                         updateRoutCtx nm location newUsage routCtxAccum
     in
         Map.foldrWithKey (poison) routCtx1 routCtx2
-    where
-        -- a weaker version of updateRoutCtx, which does not error if
-        -- we access a poisoned source
-        updateRoutCtx nm dst (UpdatedWith src) routCtx =
-            let
-                s = untypedLocation src
-                d = untypedLocation dst
-            in
-                Map.insert d (UpdatedWith s) routCtx
-        updateRoutCtx nm dst (PoisonedWith src) routCtx =
-            Map.insert (untypedLocation dst) (PoisonedWith $ untypedLocation src) routCtx
diff --git a/src/SixtyPical/Context.hs b/src/SixtyPical/Context.hs
index 9453d0e..de4d3f0 100644
--- a/src/SixtyPical/Context.hs
+++ b/src/SixtyPical/Context.hs
@@ -38,8 +38,8 @@ untypedLocation (NamedLocation _ name) =
     NamedLocation Nothing name
 untypedLocation x = x
 
-updateRoutCtx :: String -> StorageLocation -> Usage -> RoutineContext -> RoutineContext
-updateRoutCtx nm dst (UpdatedWith src) routCtx =
+updateRoutCtxPoison :: String -> StorageLocation -> Usage -> RoutineContext -> RoutineContext
+updateRoutCtxPoison nm dst (UpdatedWith src) routCtx =
     let
         s = untypedLocation src
         d = untypedLocation dst
@@ -50,9 +50,18 @@ updateRoutCtx nm dst (UpdatedWith src) routCtx =
                        (show s) ++ "' (in context: " ++ (show routCtx) ++ ")")
             _ ->
                 Map.insert d (UpdatedWith s) routCtx
-updateRoutCtx nm dst (PoisonedWith src) routCtx =
+updateRoutCtxPoison nm dst (PoisonedWith src) routCtx =
     Map.insert (untypedLocation dst) (PoisonedWith $ untypedLocation src) routCtx
                   
+updateRoutCtx nm dst (UpdatedWith src) routCtx =
+    let
+        s = untypedLocation src
+        d = untypedLocation dst
+    in
+        Map.insert d (UpdatedWith s) routCtx
+updateRoutCtx nm dst (PoisonedWith src) routCtx =
+    Map.insert (untypedLocation dst) (PoisonedWith $ untypedLocation src) routCtx
+
 -- pretty printing
 
 ppAnalysis :: Program -> ProgramContext -> IO ()