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 *) | |
3b1bffdb SK |
50 | { level : Level.t |
51 | ; access : Frame.access | |
cc540a7e SK |
52 | } |
53 | ||
54 | let alloc_local ~level ~escapes = | |
55 | { level | |
3b1bffdb | 56 | ; access = Frame.alloc_local (Level.frame level) ~escapes |
cc540a7e SK |
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 | 64 | |
3b1bffdb SK |
65 | let not_implemented func = |
66 | failwith (Printf.sprintf "Not implemented: %s.%s" __MODULE__ func) | |
67 | ||
6ca1afb7 SK |
68 | let rec seq = function |
69 | (* TODO: Is appending 0 OK? How else can the empty case be handled? *) | |
70 | | [] -> T.EXP (T.CONST 0) | |
71 | | s :: ss -> T.SEQ (s, seq ss) | |
72 | ||
73 | let cond_stm gen_stm = | |
74 | let t = Temp.Label.gen () in | |
75 | let f = Temp.Label.gen () in | |
76 | let r = Temp.Temp.gen () in | |
77 | let stms = | |
78 | [ T.MOVE (T.TEMP r, T.CONST 1) | |
79 | ; gen_stm (t, f) | |
80 | ; T.LABEL f | |
81 | ; T.MOVE (T.TEMP r, T.CONST 0) | |
82 | ; T.LABEL t | |
83 | ] | |
84 | in | |
85 | (seq stms, T.TEMP r) | |
86 | ||
87 | let unEx = function | |
88 | | Ex exp -> exp | |
89 | | Nx stm -> T.ESEQ (stm, T.CONST 0) | |
90 | | Cx gen -> | |
91 | let stm, exp = cond_stm gen in | |
92 | T.ESEQ (stm, exp) | |
93 | ||
94 | let unNx = function | |
95 | | Ex exp -> T.EXP exp | |
96 | | Nx stm -> stm | |
97 | | Cx gen -> fst (cond_stm gen) | |
98 | ||
99 | let unCx = function | |
100 | (* "should never occur in compiling a well typed Tiger program" p.154 *) | |
101 | | Nx _ -> assert false | |
102 | | Ex e -> fun (_, _) -> T.EXP e (* TODO: Is this right? *) | |
103 | | Cx g -> g | |
104 | ||
105 | let dummy__FIXME = Ex (T.CONST 0) | |
3b1bffdb SK |
106 | |
107 | let simple_var {level; access} = | |
108 | let pointer = not_implemented "simple_var frame pointer" in | |
109 | Ex (Frame.exp ~access ~pointer) |