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

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

@ -5,29 +5,32 @@
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,118 +40,104 @@ 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
@ -180,11 +169,13 @@ module type InstructionSelector =
(** [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]
@ -192,26 +183,25 @@ module type InstructionSelector =
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
@ -229,58 +219,47 @@ module type FrameManager =
(** [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 =
`Addr (FM.location_of fd v)
let translate_literal lit env = let translate_literal lit env =
match lit with 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 -> | S.LString s ->
let l, env = register_string s env in let l, env = register_string s env in
T.Lab l, env 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 = let translate_lvalue fi lv =
match lv with 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 = let translate_rvalue fi rv env =
match rv with match rv with
| `Immediate lit -> | `Immediate lit ->
let lit, env = translate_literal lit env in let lit, env = translate_literal lit env in
`Imm lit, env `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 = let translate_rvalues fi rvs env =
List.fold_right List.fold_right
@ -289,9 +268,9 @@ module Codegen(IS : InstructionSelector)(FM : FrameManager) =
rv :: rvs, env) rv :: rvs, env)
rvs rvs
([], env) ([], 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 = let translate_cond cond =
match cond with match cond with
@ -300,124 +279,88 @@ module Codegen(IS : InstructionSelector)(FM : FrameManager) =
| S.GTE -> T.GE | S.GTE -> T.GE
| S.LTE -> T.LE | S.LTE -> T.LE
| S.EQ -> T.E | S.EQ -> T.E
;;
let translate_instruction fd ins env : T.line list * environment = let translate_instruction fd ins env : T.line list * environment =
let open T in let open T in
begin match ins with match ins with
| S.Call (f, args, is_tail) -> | S.Call (f, args, is_tail) ->
let kind = if is_tail then `Tail else `Normal in let kind = if is_tail then `Tail else `Normal in
let f, env = translate_rvalue fd f env in let f, env = translate_rvalue fd f env in
let args, env = translate_rvalues fd args 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) -> | S.Assign (dst, op, args) ->
let dst = translate_lvalue fd dst in let dst = translate_lvalue fd dst in
let args, env = translate_rvalues fd args env in let args, env = translate_rvalues fd args env in
let inss = let inss =
match op, args with 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 in
inss, env 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) -> | S.ConditionalJump (cond, args, ll, lr) ->
let cc = translate_cond cond in let cc = translate_cond cond in
let srcl, srcr, env = let srcl, srcr, env =
match args with match args with
| [ src1; src2; ] -> | [ src1; src2 ] ->
let src1, env = translate_rvalue fd src1 env in let src1, env = translate_rvalue fd src1 env in
let src2, env = translate_rvalue fd src2 env in let src2, env = translate_rvalue fd src2 env in
src1, src2, env src1, src2, env
| _ -> | _ -> failwith "translate_exp: conditional jump with invalid arity"
failwith "translate_exp: conditional jump with invalid arity"
in in
IS.conditional_jump ( IS.conditional_jump
~cc ~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) -> | S.Switch (discriminant, cases, default) ->
let discriminant, env = translate_rvalue fd discriminant env in let discriminant, env = translate_rvalue fd discriminant env in
let cases = Array.map translate_label cases in let cases = Array.map translate_label cases in
let default = ExtStd.Option.map translate_label default 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 -> | 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 translate_labelled_instruction fi (body, env) (l, ins) =
let ins, env = translate_instruction fi ins env in 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 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 List.rev inss, env
;;
let translate_fun_def ~name ?(desc = "") ~params ~locals gen_body = let translate_fun_def ~name ?(desc = "") ~params ~locals gen_body =
let open T in let open T in
let fd = FM.frame_descriptor ~params ~locals in let fd = FM.frame_descriptor ~params ~locals in
let prologue = FM.function_prologue fd in let prologue = FM.function_prologue fd in
let body, env = gen_body 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 = 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) = let translate_definition def (body, env) =
match def with match def with
@ -425,16 +368,10 @@ module Codegen(IS : InstructionSelector)(FM : FrameManager) =
let ids = ExtPPrint.to_string RetrolixPrettyPrinter.identifiers xs in let ids = ExtPPrint.to_string RetrolixPrettyPrinter.identifiers xs in
let name = init_label_of_global xs in let name = init_label_of_global xs in
let def, env = let def, env =
translate_block translate_block ~name ~desc:("Initializer for " ^ ids ^ ".") ~params:[] block env
~name
~desc:("Initializer for " ^ ids ^ ".")
~params:[]
block
env
in in
def @ body, env def @ body, env
| S.DFunction ((S.FId id as f), params, block) ->
| S.DFunction ((S.FId id) as f, params, block) ->
let def, env = let def, env =
translate_block translate_block
~desc:("Retrolix function " ^ id ^ ".") ~desc:("Retrolix function " ^ id ^ ".")
@ -444,24 +381,19 @@ module Codegen(IS : InstructionSelector)(FM : FrameManager) =
env env
in in
def @ body, env 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 generate_main _ p =
let open T in let open T in
let body = let body =
List.rev 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 in
(* Call all initialization stubs *) (* Call all initialization stubs *)
let body = let body =
let call body def = let call body def =
@ -469,116 +401,85 @@ module Codegen(IS : InstructionSelector)(FM : FrameManager) =
| S.DValues (ids, _) -> | S.DValues (ids, _) ->
let l = init_label_of_global ids in let l = init_label_of_global ids in
Instruction (T.calld ~tgt:(Lab l)) :: body Instruction (T.calld ~tgt:(Lab l)) :: body
| S.DFunction _ | S.DExternalFunction _ -> | S.DFunction _ | S.DExternalFunction _ -> body
body
in in
List.fold_left call body p List.fold_left call body p
in in
let body = 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 in
Directive (Global "main") :: List.rev body 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!"
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
module FrameManager(IS : InstructionSelector) : FrameManager =
struct
type frame_descriptor = 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. *) (** 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 (** Maps stack-allocated variable names to stack slots expressed as
frame-pointer relative offsets. *) frame-pointer relative offsets. *)
} }
(** [empty_frame fd] returns [true] if and only if the stack frame described (** [empty_frame fd] returns [true] if and only if the stack frame described
by [fd] is empty. *) 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 (** [stack_usage_after_prologue fd] returns the size, in bytes, of the stack
space after the function prologue. *) space after the function prologue. *)
let stack_usage_after_prologue fd = let stack_usage_after_prologue fd =
Mint.size_in_bytes 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 + fd.locals_space
;;
let frame_descriptor ~params ~locals = let frame_descriptor ~params ~locals =
(* Student! Implement me! *) (* 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 = let function_prologue fd =
(* Student! Implement me! *) (* Student! Implement me! *)
[] []
;;
let function_epilogue fd = let function_epilogue fd =
(* Student! Implement me! *) (* 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
end module CG = Codegen (InstructionSelector) (FrameManager (InstructionSelector))
module CG =
Codegen(InstructionSelector)(FrameManager(InstructionSelector))
let translate = CG.translate let translate = CG.translate