open Format
open X86_64
open Ast

(* phase 1 : allocation des variables *)

exception VarUndef of string

let (genv : (string, unit) Hashtbl.t) = Hashtbl.create 17

module Smap = Map.Make(String)

type local_env = ident Smap.t

let rec alloc_expr env next = function
  | PCst i ->
    Cst i, next

  | PVar x ->
    begin
      try
        let ofs_x = Smap.find x env in
        LVar ofs_x, next
      with Not_found ->
        if not (Hashtbl.mem genv x) then raise (VarUndef x);
        GVar x, next
    end

  | PBinop (o, e1, e2)->
    let e1, fpmax1 = alloc_expr env next e1 in
    let e2, fpmax2 = alloc_expr env next e2 in
    Binop(o, e1, e2), (max fpmax1 fpmax2)

  | PLetin (x,e1,e2) ->
    let e1, fpmax1 = alloc_expr env next e1 in
    let next = next + 8 in
    let e2, fpmax2 = alloc_expr (Smap.add x (-next) env) next e2 in
    Letin (-next, e1, e2), max fpmax1 fpmax2

  | PCall (f, l) ->
    let l, fpmax =
      List.fold_left
        (fun (l, fpmax) e ->
          let e, fpmax' = alloc_expr env next e in
          e::l, max fpmax fpmax') ([], next) l
    in
    Call (f, List.rev l), fpmax

let alloc_stmt = function
  | PSet (x, e) ->
    let e, fpmax = alloc_expr Smap.empty 0 e in
    Hashtbl.replace genv x ();
    Set (x, e, fpmax)

  | PFun (f, l, e) ->
    (* Format.eprintf "fun %s@." f; *)
    let env, next =
      List.fold_right
        (fun x (env, next) ->
          let next = next + 8 in
          (* Format.eprintf "  %s = %d@." x next; *)
          Smap.add x next env, next)
        l (Smap.empty, 8)
    in
    let e, fpmax = alloc_expr env 0 e in
   Fun (f, e, fpmax)

  | PPrint e ->
    let e, fpmax = alloc_expr Smap.empty 0 e in
    Print (e, fpmax)

let alloc = List.map alloc_stmt

(******************************************************************************)
(* phase 2 : production de code *)

let popn n = addq (imm n) (reg rsp)
let pushn n = subq (imm n) (reg rsp)

let rec compile_expr = function
  | Cst i ->
      pushq (imm i)

  | LVar fp_x ->
      pushq (ind ~ofs:fp_x rbp)

  | GVar x ->
      pushq (lab x)

  | Binop (o, e1, e2)->
      compile_expr e1 ++
      compile_expr e2 ++
      popq rbx ++ popq rax ++
      (match o with
        | Add -> addq (reg rbx) (reg rax)
        | Sub -> subq (reg rbx) (reg rax)
        | Mul -> imulq (reg rbx) (reg rax)
        | Div -> cqto ++ idivq (reg rbx)) ++
       pushq (reg rax)

  | Letin (ofs, e1, e2) ->
      compile_expr e1 ++
      popq rax ++ movq (reg rax) (ind ~ofs rbp) ++
      compile_expr e2

  | Call (f, l) ->
      List.fold_left (fun code e -> code ++ compile_expr e) nop l ++
      call f ++ popn (8 * List.length l) ++ pushq (reg rax)

let compile_stmt (codefun, codemain) = function
  | Set (x, e, fpmax) ->
    let code =
      pushn fpmax ++
      compile_expr e ++
      popq rax ++ movq (reg rax) (lab x) ++
      popn fpmax
    in
    codefun, codemain ++ code

  | Fun (f, e, fpmax) ->
    let code =
      label f ++
      pushq (reg rbp) ++
      movq (reg rsp) (reg rbp) ++ pushn fpmax ++
      compile_expr e ++ popq rax ++
      popn fpmax ++ popq rbp ++ ret
    in
    code ++ codefun, codemain

  | Print (e, fpmax) ->
    let code =
      pushn fpmax ++
      compile_expr e ++
      popq rdi ++
      popn fpmax ++
      call "print_int"
    in
    codefun, codemain ++ code


let compile_program p ofile =
  let p = alloc p in
  let codefun, code = List.fold_left compile_stmt (nop, nop) p in
  let p =
    { text =
        glabel "main" ++
        movq (reg rsp) (reg rbp) ++
        code ++
        movq (imm 0) (reg rax) ++ (* exit *)
        ret ++
        label "print_int" ++
        movq (reg rdi) (reg rsi) ++
        movq (ilab ".Sprint_int") (reg rdi) ++
        movq (imm 0) (reg rax) ++
        call "printf" ++
        ret ++
        codefun;
      data =
        Hashtbl.fold (fun x _ l -> label x ++ dquad [1] ++ l) genv
          (label ".Sprint_int" ++ string "%d\n")
    }
  in
  let f = open_out ofile in
  let fmt = formatter_of_out_channel f in
  X86_64.print_program fmt p;
  fprintf fmt "@?";
  close_out f

This document was generated using caml2html