Dans ce cours on commence la compilation

ast.ml

module IR = struct
  type value =
    | Void
    | Bool of bool
    | Int of int
    | Data of string

  type expr =
    | Value of value
    | Var of string
    | Call of string * expr list

  type instr =
    | Decl of string
    | Assign of string * expr
    | Do of expr (* appel de fonction void *)
    | Return of expr

  type def = Func of string * string list * instr list
  type prog = def list
end

module MIPS = struct
  type reg =
    | Zero
    | SP
    | FP
    | RA
    | V0
    | A0
    | A1
    | T0
    | T1
    | T2

  type label = string

  type loc =
    | Lbl of label
    | Reg of reg
    | Mem of reg * int

  type instr =
    | Label of label
    | Li of reg * int
    | La of reg * loc
    | Sw of reg * loc
    | Lw of reg * loc
    | Sb of reg * loc
    | Lb of reg * loc
    | Move of reg * reg
    | Addi of reg * reg * int
    | Add of reg * reg * reg
    | Mul of reg * reg * reg
    | Syscall
    | B of label
    | Beq of reg * reg * label
    | Bne of reg * reg * label
    | Jal of label
    | Jr of reg

  type directive = Asciiz of string
  type decl = label * directive

  type asm =
    { text : instr list
    ; data : decl list
    }

  module Syscall = struct
    let print_int = 1
    let print_str = 4
    let read_int = 5
    let read_str = 8
  end
end

baselib.ml

open Ast.MIPS
module Env = Map.Make (String)

let _baselib_ =
  [ Label "_add"
  ; Lw (T0, Mem (SP, 4))
  ; Lw (T1, Mem (SP, 0))
  ; Add (V0, T0, T1)
  ; Jr RA
  ; Label "_mul"
  ; Lw (T0, Mem (SP, 4))
  ; Lw (T1, Mem (SP, 0))
  ; Mul (V0, T0, T1)
  ; Jr RA
  ; Label "puti"
  ; Lw (A0, Mem (SP, 0))
  ; Li (V0, Syscall.print_int)
  ; Syscall
  ; Li (V0, 0)
  ; Jr RA
(*   ; Label "puts"
  ; print_string *)
  ; Label "pnl" (* print newline *)
  ; La (A0, Lbl "qlf")
  ; Li (V0, Syscall.print_str)
  ; Syscall
  ; Li (V0, 0)
  ; Jr RA
  ]
;;

compiler.ml

open Ast.IR
open Ast.MIPS
open Baselib

let compile_value = function
  | Void -> [ Li (V0, 0) ]
  | Bool b -> [ Li (V0, if b then 1 else 0) ]
  | Int n -> [ Li (V0, n) ]
  | Data d -> []
;;

let rec compile_expr e env =
  let compile_on_push e =
    (* -4 à chaque argument *)
    compile_expr e env @ [ Addi (SP, SP, -4); Sw (V0, Mem (SP, 0)) ]
  in
  match e with
  | Value v -> compile_value v
  | Var v -> [ Lw (V0, Env.find v env) ]
  | Call (f, args) ->
    let compile_args = List.map compile_on_push args in
    (* +4 à chaque argument *)
    List.flatten compile_args @ [ Jal f; Addi (SP, SP, 4 * List.length args) ]
;;

type info =
  { asm : instr list
  ; env : loc Env.t
  ; fpo : int (* FP offset *)
  }

let compile_instr i info =
  match i with
  | Decl v ->
    { info with env = Env.add v (Mem (FP, -info.fpo)) info.env; fpo = info.fpo + 4 }
  | Assign (v, e) ->
    { info with
      asm = info.asm @ compile_expr e info.env @ [ Sw (V0, Env.find v info.env) ]
    }
  | Do e -> { info with asm = info.asm @ compile_expr e info.env }
  | Return e ->
    { info with
      asm =
        info.asm
        @ compile_expr e info.env
        @ [ Lw (RA, Mem (FP, 0)); Addi (SP, FP, 4); Lw (FP, Mem (FP, -4)); Jr RA ]
    }
;;

let rec compile_block b info =
  match b with
  | [] -> info
  | i :: b -> compile_block b (compile_instr i info)
;;

let compile_def (Func (name, args, body)) =
  let compile_body =
    compile_block
      body
      { asm = []
      ; env =
          List.fold_left
            (fun env (arg, addr) -> Env.add arg addr env)
            Env.empty
            (List.mapi (fun i a -> a, Mem (FP, 4 * (i + 1))) (List.rev args))
      ; fpo = 8
      }
  in
  [ Label name
  ; Addi (SP, SP, -compile_body.fpo)
  ; Sw (RA, Mem (SP, 4))
  ; Sw (FP, Mem (SP, 0))
  ; Addi (FP, SP, 4)
  ]
  @ compile_body.asm
  @ [ Li (V0, 0); Lw (RA, Mem (FP, 0)); Addi (SP, FP, 4); Lw (FP, Mem (FP, -4)); Jr RA ]
;;

let compile ir =
  let asm = List.flatten (List.map compile_def ir) in
  { text = _baselib_ @ asm; data = [ "qlf", Asciiz "\\n" ] }
;;

mips.ml

open Ast.MIPS

let ps = Printf.sprintf (* alias raccourci *)

let fmt_reg = function
  | Zero -> "$zero"
  | SP -> "$sp"
  | FP -> "$fp"
  | RA -> "$ra"
  | V0 -> "$v0"
  | A0 -> "$a0"
  | A1 -> "$a1"
  | T0 -> "$t0"
  | T1 -> "$t1"
  | T2 -> "$t2"
;;

let fmt_loc = function
  | Lbl l -> l
  | Reg r -> fmt_reg r
  | Mem (r, o) -> ps "%d(%s)" o (fmt_reg r)
;;

let fmt_instr = function
  | Label l -> ps "%s:" l
  | Li (r, i) -> ps " li %s, %d" (fmt_reg r) i
  | La (r, a) -> ps " la %s, %s" (fmt_reg r) (fmt_loc a)
  | Sw (r, a) -> ps " sw %s, %s" (fmt_reg r) (fmt_loc a)
  | Lw (r, a) -> ps " lw %s, %s" (fmt_reg r) (fmt_loc a)
  | Sb (r, a) -> ps " sb %s, %s" (fmt_reg r) (fmt_loc a)
  | Lb (r, a) -> ps " lb %s, %s" (fmt_reg r) (fmt_loc a)
  | Move (rd, rs) -> ps " move %s, %s" (fmt_reg rd) (fmt_reg rs)
  | Addi (rd, rs, i) -> ps " addi %s, %s, %d" (fmt_reg rd) (fmt_reg rs) i
  | Add (rd, rs, rt) -> ps " add %s, %s, %s" (fmt_reg rd) (fmt_reg rs) (fmt_reg rt)
  | Mul (rd, rs, rt) -> ps " mul %s, %s, %s" (fmt_reg rd) (fmt_reg rs) (fmt_reg rt)
  | Syscall -> ps " syscall"
  | B l -> ps " b %s" l
  | Beq (rs, rt, l) -> ps " beq %s, %s, %s" (fmt_reg rs) (fmt_reg rt) l
  | Bne (rs, rt, l) -> ps " bne %s, %s, %s" (fmt_reg rs) (fmt_reg rt) l
  | Jal l -> ps " jal %s" l
  | Jr r -> ps " jr %s" (fmt_reg r)
;;

let fmt_dir = function
  | Asciiz s -> ps ".asciiz \"%s\"" s
;;

let print_asm oc asm =
  Printf.fprintf oc ".text\n.globl main\n";
  List.iter (fun i -> Printf.fprintf oc "%s\n" (fmt_instr i)) asm.text;
  Printf.fprintf oc "\n.data\n";
  List.iter (fun (l, d) -> Printf.fprintf oc "%s: %s\n" l (fmt_dir d)) asm.data
;;

test.ml

open Ast

let () =
  let ir =
    [ IR.Func ("main", [], [Decl "a"
    ; Assign ("a", Value (Int 42))
    ; Decl "toto"
    ; Assign ("toto", Call ("_add", [ Var "a"; Value (Int 9) ]))
    ; Do (Call ("puti", [ Var "toto" ]))
    ; Do (Call ("pnl", []))
    ; Return (Var "a")])
    ]
  in
  let asm = Compiler.compile ir in
  Mips.print_asm Stdlib.stdout asm
;;