Skip to content

Commit

Permalink
chapter 19: TACKY optimizations
Browse files Browse the repository at this point in the history
  • Loading branch information
@nlsandler
nlsandler committed Jun 25, 2024
1 parent 9c41f56 commit 62aca9a
Show file tree
Hide file tree
Showing 30 changed files with 1,634 additions and 78 deletions.
137 changes: 127 additions & 10 deletions bin/main.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -30,8 +30,8 @@ let preprocess src =
let _ = run_command preprocess_cmd in
output

let compile stage preprocessed_src =
let _ = Compile.compile stage preprocessed_src in
let compile stage optimizations preprocessed_src =
let _ = Compile.compile stage optimizations preprocessed_src in
(* remove preprocessed src *)
let cleanup_preprocessed = Printf.sprintf "rm %s" preprocessed_src in
run_command cleanup_preprocessed;
Expand All @@ -54,20 +54,21 @@ let assemble_and_link ?(link = true) ?(cleanup = true) ?(libs = []) src =
let cleanup_cmd = Printf.sprintf "rm %s" assembly_file in
run_command cleanup_cmd

let driver target debug libs extra_credit int_only stage src =
let driver target debug libs extra_credit int_only stage optimizations src =
let _ =
Settings.platform := target;
Settings.debug := debug;
Settings.extra_credit_flags := extra_credit;
Settings.int_only := int_only
in
let preprocessed_name = preprocess src in
let assembly_name = compile stage preprocessed_name in
let assembly_name = compile stage optimizations preprocessed_name in
match stage with
| Settings.Executable ->
assemble_and_link ~link:true ~cleanup:(not debug) ~libs assembly_name
assemble_and_link ~link:true ~cleanup:(not debug.dump_asm) ~libs
assembly_name
| Settings.Obj ->
assemble_and_link ~link:false ~cleanup:(not debug) assembly_name
assemble_and_link ~link:false ~cleanup:(not debug.dump_asm) assembly_name
| _ -> ()

(* Command-line options *)
Expand Down Expand Up @@ -152,15 +153,130 @@ let int_only =
Arg.(value & flag & info [ "int-only" ] ~doc)

let debug =
let doc =
"Write out pre- and post-register-allocation assembly and DOT files of \
interference graphs."
let dump_tacky_opt =
let doc = "Dump TACKY at start and end of optimization phase." in
Arg.(value & flag & info [ "dump-tacky" ] ~doc)
in
Arg.(value & flag & info [ "d" ] ~doc)
let dump_asm_opt =
let doc = "Dump assembly before and after pseudoreg allocation" in
Arg.(value & flag & info [ "dump-asm" ] ~doc)
in
let dump_const_fold_opt =
let doc =
"Dump TACKY immediately before and after each constant folding pass. \
Ignored if this optimization is not enabled."
in
Arg.(value & flag & info [ "dump-const-fold" ] ~doc)
in
let dump_dse_opt =
let doc =
"Dump debug info (e.g. control flow graph) during dead store \
elimination. Ignored if this optimization is not enabled."
in
Arg.(value & flag & info [ "dump-dse" ] ~doc)
in
let dump_copy_prop_opt =
let doc =
"Dump debug info (e.g. control flow graph) during copy pro. Ignored if \
this optimization is not enabled."
in
Arg.(value & flag & info [ "dump-copy-prop" ] ~doc)
in
let dump_unreachable_elim_opt =
let doc =
"Dump debug info (e.g. control flow graph) during unreachable code elim. \
Ignored if this optimization is not enabled."
in
Arg.(value & flag & info [ "dump-unreachable-elim" ] ~doc)
in
let dump_fun_opt =
let doc =
"Function to dump extra optimization details for (if not specified, dump \
info for all functions). Affects optimization-specific --dump* options \
but not --dump-tacky or --dump-asm."
in
Arg.(value & opt (some' string) None & info [ "dump-fun" ] ~doc)
in
let set_debug_options dump_asm dump_tacky constant_folding
dead_store_elimination copy_propagation unreachable_code_elimination
dump_fun =
Settings.
{
dump_asm;
dump_tacky;
dump_optimizations =
{
constant_folding;
dead_store_elimination;
unreachable_code_elimination;
copy_propagation;
};
dump_fun;
}
in
Cmdliner.Term.(
const set_debug_options
$ dump_asm_opt
$ dump_tacky_opt
$ dump_const_fold_opt
$ dump_dse_opt
$ dump_copy_prop_opt
$ dump_unreachable_elim_opt
$ dump_fun_opt)

let src_file =
Arg.(required & pos 0 (some non_dir_file) None & info [] ~docv:"files")

(* optimization options *)
let optimization_options =
let fold_constants =
let doc = "Enable constant folding" in
Arg.(value & flag & info [ "fold-constants" ] ~doc)
in
let eliminate_dead_stores =
let doc = "Enable dead store elimination" in
Arg.(value & flag & info [ "eliminate-dead-stores" ] ~doc)
in
let propagate_copies =
let doc = "Enable copy-propagation" in
Arg.(value & flag & info [ "propagate-copies" ] ~doc)
in
let eliminate_unreachable_code =
let doc = "Enable unreachable code eliminaiton" in
Arg.(value & flag & info [ "eliminate-unreachable-code" ] ~doc)
in
let optimize =
let doc = "enable optimizations" in
Arg.(value & flag & info [ "o"; "optimize" ] ~doc)
in
let set_options optimize constant_folding dead_store_elimination
copy_propagation unreachable_code_elimination =
if optimize then
(* TODO maybe warn if both --optimize and any of the other options are set, since those options will be redundant? *)
Settings.
{
constant_folding = true;
dead_store_elimination = true;
unreachable_code_elimination = true;
copy_propagation = true;
}
else
Settings.
{
constant_folding;
dead_store_elimination;
copy_propagation;
unreachable_code_elimination;
}
in
Cmdliner.Term.(
const set_options
$ optimize
$ fold_constants
$ eliminate_dead_stores
$ propagate_copies
$ eliminate_unreachable_code)

let cmd =
let doc = "A not-quite-C compiler" in
let info = Cmd.info "nqcc" ~doc in
Expand All @@ -173,6 +289,7 @@ let cmd =
$ extra_credit
$ int_only
$ stage
$ optimization_options
$ src_file)

let main () = exit (Cmd.eval cmd)
Expand Down
58 changes: 26 additions & 32 deletions lib/backend/codegen.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -109,15 +109,7 @@ let convert_type = function
("Internal error, converting type to assembly: " ^ Types.show t)
[@coverage off]

let tacky_type = function
(* note: this reports the type of ConstChar as SChar instead of Char, doesn't matter in this context *)
| Tacky.Constant c -> Const.type_of_const c
| Tacky.Var v -> (
try (Symbols.get v).t
with Not_found ->
failwith ("Internal error: " ^ v ^ " not in symbol table"))

let asm_type = convert_type % tacky_type
let asm_type = convert_type % Tacky.type_of_val

let convert_unop = function
| Tacky.Complement -> Assembly.Not
Expand Down Expand Up @@ -268,7 +260,7 @@ let classify_type tag =
classes

let classify_tacky_val v =
match tacky_type v with
match Tacky.type_of_val v with
| Structure tag -> classify_type tag
| Union tag -> classify_type tag
| _ ->
Expand Down Expand Up @@ -298,7 +290,7 @@ let classify_parameters tacky_vals return_on_stack =
| Constant _ ->
failwith "Internal error: constant byte array" [@coverage off]
in
let var_size = Type_utils.get_size (tacky_type v) in
let var_size = Type_utils.get_size (Tacky.type_of_val v) in
let classes = classify_tacky_val v in
let updated_int, updated_dbl, use_stack =
if List.hd classes = Mem then
Expand Down Expand Up @@ -355,7 +347,7 @@ let classify_parameters tacky_vals return_on_stack =

let classify_return_value retval =
let open Assembly in
let retval_type = tacky_type retval in
let retval_type = Tacky.type_of_val retval in
let classify_return_val_helper tag =
let classes = classify_type tag in
let var_name =
Expand Down Expand Up @@ -512,7 +504,7 @@ let convert_return_instruction = function
| Some v ->
let int_retvals, dbl_retvals, return_on_stack = classify_return_value v in
if return_on_stack then
let byte_count = Type_utils.get_size (tacky_type v) in
let byte_count = Type_utils.get_size (Tacky.type_of_val v) in
let get_ptr = Assembly.Mov (Quadword, Memory (BP, -8), Reg AX) in
let copy_into_ptr =
copy_bytes (convert_val v) (Assembly.Memory (AX, 0)) ~byte_count
Expand Down Expand Up @@ -540,15 +532,15 @@ let convert_return_instruction = function
return_ints @ return_dbls @ [ Ret ]

let convert_instruction = function
| Tacky.Copy { src; dst } when Type_utils.is_scalar (tacky_type src) ->
| Tacky.Copy { src; dst } when Type_utils.is_scalar (Tacky.type_of_val src) ->
let t = asm_type src in
let asm_src = convert_val src in
let asm_dst = convert_val dst in
Assembly.[ Mov (t, asm_src, asm_dst) ]
| Tacky.Copy { src; dst } ->
let asm_src = convert_val src in
let asm_dst = convert_val dst in
let byte_count = Type_utils.get_size (tacky_type src) in
let byte_count = Type_utils.get_size (Tacky.type_of_val src) in
copy_bytes asm_src asm_dst ~byte_count
| Tacky.Return maybe_val -> convert_return_instruction maybe_val
| Tacky.Unary { op = Not; src; dst } ->
Expand All @@ -571,7 +563,7 @@ let convert_instruction = function
Mov (dst_t, zero, asm_dst);
SetCC (E, asm_dst);
]
| Tacky.Unary { op = Negate; src; dst } when tacky_type src = Double ->
| Tacky.Unary { op = Negate; src; dst } when Tacky.type_of_val src = Double ->
let asm_src = convert_val src in
let asm_dst = convert_val dst in
let negative_zero = add_constant ~alignment:16 (-0.0) in
Expand Down Expand Up @@ -602,7 +594,7 @@ let convert_instruction = function
else
let signed =
if src_t = Double then false
else Type_utils.is_signed (tacky_type src1)
else Type_utils.is_signed (Tacky.type_of_val src1)
in
let cond_code = convert_cond_code signed op in
[
Expand All @@ -613,7 +605,7 @@ let convert_instruction = function
(* Division/modulo *)
| (Divide | Mod) when src_t <> Double ->
let result_reg = if op = Divide then Assembly.AX else DX in
if Type_utils.is_signed (tacky_type src1) then
if Type_utils.is_signed (Tacky.type_of_val src1) then
[
Mov (src_t, asm_src1, Reg AX);
Cdq src_t;
Expand All @@ -628,7 +620,7 @@ let convert_instruction = function
Mov (src_t, Reg result_reg, asm_dst);
]
| BitshiftLeft | BitshiftRight -> (
let is_signed = Type_utils.is_signed (tacky_type src1) in
let is_signed = Type_utils.is_signed (Tacky.type_of_val src1) in
let asm_op = convert_shift_op is_signed op in
let asm_t = asm_type src1 in
match asm_src2 with
Expand All @@ -651,26 +643,28 @@ let convert_instruction = function
Mov (src_t, asm_src1, asm_dst);
Binary { op = asm_op; t = src_t; src = asm_src2; dst = asm_dst };
])
| Tacky.Load { src_ptr; dst } when Type_utils.is_scalar (tacky_type dst) ->
| Tacky.Load { src_ptr; dst }
when Type_utils.is_scalar (Tacky.type_of_val dst) ->
let asm_src_ptr = convert_val src_ptr in
let asm_dst = convert_val dst in
let t = asm_type dst in
[ Mov (Quadword, asm_src_ptr, Reg R9); Mov (t, Memory (R9, 0), asm_dst) ]
| Tacky.Load { src_ptr; dst } ->
let asm_src_ptr = convert_val src_ptr in
let asm_dst = convert_val dst in
let byte_count = Type_utils.get_size (tacky_type dst) in
let byte_count = Type_utils.get_size (Tacky.type_of_val dst) in
Mov (Quadword, asm_src_ptr, Reg R9)
:: copy_bytes (Memory (R9, 0)) asm_dst ~byte_count
| Tacky.Store { src; dst_ptr } when Type_utils.is_scalar (tacky_type src) ->
| Tacky.Store { src; dst_ptr }
when Type_utils.is_scalar (Tacky.type_of_val src) ->
let asm_src = convert_val src in
let t = asm_type src in
let asm_dst_ptr = convert_val dst_ptr in
[ Mov (Quadword, asm_dst_ptr, Reg R9); Mov (t, asm_src, Memory (R9, 0)) ]
| Tacky.Store { src; dst_ptr } ->
let asm_src = convert_val src in
let asm_dst_ptr = convert_val dst_ptr in
let byte_count = Type_utils.get_size (tacky_type src) in
let byte_count = Type_utils.get_size (Tacky.type_of_val src) in
Mov (Quadword, asm_dst_ptr, Reg R9)
:: copy_bytes asm_src (Memory (R9, 0)) ~byte_count
| Tacky.GetAddress { src; dst } ->
Expand Down Expand Up @@ -756,7 +750,7 @@ let convert_instruction = function
| Tacky.UIntToDouble { src; dst } ->
let asm_src = convert_val src in
let asm_dst = convert_val dst in
if tacky_type src = Types.UChar then
if Tacky.type_of_val src = Types.UChar then
[
MovZeroExtend
{
Expand All @@ -767,7 +761,7 @@ let convert_instruction = function
};
Cvtsi2sd (Longword, Reg R9, asm_dst);
]
else if tacky_type src = Types.UInt then
else if Tacky.type_of_val src = Types.UInt then
[
MovZeroExtend
{
Expand Down Expand Up @@ -805,9 +799,9 @@ let convert_instruction = function
| Tacky.DoubleToUInt { src; dst } ->
let asm_src = convert_val src in
let asm_dst = convert_val dst in
if tacky_type dst = Types.UChar then
if Tacky.type_of_val dst = Types.UChar then
[ Cvttsd2si (Longword, asm_src, Reg R9); Mov (Byte, Reg R9, asm_dst) ]
else if tacky_type dst = Types.UInt then
else if Tacky.type_of_val dst = Types.UInt then
Assembly.
[
Cvttsd2si (Quadword, asm_src, Reg R9);
Expand Down Expand Up @@ -835,21 +829,21 @@ let convert_instruction = function
Binary { op = Add; t = Quadword; src = r; dst = asm_dst };
Label end_lbl;
]
| CopyToOffset { src; dst; offset } when Type_utils.is_scalar (tacky_type src)
->
| CopyToOffset { src; dst; offset }
when Type_utils.is_scalar (Tacky.type_of_val src) ->
[ Mov (asm_type src, convert_val src, PseudoMem (dst, offset)) ]
| CopyToOffset { src; dst; offset } ->
let asm_src = convert_val src in
let asm_dst = Assembly.PseudoMem (dst, offset) in
let byte_count = Type_utils.get_size (tacky_type src) in
let byte_count = Type_utils.get_size (Tacky.type_of_val src) in
copy_bytes asm_src asm_dst ~byte_count
| CopyFromOffset { src; dst; offset }
when Type_utils.is_scalar (tacky_type dst) ->
when Type_utils.is_scalar (Tacky.type_of_val dst) ->
[ Mov (asm_type dst, PseudoMem (src, offset), convert_val dst) ]
| CopyFromOffset { src; dst; offset } ->
let asm_src = Assembly.PseudoMem (src, offset) in
let asm_dst = convert_val dst in
let byte_count = Type_utils.get_size (tacky_type dst) in
let byte_count = Type_utils.get_size (Tacky.type_of_val dst) in
copy_bytes asm_src asm_dst ~byte_count
| AddPtr { ptr; index = Constant (Const.ConstLong c); scale; dst } ->
(* note that typechecker converts index to long
Expand Down
Loading

0 comments on commit 62aca9a

Please sign in to comment.