fmt

flap/src/x86-64/retrolixToX86_64.ml

@@ -5,29 +5,32 @@
       loads and stores ;
     - generating initialization code and reserving space in the .data section for
       global variables ;
-   - reserving space in the .data section for literal strings.
+    - reserving space in the .data section for literal strings. *)
- *)
 
 (* TODO tail recursion *)
 
-let error ?(pos = Position.dummy) msg =
+let error ?(pos = Position.dummy) msg = Error.error "compilation" pos msg
-  Error.error "compilation" pos msg
 
 (** As in any module that implements {!Compilers.Compiler}, the source
     language and the target language must be specified. *)
 module Source = Retrolix
+
 module Target = X86_64
 module S = Source.AST
 module T = Target.AST
 
-module Str = struct type t = string let compare = Stdlib.compare end
+module Str = struct
+  type t = string
+
+  let compare = Stdlib.compare
+end
+
 module StrMap = Map.Make (Str)
 module StrSet = Set.Make (Str)
 
 (** {2 Low-level helpers} *)
 
 let scratchr = X86_64_Architecture.scratch_register
-
 let scratch = `Reg scratchr
 let rsp = `Reg X86_64_Architecture.RSP
 let rbp = `Reg X86_64_Architecture.RBP
@@ -37,118 +40,104 @@ let rdi = `Reg X86_64_Architecture.RDI
 let align n b =
   let m = n mod b in
   if m = 0 then n else n + b - m
+;;
 
 (** {2 Label mangling and generation} *)
 
 let hash x = string_of_int (Hashtbl.hash x)
-
+let label_for_string_id id = ".S_" ^ string_of_int id
-let label_for_string_id id =
+let label_of_retrolix_label (s : string) = s
-  ".S_" ^ string_of_int id
+let label_of_function_identifier (S.FId s) = label_of_retrolix_label s
-
+let data_label_of_global (S.Id s) = label_of_retrolix_label s
-let label_of_retrolix_label (s : string) =
+let init_label_of_global (xs : S.identifier list) = ".I_" ^ hash xs
-  s
+let label_of_internal_label_id (id : T.label) = ".X_" ^ id
-
-let label_of_function_identifier (S.FId s) =
-  label_of_retrolix_label s
-
-let data_label_of_global (S.Id s) =
-  label_of_retrolix_label s
-
-let init_label_of_global (xs : S.identifier list) =
-  ".I_" ^ hash xs
-
-let label_of_internal_label_id (id : T.label) =
-  ".X_" ^ id
 
 let fresh_label : unit -> T.label =
   let r = ref 0 in
-  fun () -> incr r; label_of_internal_label_id (string_of_int !r)
+  fun () ->
+    incr r;
+    label_of_internal_label_id (string_of_int !r)
+;;
 
 let fresh_string_label : unit -> string =
   let r = ref 0 in
-  fun () -> let n = !r in incr r; label_for_string_id n
+  fun () ->
+    let n = !r in
+    incr r;
+    label_for_string_id n
+;;
 
 (** {2 Environments} *)
 
 type environment =
-  {
+  { externals : S.FIdSet.t
-    externals : S.FIdSet.t;
   (** All the external functions declared in the retrolix program. *)
-    globals : S.IdSet.t;
+  ; globals : S.IdSet.t
   (** All the global variables found in the Retrolix program, each with a
       unique integer. *)
-    data_lines : T.line list;
+  ; data_lines : T.line list
   (** All the lines to be added to the .data section of the complete file. *)
   }
 
 let make_environment ~externals ~globals () =
   let open T in
-
   let data_lines =
     S.IdSet.fold
-      (fun ((S.Id id_s) as id) lines ->
+      (fun (S.Id id_s as id) lines ->
         Label (data_label_of_global id)
         :: Instruction (Comment id_s)
         :: Directive (Quad [ Lit Mint.zero ])
-        :: lines
+        :: lines)
-      )
       globals
       []
   in
-
   let data_lines =
     S.FIdSet.fold
       (fun (S.FId f) lines -> Directive (Extern f) :: lines)
       externals
       data_lines
   in
-
+  { externals; globals; data_lines }
-  {
+;;
-    externals;
-    globals;
-    data_lines;
-  }
 
 let is_external env (f : S.rvalue) =
   match f with
-  | `Immediate (S.LFun f) ->
+  | `Immediate (S.LFun f) -> S.FIdSet.mem f env.externals
-     S.FIdSet.mem f env.externals
+  | _ -> false
-  | _ ->
+;;
-     false
 
-let is_global env f =
+let is_global env f = S.IdSet.mem f env.globals
-  S.IdSet.mem f env.globals
 
 let register_string s env =
   let open T in
   let l = fresh_string_label () in
-  l,
+  l, { env with data_lines = Label l :: Directive (String s) :: env.data_lines }
-  { env with data_lines = Label l :: Directive (String s) :: env.data_lines; }
+;;
 
 (* The following function is here to please Flap's architecture. *)
 let initial_environment () =
   make_environment ~externals:S.FIdSet.empty ~globals:S.IdSet.empty ()
+;;
 
 let register_globals global_set env =
   let open T in
   let globals, data_lines =
     S.IdSet.fold
-      (fun ((S.Id id_s) as id) (globals, lines) ->
+      (fun (S.Id id_s as id) (globals, lines) ->
-        S.IdSet.add id globals,
+        ( S.IdSet.add id globals
-        Label (data_label_of_global id)
+        , Label (data_label_of_global id)
           :: Instruction (Comment id_s)
           :: Directive (Quad [ Lit Mint.zero ])
-        :: lines
+          :: lines ))
-      )
       global_set
       (S.IdSet.empty, env.data_lines)
   in
-  { env with globals; data_lines; }
+  { env with globals; data_lines }
+;;
 
 (** {2 Abstract instruction selectors and calling conventions} *)
 
-module type InstructionSelector =
+module type InstructionSelector = sig
-  sig
   (** [mov ~dst ~src] generates the x86-64 assembly listing to copy [src] into
       [dst]. *)
   val mov : dst:T.dst -> src:T.src -> T.line list
@@ -180,11 +169,13 @@ module type InstructionSelector =
   (** [conditional_jump ~cc ~srcl ~srcr ~ll ~lr] generates the x86-64 assembly
       listing to test whether [srcl, srcr] satisfies the relation described by
       [cc] and jump to [ll] if they do or to [lr] when they do not. *)
-    val conditional_jump :
+  val conditional_jump
-      cc:T.condcode ->
+    :  cc:T.condcode
-      srcl:T.src -> srcr:T.src ->
+    -> srcl:T.src
-      ll:T.label -> lr:T.label ->
+    -> srcr:T.src
-      T.line list
+    -> ll:T.label
+    -> lr:T.label
+    -> T.line list
 
   (** [switch ~default ~discriminant ~cases ()] generates the x86-64 assembly
       listing to jump to [cases.(discriminant)], or to the (optional) [default]
@@ -192,26 +183,25 @@ module type InstructionSelector =
 
       The behavior of the program is undefined if [discriminant < 0], or if
       [discriminant >= Array.length cases] and no [default] has been given. *)
-    val switch :
+  val switch
-      ?default:T.label ->
+    :  ?default:T.label
-      discriminant:T.src ->
+    -> discriminant:T.src
-      cases:T.label array ->
+    -> cases:T.label array
-      unit ->
+    -> unit
-      T.line list
+    -> T.line list
 end
 
-module type FrameManager =
+module type FrameManager = sig
-  sig
   (** The abstract data structure holding the information necessary to
       implement the calling convention. *)
   type frame_descriptor
 
   (** Generate a frame descriptor for the function with parameter [params] and
       locals [locals]. *)
-    val frame_descriptor :
+  val frame_descriptor
-      params:S.identifier list ->
+    :  params:S.identifier list
-      locals:S.identifier list ->
+    -> locals:S.identifier list
-      frame_descriptor
+    -> frame_descriptor
 
   (** [location_of fd v] computes the address of [v] according to the frame
       descriptor [fd]. Note that [v] might be a local variable, a function
@@ -229,58 +219,47 @@ module type FrameManager =
   (** [call fd ~kind ~f ~args] generates the x86-64 assembly listing to setup
       a call to the function at [f], with arguments [args], with [kind]
       specifying whether this should be a normal or tail call. *)
-    val call :
+  val call
-      frame_descriptor ->
+    :  frame_descriptor
-      kind:[ `Normal | `Tail ] ->
+    -> kind:[ `Normal | `Tail ]
-      f:T.src ->
+    -> f:T.src
-      args:T.src list ->
+    -> args:T.src list
-      T.line list
+    -> T.line list
 end
 
 (** {2 Code generator} *)
 
 (** This module implements an x86-64 code generator for Retrolix using the
     provided [InstructionSelector] and [FrameManager]. *)
-module Codegen(IS : InstructionSelector)(FM : FrameManager) =
+module Codegen (IS : InstructionSelector) (FM : FrameManager) = struct
-  struct
+  let translate_label (S.Label l) = label_of_retrolix_label l
-    let translate_label (S.Label l) =
+  let translate_variable fd v = `Addr (FM.location_of fd v)
-      label_of_retrolix_label l
-
-    let translate_variable fd v =
-      `Addr (FM.location_of fd v)
 
   let translate_literal lit env =
     match lit with
-      | S.LInt i ->
+    | S.LInt i -> T.Lit i, env
-         T.Lit i, env
+    | S.LFun f -> T.Lab (label_of_function_identifier f), env
-
+    | S.LChar c -> T.Lit (Mint.of_int @@ Char.code c), env
-      | S.LFun f ->
-         T.Lab (label_of_function_identifier f), env
-
-      | S.LChar c ->
-         T.Lit (Mint.of_int @@ Char.code c), env
-
     | S.LString s ->
       let l, env = register_string s env in
       T.Lab l, env
+  ;;
 
-    let translate_register (S.RId s) =
+  let translate_register (S.RId s) = X86_64_Architecture.register_of_string s
-      X86_64_Architecture.register_of_string s
 
   let translate_lvalue fi lv =
     match lv with
-      | `Variable v ->
+    | `Variable v -> translate_variable fi v
-         translate_variable fi v
+    | `Register reg -> `Reg (translate_register reg)
-      | `Register reg ->
+  ;;
-         `Reg (translate_register reg)
 
   let translate_rvalue fi rv env =
     match rv with
     | `Immediate lit ->
       let lit, env = translate_literal lit env in
       `Imm lit, env
-      | (`Variable _ | `Register _) as lv ->
+    | (`Variable _ | `Register _) as lv -> translate_lvalue fi lv, env
-         translate_lvalue fi lv, env
+  ;;
 
   let translate_rvalues fi rvs env =
     List.fold_right
@@ -289,9 +268,9 @@ module Codegen(IS : InstructionSelector)(FM : FrameManager) =
         rv :: rvs, env)
       rvs
       ([], env)
+  ;;
 
-    let translate_label_to_operand (S.Label l) =
+  let translate_label_to_operand (S.Label l) = `Imm (T.Lab l)
-      `Imm (T.Lab l)
 
   let translate_cond cond =
     match cond with
@@ -300,124 +279,88 @@ module Codegen(IS : InstructionSelector)(FM : FrameManager) =
     | S.GTE -> T.GE
     | S.LTE -> T.LE
     | S.EQ -> T.E
+  ;;
 
   let translate_instruction fd ins env : T.line list * environment =
     let open T in
-      begin match ins with
+    match ins with
     | S.Call (f, args, is_tail) ->
       let kind = if is_tail then `Tail else `Normal in
       let f, env = translate_rvalue fd f env in
       let args, env = translate_rvalues fd args env in
-         FM.call fd ~kind ~f ~args,
+      FM.call fd ~kind ~f ~args, env
-         env
-
     | S.Assign (dst, op, args) ->
       let dst = translate_lvalue fd dst in
       let args, env = translate_rvalues fd args env in
       let inss =
         match op, args with
-           | S.Add, [ srcl; srcr; ] ->
+        | S.Add, [ srcl; srcr ] -> IS.add ~dst ~srcl ~srcr
-              IS.add ~dst ~srcl ~srcr
+        | S.Sub, [ srcl; srcr ] -> IS.sub ~dst ~srcl ~srcr
-           | S.Sub, [ srcl; srcr; ] ->
+        | S.Mul, [ srcl; srcr ] -> IS.mul ~dst ~srcl ~srcr
-              IS.sub ~dst ~srcl ~srcr
+        | S.Div, [ srcl; srcr ] -> IS.div ~dst ~srcl ~srcr
-           | S.Mul, [ srcl; srcr; ] ->
+        | S.And, [ srcl; srcr ] -> IS.andl ~dst ~srcl ~srcr
-              IS.mul ~dst ~srcl ~srcr
+        | S.Or, [ srcl; srcr ] -> IS.orl ~dst ~srcl ~srcr
-           | S.Div, [ srcl; srcr; ] ->
+        | S.Copy, [ src ] -> IS.mov ~dst ~src
-              IS.div ~dst ~srcl ~srcr
+        | _ -> error "Unknown operator or bad arity"
-           | S.And, [ srcl; srcr; ] ->
-              IS.andl ~dst ~srcl ~srcr
-           | S.Or, [ srcl; srcr; ] ->
-              IS.orl ~dst ~srcl ~srcr
-           | S.Copy, [ src; ] ->
-              IS.mov ~dst ~src
-           | _ ->
-              error "Unknown operator or bad arity"
       in
       inss, env
-
+    | S.Ret -> FM.function_epilogue fd @ insns [ T.Ret ], env
-      | S.Ret ->
+    | S.Jump l -> insns [ T.jmpl ~tgt:(translate_label l) ], env
-         FM.function_epilogue fd @ insns [T.Ret],
-         env
-
-      | S.Jump l ->
-         insns
-           [
-             T.jmpl ~tgt:(translate_label l);
-           ],
-         env
-
     | S.ConditionalJump (cond, args, ll, lr) ->
       let cc = translate_cond cond in
       let srcl, srcr, env =
         match args with
-           | [ src1; src2; ] ->
+        | [ src1; src2 ] ->
           let src1, env = translate_rvalue fd src1 env in
           let src2, env = translate_rvalue fd src2 env in
           src1, src2, env
-           | _ ->
+        | _ -> failwith "translate_exp: conditional jump with invalid arity"
-              failwith "translate_exp: conditional jump with invalid arity"
       in
-         IS.conditional_jump
+      ( IS.conditional_jump
           ~cc
-           ~srcl ~srcr
+          ~srcl
-           ~ll:(translate_label ll) ~lr:(translate_label lr),
+          ~srcr
-         env
+          ~ll:(translate_label ll)
-
+          ~lr:(translate_label lr)
+      , env )
     | S.Switch (discriminant, cases, default) ->
       let discriminant, env = translate_rvalue fd discriminant env in
       let cases = Array.map translate_label cases in
       let default = ExtStd.Option.map translate_label default in
-         IS.switch ?default ~discriminant ~cases (),
+      IS.switch ?default ~discriminant ~cases (), env
-         env
+    | S.Comment s -> insns [ Comment s ], env
-
-      | S.Comment s ->
-         insns
-           [
-             Comment s;
-           ],
-         env
-
     | S.Exit ->
-         IS.mov ~src:(liti 0) ~dst:rdi
+      ( IS.mov ~src:(liti 0) ~dst:rdi
-         @ FM.call fd ~kind:`Normal ~f:(`Imm (Lab "exit")) ~args:[],
+        @ FM.call fd ~kind:`Normal ~f:(`Imm (Lab "exit")) ~args:[]
-         env
+      , env )
-      end
+  ;;
-
 
   let translate_labelled_instruction fi (body, env) (l, ins) =
     let ins, env = translate_instruction fi ins env in
-      List.rev ins @ T.Label (translate_label l) :: body,
+    List.rev ins @ (T.Label (translate_label l) :: body), env
-      env
+  ;;
 
   let translate_labelled_instructions fi env inss =
-      let inss, env =
+    let inss, env = List.fold_left (translate_labelled_instruction fi) ([], env) inss in
-        List.fold_left (translate_labelled_instruction fi) ([], env) inss
-      in
     List.rev inss, env
+  ;;
 
   let translate_fun_def ~name ?(desc = "") ~params ~locals gen_body =
     let open T in
-
     let fd = FM.frame_descriptor ~params ~locals in
-
     let prologue = FM.function_prologue fd in
-
     let body, env = gen_body fd in
-
+    ( (Directive (PadToAlign { pow = 3; fill = 0x90 })
-      Directive (PadToAlign { pow = 3; fill = 0x90; }) :: Label name
+       :: Label name
-      :: (if desc = ""
+       :: (if desc = "" then prologue else Instruction (Comment desc) :: prologue))
-          then prologue
+      @ body
-          else Instruction (Comment desc) :: prologue)
+    , env )
-      @ body,
+  ;;
-      env
 
   let translate_block ~name ?(desc = "") ~params (locals, body) env =
-      translate_fun_def
+    translate_fun_def ~name ~desc ~params ~locals (fun fi ->
-        ~name
+      translate_labelled_instructions fi env body)
-        ~desc
+  ;;
-        ~params
-        ~locals
-        (fun fi -> translate_labelled_instructions fi env body)
 
   let translate_definition def (body, env) =
     match def with
@@ -425,16 +368,10 @@ module Codegen(IS : InstructionSelector)(FM : FrameManager) =
       let ids = ExtPPrint.to_string RetrolixPrettyPrinter.identifiers xs in
       let name = init_label_of_global xs in
       let def, env =
-           translate_block
+        translate_block ~name ~desc:("Initializer for " ^ ids ^ ".") ~params:[] block env
-             ~name
-             ~desc:("Initializer for " ^ ids ^ ".")
-             ~params:[]
-             block
-             env
       in
       def @ body, env
-
+    | S.DFunction ((S.FId id as f), params, block) ->
-      | S.DFunction ((S.FId id) as f, params, block) ->
       let def, env =
         translate_block
           ~desc:("Retrolix function " ^ id ^ ".")
@@ -444,24 +381,19 @@ module Codegen(IS : InstructionSelector)(FM : FrameManager) =
           env
       in
       def @ body, env
-
+    | S.DExternalFunction (S.FId id) -> T.(Directive (Extern id)) :: body, env
-      | S.DExternalFunction (S.FId id) ->
+  ;;
-         T.(Directive (Extern id)) :: body,
-         env
 
   let generate_main _ p =
     let open T in
-
     let body =
       List.rev
-          [
+        [ Directive (PadToAlign { pow = 3; fill = 0x90 })
-            Directive (PadToAlign { pow = 3; fill = 0x90; });
+        ; Label "main"
-            Label "main";
+        ; Instruction (Comment "Program entry point.")
-            Instruction (Comment "Program entry point.");
+        ; Instruction (T.subq ~src:(`Imm (Lit 8L)) ~dst:rsp)
-            Instruction (T.subq ~src:(`Imm (Lit 8L)) ~dst:rsp);
         ]
     in
-
     (* Call all initialization stubs *)
     let body =
       let call body def =
@@ -469,116 +401,85 @@ module Codegen(IS : InstructionSelector)(FM : FrameManager) =
         | S.DValues (ids, _) ->
           let l = init_label_of_global ids in
           Instruction (T.calld ~tgt:(Lab l)) :: body
-          | S.DFunction _ | S.DExternalFunction _ ->
+        | S.DFunction _ | S.DExternalFunction _ -> body
-             body
       in
       List.fold_left call body p
     in
-
     let body =
-        T.insns
+      T.insns [ T.calld ~tgt:(Lab "exit"); T.movq ~src:(liti 0) ~dst:rdi ] @ body
-          [
-            T.calld ~tgt:(Lab "exit");
-            T.movq ~src:(liti 0) ~dst:rdi;
-          ]
-        @ body
     in
-
     Directive (Global "main") :: List.rev body
+  ;;
 
   (** [translate p env] turns a Retrolix program into a X86-64 program. *)
   let translate (p : S.t) (env : environment) : T.t * environment =
     let env = register_globals (S.globals p) env in
     let pt, env = List.fold_right translate_definition p ([], env) in
     let main = generate_main env p in
-      let p = T.data_section :: env.data_lines @ T.text_section :: main @ pt in
+    let p = (T.data_section :: env.data_lines) @ (T.text_section :: main) @ pt in
     T.remove_unused_labels p, env
+  ;;
 end
 
 (** {2 Concrete instructions selectors and calling conventions} *)
 
-module InstructionSelector : InstructionSelector =
+module InstructionSelector : InstructionSelector = struct
-  struct
   open T
 
-    let mov ~(dst : dst) ~(src : src) =
+  let mov ~(dst : dst) ~(src : src) = failwith "Students! This is your job!"
-      failwith "Students! This is your job!"
+  let bin ins ~dst ~srcl ~srcr = failwith "Students! This is your job!"
-
+  let add ~dst ~srcl ~srcr = failwith "Students! This is your job!"
-    let bin ins ~dst ~srcl ~srcr =
+  let sub ~dst ~srcl ~srcr = failwith "Students! This is your job!"
-      failwith "Students! This is your job!"
+  let mul ~dst ~srcl ~srcr = failwith "Students! This is your job!"
-
+  let div ~dst ~srcl ~srcr = failwith "Students! This is your job!"
-    let add ~dst ~srcl ~srcr =
+  let andl ~dst ~srcl ~srcr = failwith "Students! This is your job!"
-      failwith "Students! This is your job!"
+  let orl ~dst ~srcl ~srcr = failwith "Students! This is your job!"
-
+  let conditional_jump ~cc ~srcl ~srcr ~ll ~lr = failwith "Students! This is your job!"
-    let sub ~dst ~srcl ~srcr =
+  let switch ?default ~discriminant ~cases () = failwith "Students! This is your job!"
-      failwith "Students! This is your job!"
-
-    let mul ~dst ~srcl ~srcr =
-      failwith "Students! This is your job!"
-
-    let div ~dst ~srcl ~srcr =
-      failwith "Students! This is your job!"
-
-    let andl ~dst ~srcl ~srcr =
-      failwith "Students! This is your job!"
-
-    let orl ~dst ~srcl ~srcr =
-      failwith "Students! This is your job!"
-
-    let conditional_jump ~cc ~srcl ~srcr ~ll ~lr =
-      failwith "Students! This is your job!"
-
-    let switch ?default ~discriminant ~cases () =
-      failwith "Students! This is your job!"
-
 end
 
-module FrameManager(IS : InstructionSelector) : FrameManager =
+module FrameManager (IS : InstructionSelector) : FrameManager = struct
-  struct
   type frame_descriptor =
-      {
+    { param_count : int (** Number of parameters. *)
-        param_count : int;
+    ; locals_space : int
-        (** Number of parameters. *)
-        locals_space : int;
     (** Amount of space dedicated to local variables in the stack frame. *)
-        stack_map : Mint.t S.IdMap.t;
+    ; stack_map : Mint.t S.IdMap.t
     (** Maps stack-allocated variable names to stack slots expressed as
         frame-pointer relative offsets. *)
     }
 
   (** [empty_frame fd] returns [true] if and only if the stack frame described
       by [fd] is empty. *)
-    let empty_frame fd =
+  let empty_frame fd = fd.param_count = 0 && fd.locals_space = 0
-      fd.param_count = 0 && fd.locals_space = 0
 
   (** [stack_usage_after_prologue fd] returns the size, in bytes, of the stack
       space after the function prologue. *)
   let stack_usage_after_prologue fd =
     Mint.size_in_bytes
-      + (if empty_frame fd then 0 else 1) * Mint.size_in_bytes
+    + ((if empty_frame fd then 0 else 1) * Mint.size_in_bytes)
     + fd.locals_space
+  ;;
 
   let frame_descriptor ~params ~locals =
     (* Student! Implement me! *)
-      { param_count = 0; locals_space = 0; stack_map = S.IdMap.empty; }
+    { param_count = 0; locals_space = 0; stack_map = S.IdMap.empty }
+  ;;
 
-    let location_of fd id =
+  let location_of fd id = failwith "Students! This is your job!"
-      failwith "Students! This is your job!"
 
   let function_prologue fd =
     (* Student! Implement me! *)
     []
+  ;;
 
   let function_epilogue fd =
     (* Student! Implement me! *)
     []
+  ;;
 
-    let call fd ~kind ~f ~args =
+  let call fd ~kind ~f ~args = failwith "Students! This is your job!"
-      failwith "Students! This is your job!"
-
 end
 
-module CG =
+module CG = Codegen (InstructionSelector) (FrameManager (InstructionSelector))
-  Codegen(InstructionSelector)(FrameManager(InstructionSelector))
 
 let translate = CG.translate