summaryrefslogtreecommitdiff
path: root/compile.ml
blob: 48d8708a036e1a8c48499b7f4236b3274693d61c (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
(****************************************
    compile.ml - production de code
 ****************************************)

open Format
open Mips
open Ast
open Utils
open Closure
open Optimize
open Primitives
open Mipshelpers

module Smap = Map.Make(String)

type env = { addrs : ident_address Smap.t ;
             fp : int ;
             idents : Sset.t  }
let empty_env = { idents = Sset.empty ; addrs = Smap.empty ; fp = 0 }

let frame_size = ref 0

let next_string_id = ref 1
let next_jump_id = ref 1

let new_primitive_label idents ident =
    let rec aux i =
        let label = Printf.sprintf "%s__%d" ident i
        in
            if Sset.mem label idents then
                aux (i + 1)
            else
                label
    in
        if Sset.mem ident idents then
            aux 0
        else
            ident

let rec new_jump_label env =
    let label = Printf.sprintf "jump___%d" !next_jump_id
    in
        incr next_jump_id;
        if Sset.mem label env.idents then
            new_jump_label env
        else
            label

let rec new_string_label env =
    let label = Printf.sprintf "string___%d" !next_string_id
    in
        incr next_string_id;
        if Sset.mem label env.idents then
            new_string_label env
        else
            label

let assign_ident_to_addr env ident addr =
    { env with addrs = Smap.add ident addr env.addrs }

let push_closure env =
	if !frame_size = env.fp then frame_size := 4 + !frame_size;
    let curr_fp = env.fp
    in
        (-curr_fp, FP),
        [Comment "Push closure address to stack" ;
         Sw (A0, (- curr_fp, FP))],
        { env with fp = env.fp + 4 }

let assign_ident env ident =
	if !frame_size = env.fp then frame_size := 4 + !frame_size;
    let new_addrs = Smap.add ident (Amem (- env.fp, FP)) env.addrs
    and curr_fp = env.fp
    in
        [Comment (Printf.sprintf "Assign %s" ident); Sw (V0, (- curr_fp, FP))],
        { env with addrs = new_addrs ; fp = env.fp + 4 }

let make_base_env idents =
    List.fold_left (fun (base_code, base_register_code, env) ident ->
                        let assign_code, env = assign_ident env ident
                        and label = new_primitive_label idents ident
                        in
                                base_code
                                @
                                [Label label]
                                @
                                (Smap.find ident primitives_map),
                                base_register_code
                                @
                                [Comment (Printf.sprintf "Register %s" ident)]
                                @
                                (primitive_register_code label)
                                @ assign_code,
                                env)
                   ([], [], { empty_env with idents = idents })

let function_header frame_size =
     [Addi (SP, SP, - 12) ;
      Sw (RA, (8, SP)) ;
      Sw (FP, (4, SP)) ;
      Move (FP, SP) ;
      Addi (SP, SP, - frame_size)]

let function_footer frame_size =
    [Addi (SP, SP, frame_size) ;
     Lw (RA, (8, SP)) ;
     Lw (FP, (4, SP)) ;
     Addi (SP, SP, 12) ;
     Jr RA]

let rec assign_motif env m =
    match m.m with
        | Munderscore -> [], env
        | Mident ident -> assign_ident env ident
        | Mtuple l ->
            let i = ref (-1)
            in
                let instrs, env =
                    List.fold_left (fun (base_instrs, env) m ->
                                        let instrs, env2 = assign_motif env m
                                        in
                                            incr i;
                                            (base_instrs
                                             @
                                             [Lw (V0, (0, SP)) ;
                                              Lw (V0, (4 * !i, V0))]
                                             @
                                             instrs, env2))
                                   ([Comment "Assign tuple"]
                                    @
                                    (heap_push 4)
                                    @
                                    [Sw (V0, (0, SP))], env)
                                   l
                in
                    instrs @ (heap_pop 4), env

let ident_to_reg env ident reg =
    try
        match Smap.find ident env.addrs with
            | Alab label -> [Lw_label (reg, label)]
            | Areg rsrc -> [Move (reg, rsrc)]
            | Amem radd -> [Lw (reg, radd)]
            | Aclosure (id, clos_add) ->
                [Lw (reg, clos_add) ;
                 Lw (reg, (id, reg))]
    with Not_found ->
        failwith (Printf.sprintf "ident_to_reg : Unknown ident %s" ident)

(* Compilation des listes :
   allocation d'un bloc de 4 + 4 = 8 octets contenant, en supposant que
   l'adresse soit dans le registre V0, la valeur ou le pointeur de la valeur
   de tête dans 0(V0), et le pointeur vers la queue dans 4(V0) *)
(* Compilation des tuples :
   bloc de 4 * n octets pour un tuple à n éléments *)
(* Cloture :
   bloc de 4 * (n + 1) octets pour n variables à stocker
   Si la cloture correspond à une fonction récursive, elle stocke l'adresse du
   bloc de données dans la cloture elle même *)

(* Compile une expression, et assure que le résultat sera dans V0 *)
let rec compile_expr env expr =
    match expr.e with
        | Econst (Cint c) ->
            [Comment (Printf.sprintf "Load int const %d" c) ;
             Li (V0, c)]
        | Econst (Cstring s) ->
            let label = new_string_label env
            in
                [Comment (Printf.sprintf "Load string %S" s) ;
                 Asciiz (label, s);
                 La (V0, label)]
        | Econst (Cbool true) ->
            [Comment "Load true" ;
             Li (V0, 1)]
        | Econst Cunit ->
            [Comment "Ignoring unit"]
        | Econst (Cbool false)
        | Econst Cemptylist ->
            [Comment "Load false/emptylist" ;
             Li (V0, 0)]
        | Eident ident ->
            let instrs = (ident_to_reg env ident V0)
            in
                (Comment (Printf.sprintf "Load ident %s" ident))::instrs
        | Etuple l ->
            let len = List.length l
            and i = ref (-1)
            in
                [Comment (Printf.sprintf "Compute tuple of length %d" len)]
                @
                malloc (4 * len)
                @
                (heap_push 4)
                @
                [Comment "Store tuple address on the stack";
                 Sw (V0, (0, SP))]
                @
                (List.fold_left (fun base e ->
                                    incr i;
                                    base
                                    @
                                    (compile_expr env e)
                                    @
                                    [Lw (T0, (0, SP)) ;
                                     Sw (V0, (4 * !i, T0))])
                                [] l)
                @
                [Comment "Restore tuple address to V0" ;
                 Lw (V0, (0, SP))]
                @
                (heap_pop 4)
        | Ebinop (e1, o, e2) ->
            [Comment "Binop" ;
             Comment "Compute left member"]
            @
            (compile_expr env e1)
            @
            [Comment "Backup left value"]
            @
            (heap_push 4)
            @
            [Sw (V0, (0, SP)) ;
             Comment "Compute right member"]
            @
            (compile_expr env e2)
            @
            [Comment "Reload left value & compute op" ;
             Lw (A0, (0, SP)) ;
             begin
                match o with
                    | OAdd -> Add (V0, A0, V0)
                    | OSub -> Sub (V0, A0, V0)
                    | OMul -> Mul (V0, A0, V0)
                    | ODiv -> Div (V0, A0, V0)
                    | OAnd -> And (V0, A0, V0)
                    | OOr -> Or (V0, A0, V0)
                    | OEq -> Seq (V0, A0, V0)
                    | ONeq -> Sne (V0, A0, V0)
                    | OLt -> Slt (V0, A0, V0)
                    | OLe -> Sle (V0, A0, V0)
                    | OGt -> Sgt (V0, A0, V0)
                    | OGe -> Sge (V0, A0, V0)
             end]
             @
             (heap_pop 4)
        | Eunop (o, e) ->
            [Comment "Compute unop" ;
             Comment "Compule right member" ;]
            @
            (compile_expr env e)
            @
            [Comment "Apply op" ;
             begin
                match o with
                    | ONot -> Seq (V0, ZERO, V0)
                    | ONeg -> Neg (V0, V0)
             end]
        | Eletin (m, val_expr, body_expr) ->
            let val_instrs = compile_expr env val_expr
            and set_instrs, env2 = assign_motif env m
            in
                [Comment "Letin" ;
                 Comment "Compute value"]
                @
                val_instrs
                @
                [Comment "Assign value"]
                @
                set_instrs
                @
                [Comment "Compute body"]
                @
                (compile_expr env2 body_expr)
        | Eif (cond_expr, then_expr, else_expr) ->
            let else_label = new_jump_label env
            and end_label = new_jump_label env
            in
                [Comment "If" ;
                 Comment "Compute condition"]
                @
                (compile_expr env cond_expr)
                @
                [Comment "If branching" ;
                 Blez (V0, else_label) ;
                 Comment "Compute result (when true)"]
                @
                (compile_expr env then_expr)
                @
                [Comment "Jump towards end-of-if label" ;
                 J end_label ;
                 Comment "Compute result (when false)" ;
                 Label else_label]
                @
                (compile_expr env else_expr)
                @
                [Comment "End-of-if label" ;
                 Label end_label]
        | Elistcons (head_expr, tail_expr) ->
            [Comment "Listcons" ;
             Comment "Compute head"]
            @
            (compile_expr env head_expr)
            @
            (heap_push 8) (* On réserve direct les deux blocs pour backup
                             de la valeur de tête de de queue *)
            @
            [Comment "Store head" ;
             Sw (V0, (4, SP)) ;
             Comment "Compute tail"]
            @
            (compile_expr env tail_expr)
            @
            [Comment "Store tail" ;
             Sw (V0, (0, SP)) ;
             Comment "Allocate list item & set it"]
            @
            (malloc 8)
            @
            [Lw (A1, (0, SP)) ;
             Lw (A0, (4, SP)) ;
             Sw (A0, (0, V0)) ;
             Sw (A1, (4, V0))]
            @
            (heap_pop 8)
        | Ecall (func_expr, arg_expr) ->
            [Comment "Call" ;
             Comment "Compute called expression"]
            @
            (compile_expr env func_expr)
            @
            (push V0)
            @
            [Comment "Compute argument"]
            @
            (compile_expr env arg_expr)
            @
            [Comment "Do the call" ;
             Move (A1, V0)] (* Cloture dans A0, argument dans A1,
                               adresse du bloc de code dans T0 *)
            @
            (pop A0)
            @
            [Lw (T0, (0, A0)) ;
             Jalr T0]
        | Ematch (match_expr, empty_expr, head_m, tail_m, result_expr) ->
            (* Petit trick : a::b est représenté comme (a, b) dans la
               mémoire, abusons donc le processus pour faciliter l'assignation
               Note : on pourrait (en plus) remplacer le match par un if
               bien placé, mais ça serait vraiment coquin *)
            let empty_label = new_jump_label env
            and end_label = new_jump_label env
            and set_instrs, env2 = assign_motif env
                                                (raw_motif (Mtuple [head_m ;
                                                                    tail_m]))
            in
                [Comment "Match" ;
                 Comment "Compute matched expr"]
                @
                (compile_expr env match_expr)
                @
                [Comment "Match branching" ;
                 Blez (V0, empty_label) ;
                 Comment "Set when non-empty list"]
                @
                set_instrs
                @
                [Comment "Compute result (when non-empty list)"]
                @
                (compile_expr env2 result_expr)
                @
                [Comment "Jump towards end of match" ;
                 J end_label ;
                 Comment "Compute result (when empty list)" ;
                 Label empty_label]
                @
                (compile_expr env empty_expr)
                @
                [Comment "End-of-match label" ;
                 Label end_label]
        | Efunc _ -> failwith "compile_expr : Unreachable matching"
        | Eclos (recursive, fname, vars) ->
            (* i -> référence utilisée par le folder pour la position dans le
               bloc de la cloture *)
            (* env : si la fonction est récursive, on ajoute le nom de la
               fonction à l'environnement avec pour adresse le champ V0,
               qui contient l'adresse du bloc mémoire de la cloture *)
            let i = ref 0
            and env = if not recursive then env
                      else assign_ident_to_addr env fname (Areg V0)
            in
                [Comment (Printf.sprintf "Closure %s" fname)]
                @
                (malloc (4 * ((List.length vars) + 1)))
                @
                (List.fold_left (fun base ident ->
                                    incr i;
                                    base
                                    @
                                    (ident_to_reg env ident T1)
                                    @
                                    [Sw (T1, (4 * !i, V0))])
                                [La (T1, fname) ;
                                 Sw (T1, (0, V0))]
                                vars)
and compile_letfuns env = function
    | [] -> []
    | (fname, fvars, farg, fbody)::l ->
        let i = ref 0
        in
            let closure_addr, assign_closure_instrs, env2 =
                push_closure empty_env
            in
                let env_folder env ident =
                    incr i;
                    assign_ident_to_addr env
                                         ident
                                         (Aclosure (4 * !i, closure_addr))
                in
                    let env2 =
                        List.fold_left env_folder env2 fvars
                    in
                        let assign_instrs, env2 = assign_motif env2 farg
                        in
                            let compiled_body = compile_expr env2 fbody
                            in
                                [Label fname]
                                @
                                (function_header !frame_size)
                                @
                                assign_closure_instrs
                                @
                                [Move (V0, A1)]
                                @
                                assign_instrs
                                @
                                compiled_body
                                @
                                (function_footer !frame_size)
                                @
                                (compile_letfuns env l)

(* Ces deux helpers sont fonctions pour que frame_size ait été calculé 
   au moment de l'écriture de ces blocs de code *)
let header_code () =
    [Label "main" ;
     Move (FP, SP) ;
     Addi (SP, SP, -(!frame_size)) ;
     Move (T9, RA)]
and footer_code () =
    [Move (RA, T9) ;
     Addi (SP, SP, !frame_size) ;
     Jr (RA)]

(* La fonction-main-hyper-indentée :
   Prend un argument un ast a, un fichier de sortie ofile et le paramètre
   verbose assembly 
   Opérations réalisées, dans l'ordre :
   * détermination des identifiants de l'arbre
   * détermination des primitives potentiellement utilisées
   * optimisation de l'ast (effectue les calculs constants, etc)
   * remplacements des fonctions par des clotures et des letfuns
   * génération des codes des primitives et création de l'environnement de base
   * compilation de l'ast et des letfuns
   * génération du header et du footer du programme, concaténation des diverses
     listes d'instructions dans le bon ordre
   * filtrage du programme (sépare les data des instructions)
   * optimisations éventuelles (factorise les addi consécutifs, par exemple)
   * suppression éventuelle des commentaires, si "not verbose_assembly"
   * écriture de l'assembleur dans le fichier ofile
   Ouf, fini ! *)
let compile a ofile verbose_assembly =
    let idents = identifiers a
    in
        let primitives = in_use_primitives idents
        in
            let a, letfuns = replace_funcs idents (optimize_ast a)
            and primitives_code, primitives_register_code, env =
                make_base_env idents primitives
            in
                let compiled_letfuns, compiled_exprs =
                    (compile_letfuns env letfuns), (compile_expr env a)
                and f = open_out ofile
                in
                    let program = (compiled_letfuns @ primitives_code
                                @ (header_code ()) @ primitives_register_code
                                @ compiled_exprs @ (footer_code ()))
                    and fmt = formatter_of_out_channel f
                    in
                        let program = optimize_program (filter_program program)
                        in
                            let program =
                                { program with
                                  text = if verbose_assembly then program.text
                                         else filter_comments program.text }
                            in
                                format_program fmt program;
                                fprintf fmt "@?";
                                close_out f