Routines can declare their outputs now.
Cat's Eye Technologies
10 years ago
58 | 58 | = update_score |
59 | 59 | = X: UpdatedWith (Immediate 1) |
60 | 60 | = NamedLocation (Just Byte) "score": UpdatedWith X |
61 | ||
62 | We can't expect to stay named variables to stay unmodified either. | |
63 | ||
64 | | assign byte border_colour 4000 | |
65 | | reserve byte score | |
66 | | routine update_score | |
67 | | { | |
68 | | lda #8 | |
69 | | sta score | |
70 | | } | |
71 | | routine main { | |
72 | | jsr update_score | |
73 | | ldx score | |
74 | | } | |
75 | ? routine does not preserve 'NamedLocation (Just Byte) "score"' | |
76 | ||
77 | What the solution to the above is to notate `update_score` as intentionally | |
78 | modifying score, as an "output" of the routine. | |
79 | ||
80 | | assign byte border_colour 4000 | |
81 | | reserve byte score | |
82 | | routine update_score outputs (score) | |
83 | | { | |
84 | | lda #8 | |
85 | | sta score | |
86 | | } | |
87 | | routine main { | |
88 | | ldx score | |
89 | | jsr update_score | |
90 | | ldx score | |
91 | | } | |
92 | = main | |
93 | = A: UpdatedWith (Immediate 4) | |
94 | = X: PoisonedWith (Immediate 1) | |
95 | = NamedLocation (Just Byte) "border_colour": UpdatedWith A | |
96 | = NamedLocation (Just Byte) "score": PoisonedWith X | |
97 | = | |
98 | = update_score | |
99 | = X: UpdatedWith (Immediate 1) | |
100 | = NamedLocation (Just Byte) "score": UpdatedWith X |
8 | 8 | |
9 | 9 | -- -- -- -- abstract interpreter -- -- -- -- |
10 | 10 | |
11 | analyzeProgram (Program decls routines) = | |
11 | analyzeProgram program@(Program decls routines) = | |
12 | 12 | checkRoutines routines Map.empty |
13 | where | |
14 | checkRoutines [] progCtx = progCtx | |
15 | checkRoutines (rout@(Routine name outputs _) : routs) progCtx = | |
16 | let | |
17 | routCtx = Map.empty | |
18 | routAnalysis = checkRoutine rout progCtx routCtx | |
19 | progCtx' = Map.insert name routAnalysis progCtx | |
20 | in | |
21 | checkRoutines routs progCtx' | |
22 | ||
23 | checkRoutine (Routine name outputs instrs) progCtx routCtx = | |
24 | checkBlock instrs progCtx routCtx | |
25 | ||
26 | checkBlock [] progCtx routCtx = routCtx | |
27 | checkBlock (instr:instrs) progCtx routCtx = | |
28 | let | |
29 | routCtx' = checkInstr instr progCtx routCtx | |
30 | in | |
31 | checkBlock instrs progCtx routCtx' | |
32 | ||
33 | checkInstr (COPY src dst) progCtx routCtx = | |
34 | case Map.lookup src routCtx of | |
35 | Just (PoisonedWith _) -> | |
36 | error ("routine does not preserve '" ++ (show src) ++ "'") | |
37 | _ -> | |
38 | Map.insert dst (UpdatedWith src) routCtx | |
39 | checkInstr (DELTA dst val) progCtx routCtx = | |
40 | -- TODO check that dst is not poisoned | |
41 | Map.insert dst (UpdatedWith (Immediate val)) routCtx | |
42 | checkInstr (JSR name) progCtx routCtx = | |
43 | let | |
44 | Just calledRout = lookupRoutine program name | |
45 | in | |
46 | case Map.lookup name progCtx of | |
47 | Just calledRoutCtx -> | |
48 | mergeRoutCtxs routCtx calledRoutCtx calledRout | |
49 | Nothing -> | |
50 | error ("can't call routine '" ++ name ++ "' before it is defined") | |
51 | checkInstr (CMP reg addr) progCtx routCtx = | |
52 | -- TODO: mark Carry bit as "touched" here | |
53 | routCtx | |
54 | checkInstr (IF _ branch b1 b2) progCtx routCtx = | |
55 | -- TODO: oooh, this one's gonna be fun | |
56 | --checkBlock b1 progCtx routCtx | |
57 | --checkBlock b2 progCtx routCtx | |
58 | routCtx | |
59 | checkInstr (REPEAT _ branch blk) progCtx routCtx = | |
60 | -- TODO: oooh, this one's gonna be fun too | |
61 | --checkBlock blk progCtx routCtx | |
62 | routCtx | |
63 | checkInstr NOP progCtx routCtx = | |
64 | routCtx | |
65 | ||
66 | checkInstr instr _ _ = error ( | |
67 | "Internal error: sixtypical doesn't know how to " ++ | |
68 | "analyze '" ++ (show instr) ++ "'") | |
13 | 69 | |
14 | checkRoutines [] progCtx = progCtx | |
15 | checkRoutines (rout@(Routine name _) : routs) progCtx = | |
70 | -- | |
71 | -- Utility function: | |
72 | -- Take 2 routine contexts -- the current routine and a routine that was just | |
73 | -- JSR'ed to (immediately previously) -- and merge them to create a new | |
74 | -- context for the current routine. | |
75 | -- | |
76 | mergeRoutCtxs routCtx calledRoutCtx calledRout@(Routine name outputs _) = | |
16 | 77 | let |
17 | routCtx = Map.empty | |
18 | routAnalysis = checkRoutine rout progCtx routCtx | |
19 | progCtx' = Map.insert name routAnalysis progCtx | |
78 | -- go through all the Usages in the calledRoutCtx | |
79 | -- insert any that were updated, into routCtx | |
80 | poison location usage routCtxAccum = | |
81 | case usage of | |
82 | UpdatedWith ulocation -> | |
83 | Map.insert location (PoisonedWith ulocation) routCtxAccum | |
20 | 84 | in |
21 | checkRoutines routs progCtx' | |
22 | ||
23 | checkRoutine (Routine name instrs) progCtx routCtx = | |
24 | checkBlock instrs progCtx routCtx | |
25 | ||
26 | checkBlock [] progCtx routCtx = routCtx | |
27 | checkBlock (instr:instrs) progCtx routCtx = | |
28 | let | |
29 | routCtx' = checkInstr instr progCtx routCtx | |
30 | in | |
31 | checkBlock instrs progCtx routCtx' | |
32 | ||
33 | checkInstr (COPY src dst) progCtx routCtx = | |
34 | case Map.lookup src routCtx of | |
35 | Just (PoisonedWith _) -> | |
36 | error ("routine does not preserve '" ++ (show src) ++ "'") | |
37 | _ -> | |
38 | Map.insert dst (UpdatedWith src) routCtx | |
39 | checkInstr (DELTA dst val) progCtx routCtx = | |
40 | -- TODO check that dst is not poisoned | |
41 | Map.insert dst (UpdatedWith (Immediate val)) routCtx | |
42 | checkInstr (JSR name) progCtx routCtx = | |
43 | case Map.lookup name progCtx of | |
44 | Just calledRoutCtx -> | |
45 | mergeRoutCtxs routCtx calledRoutCtx | |
46 | Nothing -> | |
47 | error ("can't call routine '" ++ name ++ "' before it is defined") | |
48 | checkInstr (CMP reg addr) progCtx routCtx = | |
49 | -- TODO: mark Carry bit as "touched" here | |
50 | routCtx | |
51 | checkInstr (IF _ branch b1 b2) progCtx routCtx = | |
52 | -- TODO: oooh, this one's gonna be fun | |
53 | --checkBlock b1 progCtx routCtx | |
54 | --checkBlock b2 progCtx routCtx | |
55 | routCtx | |
56 | checkInstr (REPEAT _ branch blk) progCtx routCtx = | |
57 | -- TODO: oooh, this one's gonna be fun too | |
58 | --checkBlock blk progCtx routCtx | |
59 | routCtx | |
60 | checkInstr NOP progCtx routCtx = | |
61 | routCtx | |
62 | ||
63 | checkInstr instr _ _ = error ( | |
64 | "Internal error: sixtypical doesn't know how to " ++ | |
65 | "analyze '" ++ (show instr) ++ "'") | |
85 | Map.foldrWithKey (poison) routCtx calledRoutCtx |
71 | 71 | ((routine':routines'), iid'') |
72 | 72 | |
73 | 73 | numberRoutineLoops :: Routine -> InternalID -> (Routine, InternalID) |
74 | numberRoutineLoops (Routine name instrs) iid = | |
74 | numberRoutineLoops (Routine name outputs instrs) iid = | |
75 | 75 | let |
76 | 76 | (instrs', iid') = numberBlockLoops instrs iid |
77 | 77 | in |
78 | ((Routine name instrs'), iid') | |
78 | ((Routine name outputs instrs'), iid') | |
79 | 79 | |
80 | 80 | numberBlockLoops :: [Instruction] -> InternalID -> ([Instruction], InternalID) |
81 | 81 | numberBlockLoops [] iid = ([], iid) |
25 | 25 | |
26 | 26 | type ProgramContext = Map.Map RoutineName RoutineContext |
27 | 27 | |
28 | -- | |
29 | -- Utility function: | |
30 | -- Take 2 routine contexts -- the current routine and a routine that was just | |
31 | -- JSR'ed to (immediately previously) -- and merge them to create a new | |
32 | -- context for the current routine. | |
33 | -- | |
34 | mergeRoutCtxs routCtx calledRoutCtx = | |
35 | let | |
36 | -- go through all the Usages in the calledRoutCtx | |
37 | -- insert any that were updated, into routCtx | |
38 | poison location usage routCtxAccum = | |
39 | case usage of | |
40 | UpdatedWith ulocation -> | |
41 | Map.insert location (PoisonedWith ulocation) routCtxAccum | |
42 | in | |
43 | Map.foldrWithKey (poison) routCtx calledRoutCtx | |
44 | ||
45 | ||
46 | 28 | ppAnalysis :: ProgramContext -> IO () |
47 | 29 | ppAnalysis progCtx = |
48 | 30 | let |
26 | 26 | emitRoutines p (rout:routs) = |
27 | 27 | emitRoutine p rout ++ "\n" ++ emitRoutines p routs |
28 | 28 | |
29 | emitRoutine p r@(Routine name instrs) = | |
29 | emitRoutine p r@(Routine name _ instrs) = | |
30 | 30 | name ++ ":\n" ++ emitInstrs p r instrs ++ " rts\n" |
31 | 31 | |
32 | 32 | emitInstrs _ _ [] = "" |
77 | 77 | | NOP |
78 | 78 | deriving (Show, Ord, Eq) |
79 | 79 | |
80 | data Routine = Routine RoutineName [Instruction] | |
80 | data Routine = Routine RoutineName [StorageLocation] [Instruction] | |
81 | 81 | deriving (Show, Ord, Eq) |
82 | 82 | |
83 | 83 | data Program = Program [Decl] [Routine] |
89 | 89 | programSummary p@(Program decls routs) = |
90 | 90 | show ((length $ show p) < 99999) |
91 | 91 | |
92 | getRoutineName (Routine name _) = name | |
92 | getRoutineName (Routine name _ _) = name | |
93 | 93 | |
94 | 94 | getDeclLocationName (Assign name _ _) = name |
95 | 95 | getDeclLocationName (Reserve name _) = name |
125 | 125 | mapBlock = map |
126 | 126 | |
127 | 127 | mapRoutine :: (Instruction -> Instruction) -> Routine -> Routine |
128 | mapRoutine f (Routine name instrs) = Routine name (mapBlock f instrs) | |
128 | mapRoutine f (Routine name outputs instrs) = | |
129 | Routine name outputs (mapBlock f instrs) | |
129 | 130 | |
130 | 131 | mapRoutines :: (Instruction -> Instruction) -> [Routine] -> [Routine] |
131 | 132 | mapRoutines f [] = [] |
142 | 143 | foldBlock = foldr |
143 | 144 | |
144 | 145 | foldRoutine :: (Instruction -> a -> a) -> a -> Routine -> a |
145 | foldRoutine f a (Routine name instrs) = | |
146 | foldRoutine f a (Routine name outputs instrs) = | |
146 | 147 | foldBlock f a instrs |
147 | 148 | |
148 | 149 | foldRoutines :: (Instruction -> a -> a) -> a -> [Routine] -> a |
163 | 164 | lookupDecl' (filter (isLocationDecl) decls) name |
164 | 165 | |
165 | 166 | lookupDecl' [] _ = Nothing |
166 | lookupDecl' (decl:decls) name = | |
167 | if | |
168 | (getDeclLocationName decl) == name | |
169 | then | |
170 | Just decl | |
171 | else | |
172 | lookupDecl' decls name | |
167 | lookupDecl' (decl:decls) name | |
168 | | (getDeclLocationName decl) == name = Just decl | |
169 | | otherwise = lookupDecl' decls name | |
170 | ||
171 | lookupRoutine (Program _ routines) name = | |
172 | lookupRoutine' routines name | |
173 | ||
174 | lookupRoutine' [] _ = Nothing | |
175 | lookupRoutine' (rout@(Routine rname _ _):routs) name | |
176 | | rname == name = Just rout | |
177 | | otherwise = lookupRoutine' routs name |
14 | 14 | | "assign" StorageType LocationName Address |
15 | 15 | | "external" RoutineName Address. |
16 | 16 | StorageType := "byte" | "word" | "vector". |
17 | Routine := "routine" RoutineName Block. | |
17 | Routine := "routine" RoutineName ["outputs" "(" {LocationName} ")"] Block. | |
18 | 18 | Block := "{" [Comment] {Command [Comment]} "}". |
19 | 19 | Command := "if" Branch Block "else" Block |
20 | 20 | | "lda" (LocationName | Immediate) |
92 | 92 | string "routine" |
93 | 93 | spaces |
94 | 94 | name <- routineName |
95 | outputs <- (try routine_outputs <|> return []) | |
95 | 96 | instrs <- block |
96 | return (Routine name instrs) | |
97 | return (Routine name outputs instrs) | |
98 | ||
99 | routine_outputs :: Parser [StorageLocation] | |
100 | routine_outputs = do | |
101 | string "outputs" | |
102 | spaces | |
103 | string "(" | |
104 | spaces | |
105 | locations <- many locationName | |
106 | string ")" | |
107 | spaces | |
108 | return (map (\x -> NamedLocation Nothing x) locations) | |
97 | 109 | |
98 | 110 | block :: Parser [Instruction] |
99 | 111 | block = do |