|
0 |
-- encoding: UTF-8
|
|
1 |
|
|
2 |
module SixtyPical.Transformer (
|
|
3 |
numberProgramLoops, fillOutNamedLocationTypes,
|
|
4 |
renameBlockDecls, liftBlockDecls
|
|
5 |
) where
|
|
6 |
|
|
7 |
import SixtyPical.Model
|
|
8 |
|
|
9 |
-- -- -- -- -- --
|
|
10 |
|
|
11 |
-- in the following "number" means "assign a unique ID to" and "loop"
|
|
12 |
-- means "REPEAT or IF" (because i'm in such a good mood)
|
|
13 |
|
|
14 |
numberProgramLoops :: Program -> Program
|
|
15 |
numberProgramLoops (Program decls routines) =
|
|
16 |
let
|
|
17 |
(routines', _) = numberRoutinesLoops routines 0
|
|
18 |
in
|
|
19 |
(Program decls routines')
|
|
20 |
|
|
21 |
numberRoutinesLoops :: [Routine] -> InternalID -> ([Routine], InternalID)
|
|
22 |
numberRoutinesLoops [] iid = ([], iid)
|
|
23 |
numberRoutinesLoops (routine:routines) iid =
|
|
24 |
let
|
|
25 |
(routine', iid') = numberRoutineLoops routine iid
|
|
26 |
(routines', iid'') = numberRoutinesLoops routines iid'
|
|
27 |
in
|
|
28 |
((routine':routines'), iid'')
|
|
29 |
|
|
30 |
numberRoutineLoops :: Routine -> InternalID -> (Routine, InternalID)
|
|
31 |
numberRoutineLoops (Routine name outputs block) iid =
|
|
32 |
let
|
|
33 |
(block', iid') = numberBlockLoops block iid
|
|
34 |
in
|
|
35 |
((Routine name outputs block'), iid')
|
|
36 |
|
|
37 |
numberBlockLoops :: Block -> InternalID -> (Block, InternalID)
|
|
38 |
numberBlockLoops block iid =
|
|
39 |
let
|
|
40 |
(Block decls instrs) = block
|
|
41 |
(instrs', iid') = numberInstrsLoops instrs iid
|
|
42 |
block' = Block decls instrs'
|
|
43 |
in
|
|
44 |
(block', iid')
|
|
45 |
|
|
46 |
numberInstrsLoops :: [Instruction] -> InternalID -> ([Instruction], InternalID)
|
|
47 |
numberInstrsLoops [] iid = ([], iid)
|
|
48 |
numberInstrsLoops (instr:instrs) iid =
|
|
49 |
let
|
|
50 |
(instr', iid') = numberInstruction instr iid
|
|
51 |
(instrs', iid'') = numberInstrsLoops instrs iid'
|
|
52 |
in
|
|
53 |
((instr':instrs'), iid'')
|
|
54 |
|
|
55 |
numberInstruction :: Instruction -> InternalID -> (Instruction, InternalID)
|
|
56 |
numberInstruction (IF _ branch b1 b2) iid =
|
|
57 |
let
|
|
58 |
(b1', iid') = numberBlockLoops b1 iid
|
|
59 |
(b2', iid'') = numberBlockLoops b2 iid'
|
|
60 |
newIid = iid'' + 1
|
|
61 |
newInstr = IF newIid branch b1' b2'
|
|
62 |
in
|
|
63 |
(newInstr, newIid)
|
|
64 |
numberInstruction (REPEAT _ branch blk) iid =
|
|
65 |
let
|
|
66 |
(blk', iid') = numberBlockLoops blk iid
|
|
67 |
newIid = iid' + 1
|
|
68 |
newInstr = REPEAT newIid branch blk'
|
|
69 |
in
|
|
70 |
(newInstr, newIid)
|
|
71 |
numberInstruction i iid = (i, iid)
|
|
72 |
|
|
73 |
-- -- --
|
|
74 |
|
|
75 |
fillOutNamedLocationTypes p@(Program decls routines) =
|
|
76 |
mapProgramRoutines (xform) p
|
|
77 |
where
|
|
78 |
xform (COPY src dest) =
|
|
79 |
typeMatch src dest (COPY)
|
|
80 |
xform (CMP dest other) =
|
|
81 |
typeMatch dest other (CMP)
|
|
82 |
xform (ADD dest other) =
|
|
83 |
typeMatch dest other (ADD)
|
|
84 |
xform (AND dest other) =
|
|
85 |
typeMatch dest other (AND)
|
|
86 |
xform (SUB dest other) =
|
|
87 |
typeMatch dest other (SUB)
|
|
88 |
xform (OR dest other) =
|
|
89 |
typeMatch dest other (OR)
|
|
90 |
xform (JMPVECTOR dest) =
|
|
91 |
case (resolve dest) of
|
|
92 |
d@(NamedLocation (Just Vector) _) ->
|
|
93 |
JMPVECTOR d
|
|
94 |
_ ->
|
|
95 |
error ("jmp to non-vector '" ++ (show dest) ++ "'")
|
|
96 |
xform (IF iid branch b1 b2) =
|
|
97 |
IF iid branch (mapBlock xform b1) (mapBlock xform b2)
|
|
98 |
xform (REPEAT iid branch blk) =
|
|
99 |
REPEAT iid branch (mapBlock xform blk)
|
|
100 |
xform (DELTA dest val) =
|
|
101 |
DELTA (resolve dest) val
|
|
102 |
xform (WITH SEI blk) =
|
|
103 |
WITH SEI (mapBlock xform blk)
|
|
104 |
xform (WITH (PUSH val) blk) =
|
|
105 |
WITH (PUSH (resolve val)) (mapBlock xform blk)
|
|
106 |
xform (COPYROUTINE name dest) =
|
|
107 |
COPYROUTINE name (resolve dest)
|
|
108 |
xform other =
|
|
109 |
other
|
|
110 |
getType (NamedLocation (Just t) _) = t
|
|
111 |
getType A = Byte
|
|
112 |
getType X = Byte
|
|
113 |
getType Y = Byte
|
|
114 |
getType (Immediate x) =
|
|
115 |
if x > 255 then Word else Byte
|
|
116 |
getType _ = Byte
|
|
117 |
typeMatch x y constructor =
|
|
118 |
let
|
|
119 |
rx = resolve x
|
|
120 |
ry = resolve y
|
|
121 |
typeRx = getType rx
|
|
122 |
typeRy = getType ry
|
|
123 |
in
|
|
124 |
case (typeRx == typeRy, typeRx, typeRy) of
|
|
125 |
(True, _, _) -> constructor rx ry
|
|
126 |
(_, Byte, (ByteTable _)) -> constructor rx ry
|
|
127 |
(_, (ByteTable _), Byte) -> constructor rx ry
|
|
128 |
_ -> error ("incompatible types '" ++ (show typeRx) ++ "' and '" ++ (show typeRy) ++ "'")
|
|
129 |
resolve (NamedLocation Nothing name) =
|
|
130 |
case lookupDecl p name of
|
|
131 |
Just decl ->
|
|
132 |
(NamedLocation (Just $ getDeclLocationType decl) name)
|
|
133 |
_ ->
|
|
134 |
error ("undeclared location '" ++ name ++ "'")
|
|
135 |
resolve (Indirect loc) =
|
|
136 |
(Indirect (resolve loc))
|
|
137 |
resolve (Indexed loc reg) =
|
|
138 |
(Indexed (resolve loc) (resolve reg))
|
|
139 |
resolve (IndirectIndexed loc reg) =
|
|
140 |
(IndirectIndexed (resolve loc) (resolve reg))
|
|
141 |
resolve other =
|
|
142 |
other
|
|
143 |
|
|
144 |
-- -- -- -- --
|
|
145 |
|
|
146 |
-- TODO: look at all blocks, not just routine's blocks
|
|
147 |
renameBlockDecls (Program decls routines) =
|
|
148 |
let
|
|
149 |
routines' = map renameRoutineDecls routines
|
|
150 |
in
|
|
151 |
Program decls routines'
|
|
152 |
where
|
|
153 |
renameRoutineDecls (Routine name outputs block) =
|
|
154 |
let
|
|
155 |
(Block decls _) = block
|
|
156 |
block' = foldDeclsRenaming decls block
|
|
157 |
in
|
|
158 |
(Routine name outputs block')
|
|
159 |
|
|
160 |
-- TODO will have to return new decls too
|
|
161 |
-- TODO will have to take accumulator too
|
|
162 |
-- TODO accumulator has to range across all routines too!
|
|
163 |
foldDeclsRenaming [] block = block
|
|
164 |
foldDeclsRenaming ((Reserve name typ Nothing):decls) block =
|
|
165 |
let
|
|
166 |
newName = "_temp_1" -- TODO base this on accumulator
|
|
167 |
block' = mapBlockNames name newName block
|
|
168 |
in
|
|
169 |
foldDeclsRenaming decls block'
|
|
170 |
|
|
171 |
mapBlockNames n1 n2 (Block decls instrs) =
|
|
172 |
(Block decls $ mapInstrsNames n1 n2 instrs)
|
|
173 |
|
|
174 |
-- TODO: write this
|
|
175 |
mapInstrsNames n1 n2 instrs = instrs
|
|
176 |
|
|
177 |
-- -- -- --
|
|
178 |
|
|
179 |
-- TODO: look at all blocks, not just routine's blocks
|
|
180 |
liftBlockDecls (Program decls routines) =
|
|
181 |
let
|
|
182 |
liftedDecls = foldr getRoutinesBlockDecls [] routines
|
|
183 |
in
|
|
184 |
Program (decls ++ liftedDecls) routines
|
|
185 |
where
|
|
186 |
getRoutinesBlockDecls (Routine name outputs block) a =
|
|
187 |
a ++ (getBlockDecls block)
|
|
188 |
getBlockDecls (Block decls instrs) =
|
|
189 |
decls
|