Dans ce cours on ajoute la gestion des strings

ast.ml

(* Ça c'est un type de module qui DOIT
 * implémenter un type value, sig = signature *)
module type Param = sig
  type value
end

(* Value1 *)
module V1 = struct
  type value =
    | Void
    | Bool of bool
    | Int of int
    | Str of string
end

(* Value2 *)
module V2 = struct
  type value =
    | Void
    | Bool of bool
    | Int of int
    | Data of string
end

(* Le module IR prend
 * un Paramètre en argument *)
module IR (P : Param) = struct
  (* Ici, value est définie via P *)

  type expr =
    | Value of P.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 IR1 = IR (V1)
module IR2 = IR (V2)

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.IR2
open Ast.V2
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 l -> [ La (V0, Lbl l) ]
;;

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 (ir2, cs) =
  let asm = List.flatten (List.map compile_def ir2) in
  { text = _baselib_ @ asm; data = [ "qlf", Asciiz "\\n" ] @ cs }
;;

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
;;

simplifier.ml

open Ast

let collect_constant_strings code =
  let counter = ref 0 in
  let ccs_value = function
    | V1.Void -> V2.Void, []
    | V1.Bool b -> V2.Bool b, []
    | V1.Int n -> V2.Int n, []
    | V1.Str s ->
      incr counter;
      let lbl = "str" ^ string_of_int !counter in
      V2.Data lbl, [ lbl, MIPS.Asciiz s ]
  in
  let rec ccs_expr = function
    | IR1.Value v ->
      let v2, cs = ccs_value v in
      IR2.Value v2, cs
    | IR1.Var v -> IR2.Var v, []
    | IR1.Call (fn, args) ->
      let a2 = List.map ccs_expr args in
      IR2.Call (fn, List.map fst a2), List.flatten (List.map snd a2)
  in
  let ccs_instr = function
    | IR1.Decl v -> IR2.Decl v, []
    | IR1.Assign (v, e) ->
      let e2, cs = ccs_expr e in
      IR2.Assign (v, e2), cs
    | IR1.Do e ->
      let e2, cs = ccs_expr e in
      IR2.Do e2, cs
    | IR1.Return e ->
      let e2, cs = ccs_expr e in
      IR2.Do e2, cs
  in
  let rec ccs_block acc_b acc_cs = function
    | i :: b ->
      let i2, cs = ccs_instr i in
      ccs_block (i2 :: acc_b) (cs @ acc_cs) b
    | [] -> List.rev acc_b, acc_cs
  in
  let ccs_def (IR1.Func (name, args, body)) =
    let body2, cs = ccs_block [] [] body in
    IR2.Func (name, args, body2), cs
  in
  let code2 = List.map ccs_def code in
  List.map fst code2, List.flatten (List.map snd code2)
;;

let simplify ir = collect_constant_strings ir

test.ml

open Ast
open Simplifier

let () =
  let ir =
    [ IR1.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 (simplify ir) in
  Mips.print_asm Stdlib.stdout asm
;;

J’utilises le même Makefile que le cours d’avant (toujours aussi moche)

Makefile

main:
	clear
	ocamlopt *.ml
	rm *.o *.cmx *.out
	ocamlbuild -no-hygiene test.byte
	./test.byte > test.s
	spim -file test.s
	rm test.byte