Paris7/compilation
Archived
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Activity

fmt

Browse source
This commit is contained in:
Mylloon 2023-12-18 19:39:52 +01:00
parent 38ab723583
commit 07a65e7bcb
Signed by: Anri
GPG key ID: A82D63DFF8D1317F
1 changed files with 355 additions and 454 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

809
flap/src/x86-64/retrolixToX86_64.ml
View file

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