Commit | Line | Data |
---|---|---|
cc540a7e SK |
1 | module List = ListLabels |
2 | ||
3 | module Frame = Tiger_frame | |
4 | module Temp = Tiger_temp | |
6ca1afb7 | 5 | module T = Tiger_tree |
cc540a7e SK |
6 | |
7 | module Level = struct | |
8 | type t = | |
9 | { parent : t option | |
10 | ; name : Temp.Label.t | |
11 | ; formals : bool list | |
12 | ; frame : Frame.t | |
13 | } | |
14 | ||
15 | let init = | |
16 | let name = Temp.Label.gen () in | |
17 | let formals = [] in | |
18 | { parent = None | |
19 | ; name | |
20 | ; formals | |
21 | ; frame = Frame.make ~name ~formals | |
22 | } | |
23 | ||
24 | let next t ~name ~formals = | |
25 | (* Adding the extra parameter for the static link. See p. 142 *) | |
26 | let formals = true :: formals in | |
27 | { parent = Some t | |
28 | ; name | |
29 | ; formals | |
30 | ; frame = Frame.make ~name ~formals | |
31 | } | |
32 | ||
33 | let formals = function {formals; _} -> | |
34 | formals | |
35 | ||
36 | let frame = function {frame; _} -> | |
37 | frame | |
38 | end | |
39 | ||
6ca1afb7 SK |
40 | type gen_stm = |
41 | (Tiger_temp.Label.t * Tiger_temp.Label.t) -> Tiger_tree.stm | |
42 | ||
43 | type exp = | |
44 | | Ex of Tiger_tree.exp | |
45 | | Nx of Tiger_tree.stm | |
46 | | Cx of gen_stm | |
cc540a7e SK |
47 | |
48 | type access = | |
49 | (* must know about static links *) | |
50 | { level : Level.t | |
51 | ; frame_access : Frame.access | |
52 | } | |
53 | ||
54 | let alloc_local ~level ~escapes = | |
55 | { level | |
56 | ; frame_access = Frame.alloc_local (Level.frame level) ~escapes | |
57 | } | |
58 | ||
59 | let formals ~level = | |
60 | (* FIXME: This seems wrong. Should we call Frame.formals? *) | |
61 | List.map (Level.formals level) ~f:(fun escapes -> | |
62 | alloc_local ~level ~escapes | |
63 | ) | |
6ca1afb7 SK |
64 | |
65 | let rec seq = function | |
66 | (* TODO: Is appending 0 OK? How else can the empty case be handled? *) | |
67 | | [] -> T.EXP (T.CONST 0) | |
68 | | s :: ss -> T.SEQ (s, seq ss) | |
69 | ||
70 | let cond_stm gen_stm = | |
71 | let t = Temp.Label.gen () in | |
72 | let f = Temp.Label.gen () in | |
73 | let r = Temp.Temp.gen () in | |
74 | let stms = | |
75 | [ T.MOVE (T.TEMP r, T.CONST 1) | |
76 | ; gen_stm (t, f) | |
77 | ; T.LABEL f | |
78 | ; T.MOVE (T.TEMP r, T.CONST 0) | |
79 | ; T.LABEL t | |
80 | ] | |
81 | in | |
82 | (seq stms, T.TEMP r) | |
83 | ||
84 | let unEx = function | |
85 | | Ex exp -> exp | |
86 | | Nx stm -> T.ESEQ (stm, T.CONST 0) | |
87 | | Cx gen -> | |
88 | let stm, exp = cond_stm gen in | |
89 | T.ESEQ (stm, exp) | |
90 | ||
91 | let unNx = function | |
92 | | Ex exp -> T.EXP exp | |
93 | | Nx stm -> stm | |
94 | | Cx gen -> fst (cond_stm gen) | |
95 | ||
96 | let unCx = function | |
97 | (* "should never occur in compiling a well typed Tiger program" p.154 *) | |
98 | | Nx _ -> assert false | |
99 | | Ex e -> fun (_, _) -> T.EXP e (* TODO: Is this right? *) | |
100 | | Cx g -> g | |
101 | ||
102 | let dummy__FIXME = Ex (T.CONST 0) |