git @ Cat's Eye Technologies SixtyPical / 64e50a9
Routines can declare their outputs now. Cat's Eye Technologies 8 years ago
7 changed file(s) with 144 addition(s) and 85 deletion(s). Raw diff Collapse all Expand all
5858 = update_score
5959 = X: UpdatedWith (Immediate 1)
6060 = 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
88
99 -- -- -- -- abstract interpreter -- -- -- --
1010
11 analyzeProgram (Program decls routines) =
11 analyzeProgram program@(Program decls routines) =
1212 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) ++ "'")
1369
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 _) =
1677 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
2084 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
7171 ((routine':routines'), iid'')
7272
7373 numberRoutineLoops :: Routine -> InternalID -> (Routine, InternalID)
74 numberRoutineLoops (Routine name instrs) iid =
74 numberRoutineLoops (Routine name outputs instrs) iid =
7575 let
7676 (instrs', iid') = numberBlockLoops instrs iid
7777 in
78 ((Routine name instrs'), iid')
78 ((Routine name outputs instrs'), iid')
7979
8080 numberBlockLoops :: [Instruction] -> InternalID -> ([Instruction], InternalID)
8181 numberBlockLoops [] iid = ([], iid)
2525
2626 type ProgramContext = Map.Map RoutineName RoutineContext
2727
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
4628 ppAnalysis :: ProgramContext -> IO ()
4729 ppAnalysis progCtx =
4830 let
2626 emitRoutines p (rout:routs) =
2727 emitRoutine p rout ++ "\n" ++ emitRoutines p routs
2828
29 emitRoutine p r@(Routine name instrs) =
29 emitRoutine p r@(Routine name _ instrs) =
3030 name ++ ":\n" ++ emitInstrs p r instrs ++ " rts\n"
3131
3232 emitInstrs _ _ [] = ""
7777 | NOP
7878 deriving (Show, Ord, Eq)
7979
80 data Routine = Routine RoutineName [Instruction]
80 data Routine = Routine RoutineName [StorageLocation] [Instruction]
8181 deriving (Show, Ord, Eq)
8282
8383 data Program = Program [Decl] [Routine]
8989 programSummary p@(Program decls routs) =
9090 show ((length $ show p) < 99999)
9191
92 getRoutineName (Routine name _) = name
92 getRoutineName (Routine name _ _) = name
9393
9494 getDeclLocationName (Assign name _ _) = name
9595 getDeclLocationName (Reserve name _) = name
125125 mapBlock = map
126126
127127 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)
129130
130131 mapRoutines :: (Instruction -> Instruction) -> [Routine] -> [Routine]
131132 mapRoutines f [] = []
142143 foldBlock = foldr
143144
144145 foldRoutine :: (Instruction -> a -> a) -> a -> Routine -> a
145 foldRoutine f a (Routine name instrs) =
146 foldRoutine f a (Routine name outputs instrs) =
146147 foldBlock f a instrs
147148
148149 foldRoutines :: (Instruction -> a -> a) -> a -> [Routine] -> a
163164 lookupDecl' (filter (isLocationDecl) decls) name
164165
165166 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
1414 | "assign" StorageType LocationName Address
1515 | "external" RoutineName Address.
1616 StorageType := "byte" | "word" | "vector".
17 Routine := "routine" RoutineName Block.
17 Routine := "routine" RoutineName ["outputs" "(" {LocationName} ")"] Block.
1818 Block := "{" [Comment] {Command [Comment]} "}".
1919 Command := "if" Branch Block "else" Block
2020 | "lda" (LocationName | Immediate)
9292 string "routine"
9393 spaces
9494 name <- routineName
95 outputs <- (try routine_outputs <|> return [])
9596 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)
97109
98110 block :: Parser [Instruction]
99111 block = do