git @ Cat's Eye Technologies SixtyPical / 650405c
Initial import. Cat's Eye Technologies 11 years ago
5 changed file(s) with 302 addition(s) and 0 deletion(s). Raw diff Collapse all Expand all
+5
-0
.hgignore less more
0 syntax: glob
1
2 *.o
3 *.hi
4 bin/*
+4
-0
build.sh less more
0 #!/bin/sh
1
2 mkdir -p bin
3 ghc src/Main.hs -o bin/sixtypical
+14
-0
eg/compare.60pical less more
0 reserve byte m_high
1 reserve byte m_low
2 reserve byte n_high
3 reserve byte n_low
4
5 routine compare_16_bit {
6 lda m_high
7 cmp n_high
8 beq {
9 lda m_low
10 cmp n_low
11 } else {
12 }
13 }
+19
-0
eg/simple.60pical less more
0 assign word fnord 4000
1 assign byte blerf 4002
2
3 reserve byte foo
4 reserve word bar
5
6 routine hello {
7 lda fnord
8 cmp blerf
9 lda foo
10 }
11
12 routine bye {
13 lda fnord
14 cmp bar
15 }
16
17 routine byee {
18 }
+260
-0
src/Main.hs less more
0 -- encoding: UTF-8
1
2 module Main where
3 --module Sixtype where
4
5 import qualified Data.Map as Map
6
7 import System.IO
8 import System.Environment
9 import System.Exit
10
11 import Text.ParserCombinators.Parsec
12
13 -- -- -- -- machine model -- -- -- --
14
15 type Address = Int -- LET'S ASSUME THIS IS AT LEAST 16 BITS
16
17 type LocationName = String
18
19 data Register = A | X | Y -- | MemLoc LocationName
20 deriving (Show, Ord, Eq)
21
22 allRegisters = [A, X, Y]
23
24 -- -- -- -- program model -- -- -- --
25
26 data Size = Byte
27 | Word
28 deriving (Show, Ord, Eq)
29
30 data Decl = Assign LocationName Size Address -- .alias
31 | Reserve LocationName Size -- .word, .byte
32 deriving (Show, Ord, Eq)
33
34 type RoutineName = String
35
36 data Instruction = LOAD Register LocationName
37 | COPY Register Register
38 | CMP Register LocationName
39 | JSR RoutineName
40 | IFEQ [Instruction] [Instruction]
41 | NOP
42 deriving (Show, Ord, Eq)
43
44 data Routine = Routine RoutineName [Instruction]
45 deriving (Show, Ord, Eq)
46
47 data Program = Program [Decl] [Routine]
48 deriving (Show, Ord, Eq)
49
50 -- -- -- -- data-flow-analysis context -- -- -- --
51
52 data Usage = Unknown
53 | Value LocationName -- obviously a bit daft for now
54 | Retained Register
55 deriving (Show, Ord, Eq)
56
57 type RoutineContext = Map.Map Register Usage
58
59 type ProgramContext = Map.Map RoutineName RoutineContext
60
61 --
62 -- Utility function:
63 -- Take 2 routine contexts -- the current routine and a routine that was just
64 -- JSR'ed to (immediately previously) -- and merge them to create a new
65 -- context for the current routine.
66 --
67 mergeRoutCtxs routCtx calledRoutCtx =
68 let
69 -- insert the values into routCtx
70 -- TODO, first compare them
71 -- TODO, if not equal, 'poison' them
72 -- TODO, other special cases (eg Unknown)
73 poison key value routCtxAccum =
74 case value of
75 -- if the called routine retains it,
76 -- we keep our idea of it -- but TODO
77 -- should we mark it "was retained"?
78 Retained reg ->
79 routCtxAccum
80 _ ->
81 Map.insert key value routCtxAccum
82 in
83 Map.foldrWithKey (poison) routCtx calledRoutCtx
84
85 -- -- -- -- static analyzer -- -- -- --
86
87 checkProgram (Program decls routines) =
88 checkRoutines routines Map.empty
89
90 checkRoutines [] progCtx = progCtx
91 checkRoutines (rout@(Routine name _) : routs) progCtx =
92 let
93 routCtx = Map.fromList $ map (\reg -> (reg, Retained reg)) allRegisters
94 routAnalysis = checkRoutine rout progCtx routCtx
95 progCtx' = Map.insert name routAnalysis progCtx
96 in
97 checkRoutines routs progCtx'
98
99 checkRoutine (Routine _ []) progCtx routCtx = routCtx
100 checkRoutine (Routine name (instr : instrs)) progCtx routCtx =
101 let
102 routCtx' = checkInstr instr progCtx routCtx
103 in
104 checkRoutine (Routine name instrs) progCtx routCtx'
105
106 checkInstr (LOAD reg addr) progCtx routCtx =
107 Map.insert reg (Value addr) routCtx
108 checkInstr (COPY src dst) progCtx routCtx =
109 Map.insert dst (Map.findWithDefault Unknown src routCtx) routCtx
110 checkInstr (JSR name) progCtx routCtx =
111 case Map.lookup name progCtx of
112 Just calledRoutCtx ->
113 mergeRoutCtxs routCtx calledRoutCtx
114 Nothing ->
115 error ("can't call routine '" ++ name ++ "' before it is defined")
116 checkInstr (CMP reg addr) progCtx routCtx =
117 -- TODO: mark Carry bit as "touched" here
118 routCtx
119 checkInstr (IFEQ b1 b2) progCtx routCtx =
120 -- TODO: oooh, this one's gonna be fun
121 routCtx
122 checkInstr NOP progCtx routCtx =
123 routCtx
124
125 -- -- -- -- parser -- -- -- --
126 {-
127
128 Toplevel := {Decl} {Routine}.
129 Decl := "reserve" Size LocationName
130 | "assign" Size LocationName Address.
131 Size := "byte" | "word".
132 Routine := "routine" RoutineName Block.
133 Block := "{" {Command} "}".
134 Command := "beq" Block "else" Block
135 | "lda" (LocationName | Immediate)
136 | "txa" | "tax" | "tya" | "tay"
137 | "cmp" (LocationName | Immediate)
138
139 -}
140
141 toplevel :: Parser Program
142 toplevel = do
143 decls <- many (assign <|> try reserve)
144 routines <- many routine
145 return $ Program decls routines
146
147 reserve :: Parser Decl
148 reserve = do
149 string "reserve"
150 spaces
151 sz <- size
152 spaces -- size does not do its own spacesising
153 name <- locationName
154 return $ Reserve name sz
155
156 assign :: Parser Decl
157 assign = do
158 string "assign"
159 spaces
160 sz <- size
161 spaces -- size does not do its own spacesising
162 name <- locationName
163 addr <- address
164 return $ Assign name sz addr
165
166 size :: Parser Size
167 size = do
168 s <- (string "byte") <|> (string "word")
169 return $ case s of
170 "byte" -> Byte
171 "word" -> Word
172
173 routine :: Parser Routine
174 routine = do
175 string "routine"
176 spaces
177 name <- routineName
178 instrs <- block
179 return (Routine name instrs)
180
181 block :: Parser [Instruction]
182 block = do
183 string "{"
184 spaces
185 cs <- many command
186 string "}"
187 spaces
188 return cs
189
190 command :: Parser Instruction
191 command = cmp <|> lda <|> beq
192
193 cmp :: Parser Instruction
194 cmp = do
195 string "cmp"
196 spaces
197 l <- locationName
198 return (CMP A l)
199
200 lda :: Parser Instruction
201 lda = do
202 string "lda"
203 spaces
204 l <- locationName
205 return (LOAD A l)
206
207 beq :: Parser Instruction
208 beq = do
209 string "beq"
210 spaces
211 b1 <- block
212 string "else"
213 spaces
214 b2 <- block
215 return (IFEQ b1 b2)
216
217 routineName :: Parser String
218 routineName = do
219 c <- letter
220 cs <- many (alphaNum <|> char '_')
221 spaces
222 return (c:cs)
223
224 locationName :: Parser String
225 locationName = do
226 c <- letter
227 cs <- many (alphaNum <|> char '_')
228 spaces
229 return (c:cs)
230
231 address :: Parser Address
232 address = do
233 digits <- many digit
234 spaces
235 return (read digits :: Address)
236
237 -- -- -- -- driver -- -- -- --
238
239 main = do
240 args <- getArgs
241 case args of
242 [filename] -> do
243 programText <- readFile filename
244 case parse toplevel "" programText of
245 Right program -> do
246 putStrLn $ show $ program
247 putStrLn $ show $ checkProgram program
248 Left problem -> do
249 hPutStrLn stderr (show problem)
250 exitWith $ ExitFailure 1
251 _ -> do
252 putStrLn "Usage: sixtypical filename.60pical"
253 exitWith $ ExitFailure 1
254
255 {-
256 test = checkProgram [(Routine "wait" [LOAD Y "score", COPY Y A]),
257 (Routine "main" [LOAD X "score", JSR "wait"])]
258 Map.empty
259 -}