From 62aca9ac5b6f03ed82d7f269afa6764e4e0d7093 Mon Sep 17 00:00:00 2001 From: Nora Sandler Date: Wed, 19 Oct 2022 12:11:06 -0700 Subject: [PATCH] chapter 19: TACKY optimizations --- bin/main.ml | 137 +++++++++- lib/backend/codegen.ml | 58 ++-- lib/cfg.ml | 278 ++++++++++++++++++++ lib/cfg.mli | 34 +++ lib/compile.ml | 12 +- lib/compile.mli | 2 +- lib/const.ml | 10 + lib/context.ml | 2 + lib/dune | 14 +- lib/optimizations/address_taken.ml | 9 + lib/optimizations/address_taken.mli | 1 + lib/optimizations/constant_folding.ml | 227 ++++++++++++++++ lib/optimizations/constant_folding.mli | 1 + lib/optimizations/copy_prop.ml | 235 +++++++++++++++++ lib/optimizations/copy_prop.mli | 2 + lib/optimizations/dead_store_elim.ml | 179 +++++++++++++ lib/optimizations/dead_store_elim.mli | 2 + lib/optimizations/optimize.ml | 48 ++++ lib/optimizations/optimize.mli | 1 + lib/optimizations/optimize_utils.ml | 23 ++ lib/optimizations/optimize_utils.mli | 2 + lib/optimizations/unreachable_code_elim.ml | 109 ++++++++ lib/optimizations/unreachable_code_elim.mli | 1 + lib/settings.ml | 37 ++- lib/settings.mli | 19 +- lib/tacky.ml | 36 ++- lib/tacky_print.ml | 45 ++-- lib/util/cnums.ml | 129 ++++++++- lib/util/debug.ml | 18 ++ lib/util/num_interfaces.ml | 41 ++- 30 files changed, 1634 insertions(+), 78 deletions(-) create mode 100644 lib/cfg.ml create mode 100644 lib/cfg.mli create mode 100644 lib/context.ml create mode 100644 lib/optimizations/address_taken.ml create mode 100644 lib/optimizations/address_taken.mli create mode 100644 lib/optimizations/constant_folding.ml create mode 100644 lib/optimizations/constant_folding.mli create mode 100644 lib/optimizations/copy_prop.ml create mode 100644 lib/optimizations/copy_prop.mli create mode 100644 lib/optimizations/dead_store_elim.ml create mode 100644 lib/optimizations/dead_store_elim.mli create mode 100644 lib/optimizations/optimize.ml create mode 100644 lib/optimizations/optimize.mli create mode 100644 lib/optimizations/optimize_utils.ml create mode 100644 lib/optimizations/optimize_utils.mli create mode 100644 lib/optimizations/unreachable_code_elim.ml create mode 100644 lib/optimizations/unreachable_code_elim.mli create mode 100644 lib/util/debug.ml diff --git a/bin/main.ml b/bin/main.ml index abbb28a..784727d 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -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; @@ -54,7 +54,7 @@ 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; @@ -62,12 +62,13 @@ let driver target debug libs extra_credit int_only stage src = 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 *) @@ -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 @@ -173,6 +289,7 @@ let cmd = $ extra_credit $ int_only $ stage + $ optimization_options $ src_file) let main () = exit (Cmd.eval cmd) diff --git a/lib/backend/codegen.ml b/lib/backend/codegen.ml index bc7ce08..74f8fa3 100644 --- a/lib/backend/codegen.ml +++ b/lib/backend/codegen.ml @@ -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 @@ -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 | _ -> @@ -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 @@ -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 = @@ -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 @@ -540,7 +532,7 @@ 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 @@ -548,7 +540,7 @@ let convert_instruction = function | 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 } -> @@ -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 @@ -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 [ @@ -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; @@ -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 @@ -651,7 +643,8 @@ 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 @@ -659,10 +652,11 @@ let convert_instruction = function | 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 @@ -670,7 +664,7 @@ let convert_instruction = function | 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 } -> @@ -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 { @@ -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 { @@ -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); @@ -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 diff --git a/lib/cfg.ml b/lib/cfg.ml new file mode 100644 index 0000000..ac226cf --- /dev/null +++ b/lib/cfg.ml @@ -0,0 +1,278 @@ +open Batteries + +(* a simplified instruction type that can represent both TACKY and assembly instructions *) +type simple_instr = + | Label of string + | ConditionalJump of string + | UnconditionalJump of string + | Return + | Other + +module type INSTR = sig + type instr + + (* functions for classifying basic blocks *) + val simplify : instr -> simple_instr + val pp_instr : Format.formatter -> instr -> unit +end + +module Cfg (Instr : INSTR) = struct + type node_id = Entry | Block of int | Exit + + (* Cfg is parameterized by type of val we compute and type of instruction (we use both Tacky and assembly instructions )*) + + type 'v basic_block = { + id : node_id; + instructions : ('v * Instr.instr) list; + mutable preds : node_id list; + mutable succs : node_id list; + value : 'v; + } + + type 'v t = { + (* store basic blocks in association list, indexed by block # *) + basic_blocks : (int * 'v basic_block) list; + mutable entry_succs : node_id list; + mutable exit_preds : node_id list; + (* extra context for debugging *) + ctx : Context.t; + } + + (* useful functions *) + + let get_succs nd_id cfg = + match nd_id with + | Entry -> cfg.entry_succs + | Block n -> + let nd = List.assoc n cfg.basic_blocks in + nd.succs + | Exit -> [] + + let get_block_value blocknum cfg = + let nd = List.assoc blocknum cfg.basic_blocks in + nd.value + + let update_successors ~f nd_id g = + match nd_id with + | Entry -> g.entry_succs <- f g.entry_succs + | Block n -> + let blk = List.assoc n g.basic_blocks in + blk.succs <- f blk.succs + | Exit -> failwith "Internal error: malformed CFG" [@coverage off] + + let update_predecessors ~f nd_id g = + match nd_id with + | Entry -> failwith "Internal error: malformed CFG" [@coverage off] + | Block n -> + let blk = List.assoc n g.basic_blocks in + blk.preds <- f blk.preds + | Exit -> g.exit_preds <- f g.exit_preds + + let add_edge pred succ g = + let add_id nd_id id_list = + if List.mem nd_id id_list then id_list else nd_id :: id_list + in + update_successors ~f:(add_id succ) pred g; + update_predecessors ~f:(add_id pred) succ g + + let remove_edge pred succ g = + let remove_id nd_id id_list = Batteries.List.remove id_list nd_id in + update_successors ~f:(remove_id succ) pred g; + update_predecessors ~f:(remove_id pred) succ g + + (* constructing the CFG *) + let partition_into_basic_blocks instructions = + let f (finished_blocks, current_block) i = + match Instr.simplify i with + | Label _ -> + let finished_blocks' = + if List.is_empty current_block then finished_blocks + else List.rev current_block :: finished_blocks + in + (finished_blocks', [ i ]) + | ConditionalJump _ | UnconditionalJump _ | Return -> + let finished = List.rev (i :: current_block) in + (finished :: finished_blocks, []) + | Other -> (finished_blocks, i :: current_block) + in + let finished, last = List.fold_left f ([], []) instructions in + let all_blocks = + if List.is_empty last then finished else List.rev last :: finished + in + List.rev all_blocks + + let add_all_edges g = + (* build map from labels to the IDS of the blocks that they start with *) + let label_map = + List.fold + (fun lbl_map (_, blk) -> + match Instr.simplify (snd (List.hd blk.instructions)) with + | Label lbl -> Map.add lbl blk.id lbl_map + | _ -> lbl_map) + Map.empty g.basic_blocks + in + + (* add outgoing edges from a single basic block *) + let process_node (id_num, block) = + let next_block = + if id_num = fst (List.last g.basic_blocks) then Exit + else Block (id_num + 1) + in + let (), last_instr = List.last block.instructions in + + match Instr.simplify last_instr with + | Return -> add_edge block.id Exit g + | UnconditionalJump target -> + let target_id = Map.find target label_map in + add_edge block.id target_id g + | ConditionalJump target -> + let target_id = Map.find target label_map in + add_edge block.id next_block g; + add_edge block.id target_id g + | _ -> add_edge block.id next_block g + in + add_edge Entry (Block 0) g; + List.iter process_node g.basic_blocks + + let instructions_to_cfg ctx instructions = + let to_node idx instructions = + let ann x = ((), x) in + ( idx, + { + id = Block idx; + instructions = List.map ann instructions; + preds = []; + succs = []; + value = (); + } ) + in + let cfg = + { + basic_blocks = + List.mapi to_node (partition_into_basic_blocks instructions); + entry_succs = []; + exit_preds = []; + ctx; + } + in + + add_all_edges cfg; + cfg + + (* converting back to instructions *) + let cfg_to_instructions g = + let blk_to_instrs (_, { instructions; _ }) = List.map snd instructions in + List.concat_map blk_to_instrs g.basic_blocks + + (* working with annotations *) + let initialize_annotation cfg dummy_val = + let initialize_instruction (_, i) = (dummy_val, i) in + let initialize_block (idx, b) = + ( idx, + { + b with + instructions = List.map initialize_instruction b.instructions; + value = dummy_val; + } ) + in + { cfg with basic_blocks = List.map initialize_block cfg.basic_blocks } + + let strip_annotations cfg = initialize_annotation cfg () + + (* debugging *) + let print_graphviz tag pp_val cfg = + let filename = Debug.mk_filename tag cfg.ctx ".dot" in + let path = + if Filename.is_relative filename then + Filename.concat (Sys.getcwd ()) filename + else filename + in + let chan = open_out path in + let formatter = Format.formatter_of_out_channel chan in + let pp_node_id out = function + | Exit -> Format.pp_print_string out "exit" + | Entry -> Format.pp_print_string out "entry" + | Block n -> Format.fprintf out "block%d" n + in + let pp_annotated_instruction out (v, i) = + Format.pp_open_box out 0; + Format.fprintf out + "@{@,\ + @[%a@]@,\ + %a@}@," + Instr.pp_instr i pp_val v; + Format.pp_close_box out () + in + let pp_block_instructions out blk = + Format.pp_open_vbox out 0; + Format.pp_open_tag out "table"; + Format.fprintf out "@{@{%a@}@}@," pp_node_id + blk.id; + Format.pp_print_list pp_annotated_instruction out blk.instructions; + (* print block annotations *) + Format.fprintf out "@{%a@}@," pp_val blk.value; + Format.pp_close_tag out (); + Format.pp_close_box out () + in + let pp_block out (lbl, b) = + Format.fprintf out "block%d[label=<%a>]" lbl pp_block_instructions b + in + let pp_entry_edge out lbl = + Format.fprintf out "entry -> %a" pp_node_id lbl + in + let pp_edge i out succ = + Format.fprintf out "block%d -> %a" i pp_node_id succ + in + let pp_edges out ((lbl : int), (blk : 'a basic_block)) = + Format.open_vbox 0; + Format.pp_print_list (pp_edge lbl) out blk.succs; + Format.close_box () + in + Format.pp_set_tags formatter true; + Format.pp_open_vbox formatter 0; + Format.pp_print_string formatter "digraph {"; + Format.pp_print_break formatter 0 2; + Format.pp_open_vbox formatter 0; + Format.pp_print_string formatter "labeljust=l"; + Format.pp_print_cut formatter (); + Format.pp_print_string formatter "node[shape=\"box\"]"; + Format.pp_print_cut formatter (); + Format.pp_print_string formatter "entry[label=\"ENTRY\"]"; + Format.pp_print_cut formatter (); + Format.pp_print_string formatter "exit[label=\"EXIT\"]"; + Format.pp_print_cut formatter (); + Format.pp_print_list pp_block formatter cfg.basic_blocks; + Format.pp_print_cut formatter (); + Format.pp_print_list pp_entry_edge formatter cfg.entry_succs; + Format.pp_print_cut formatter (); + Format.pp_print_list pp_edges formatter cfg.basic_blocks; + Format.pp_close_box formatter (); + Format.pp_print_cut formatter (); + Format.pp_print_string formatter "}"; + Format.pp_close_box formatter (); + Format.pp_print_newline formatter (); + close_out chan; + let cmd = + Printf.sprintf "dot -Tpng %s -o %s" filename + (Filename.chop_extension filename ^ ".png") + in + if Sys.command cmd <> 0 then failwith ("graphviz fail: " ^ cmd) + else if Sys.command ("rm " ^ filename) <> 0 then + failwith "failed to remove DOT file" + [@@coverage off] +end + +module TackyCfg = Cfg (struct + type instr = Tacky.instruction + + let simplify = function + | Tacky.Label l -> Label l + | Jump target -> UnconditionalJump target + | JumpIfZero (_, target) -> ConditionalJump target + | JumpIfNotZero (_, target) -> ConditionalJump target + | Return _ -> Return + | _ -> Other + + let pp_instr = Tacky_print.pp_instruction ~escape_brackets:true + [@@coverage off] +end) diff --git a/lib/cfg.mli b/lib/cfg.mli new file mode 100644 index 0000000..1711a51 --- /dev/null +++ b/lib/cfg.mli @@ -0,0 +1,34 @@ +module TackyCfg : sig + type node_id = Entry | Block of int | Exit + + (* Cfg is parameterized by type of val we compute and type of instruction (we use both Tacky and assembly instructions )*) + + type 'v basic_block = { + id : node_id; + instructions : ('v * Tacky.instruction) list; + mutable preds : node_id list; + mutable succs : node_id list; + value : 'v; + } + + type 'v t = { + (* store basic blocks in association list, indexed by block # *) + basic_blocks : (int * 'v basic_block) list; + mutable entry_succs : node_id list; + mutable exit_preds : node_id list; + ctx : Context.t; + } + + val instructions_to_cfg : Context.t -> Tacky.instruction list -> unit t + val cfg_to_instructions : 'v t -> Tacky.instruction list + val get_succs : node_id -> 'v t -> node_id list + val get_block_value : int -> 'v t -> 'v + val add_edge : node_id -> node_id -> 'v t -> unit + val remove_edge : node_id -> node_id -> 'v t -> unit + val initialize_annotation : 'a t -> 'b -> 'b t + val strip_annotations : 'a t -> unit t + + (* debugging *) + val print_graphviz : + string -> (Format.formatter -> 'v -> unit) -> 'v t -> unit +end diff --git a/lib/compile.ml b/lib/compile.ml index d1c0317..d4dae3f 100644 --- a/lib/compile.ml +++ b/lib/compile.ml @@ -1,6 +1,6 @@ open Batteries -let compile stage src_file = +let compile stage optimizations src_file = (* read in the file - TODO use streams? *) let source_lines = File.lines_of src_file in (* concatenate all the lines *) @@ -32,14 +32,18 @@ let compile stage src_file = (* Convert the AST to TACKY *) let tacky = Tacky_gen.gen validated_ast3 in (* print to file (src filename with .debug.tacky extension) if debug is enabled*) - Tacky_print.debug_print_tacky src_file tacky; + Tacky_print.debug_print_tacky ~tag:"pre_opt" ~file:src_file tacky; + (* optimize it! *) + let optimized_tacky = Optimize.optimize optimizations src_file tacky in + Tacky_print.debug_print_tacky ~tag:"post_opt" ~file:src_file + optimized_tacky; if stage = Settings.Tacky then () else (* Assembly generation has three steps: * 1. convert TACKY to assembly *) - let asm_ast = Codegen.gen tacky in + let asm_ast = Codegen.gen optimized_tacky in (* print pre-pseudoreg-allocation assembly if debug enabled *) - (if !Settings.debug then + (if !Settings.debug.dump_asm then let prealloc_filename = Filename.chop_extension src_file ^ ".prealloc.debug.s" in diff --git a/lib/compile.mli b/lib/compile.mli index addba2a..bc07a70 100644 --- a/lib/compile.mli +++ b/lib/compile.mli @@ -1 +1 @@ -val compile : Settings.stage -> string -> unit +val compile : Settings.stage -> Settings.optimizations -> string -> unit diff --git a/lib/const.ml b/lib/const.ml index 1016be5..4c796a0 100644 --- a/lib/const.ml +++ b/lib/const.ml @@ -10,6 +10,7 @@ type t = | ConstUInt of UInt32.t | ConstULong of UInt64.t | ConstDouble of Float.t +[@@deriving eq, ord] (* print functions for debugging *) let show = function @@ -36,3 +37,12 @@ let type_of_const = function | ConstUInt _ -> Types.UInt | ConstULong _ -> Types.ULong | ConstDouble _ -> Types.Double + +let to_int = function + | ConstChar c -> Int8.to_int c + | ConstUChar c -> UInt8.to_int c + | ConstInt i -> Int32.to_int i + | ConstLong l -> Int64.to_int l + | ConstUInt u -> UInt32.to_int u + | ConstULong ul -> UInt64.to_int ul + | ConstDouble d -> Float.to_int d diff --git a/lib/context.ml b/lib/context.ml new file mode 100644 index 0000000..0128f31 --- /dev/null +++ b/lib/context.ml @@ -0,0 +1,2 @@ +(* Extra context about a TACKY function; used primarily for debugging *) +type t = { filename : string; fun_name : string; params : string list } diff --git a/lib/dune b/lib/dune index e3bd448..ee56aef 100644 --- a/lib/dune +++ b/lib/dune @@ -4,23 +4,32 @@ (name nqcc) (inline_tests) (modules + address_taken ast assembly assembly_symbols + cfg cnums codegen collect_switch_cases compile const const_convert + constant_folding + context + copy_prop + dead_store_elim + debug emit extended_big_int + optimize_utils identifier_resolution initializers instruction_fixup label_loops lex num_interfaces + optimize parse replace_pseudos rounding @@ -35,8 +44,9 @@ types type_utils settings - unique_ids - validate_labels) + validate_labels + unique_ids + unreachable_code_elim) (libraries batteries ppx_deriving ppx_inline_test camlp-streams bisect_ppx) (preprocess (pps ppx_deriving.show ppx_deriving.eq ppx_deriving.ord ppx_inline_test)) diff --git a/lib/optimizations/address_taken.ml b/lib/optimizations/address_taken.ml new file mode 100644 index 0000000..8e32f60 --- /dev/null +++ b/lib/optimizations/address_taken.ml @@ -0,0 +1,9 @@ +open Batteries + +let analyze instrs = + let addr_taken = function + | Tacky.GetAddress { src = Var v; _ } -> Some v + | _ -> None + in + + Set.of_list (List.filter_map addr_taken instrs) \ No newline at end of file diff --git a/lib/optimizations/address_taken.mli b/lib/optimizations/address_taken.mli new file mode 100644 index 0000000..688015c --- /dev/null +++ b/lib/optimizations/address_taken.mli @@ -0,0 +1 @@ +val analyze : Tacky.instruction list -> string Batteries.Set.t \ No newline at end of file diff --git a/lib/optimizations/constant_folding.ml b/lib/optimizations/constant_folding.ml new file mode 100644 index 0000000..bba7349 --- /dev/null +++ b/lib/optimizations/constant_folding.ml @@ -0,0 +1,227 @@ +open Cnums +open Num_interfaces + +let evaluate_cast src_const dst = + let dst_type = Tacky.type_of_val dst in + let converted_src = + try Const_convert.const_convert dst_type src_const + with Failure _ -> + (* Undefined behavior (e.g. out of range conversion) so just use 0; + * behavior is undefined if this cast is ever executed. *) + Const_convert.const_convert dst_type Const.int_zero + in + + Some (Tacky.Copy { src = Constant converted_src; dst }) + +module type Evaluatable = sig + include BasicNumLike + + val to_const : t -> Const.t +end + +module ConstEvaluator (E : Evaluatable) = struct + open E.Infix + open E.Compare + + let int_of_bool b = if b then Const.int_one else Const.int_zero + + let eval_unop v = function + | Tacky.Not -> int_of_bool (v = E.zero) + | Tacky.Complement -> E.to_const (E.lognot v) + | Tacky.Negate -> E.to_const (E.neg v) + + let eval_binop v1 v2 = function + (* result is same type as source values *) + | Tacky.Add -> E.to_const (v1 + v2) + | Subtract -> E.to_const (v1 - v2) + | Multiply -> E.to_const (v1 * v2) + | Divide -> ( + (* don't fail on division by zero; it may not actually be executed at runtime *) + try E.to_const (v1 / v2) with Division_by_zero -> E.to_const E.zero) + | Mod -> ( + try E.(to_const (rem v1 v2)) + with Division_by_zero -> E.to_const E.zero) + | BitwiseAnd -> E.(to_const (logand v1 v2)) + | BitwiseOr -> E.(to_const (logor v1 v2)) + | BitwiseXor -> E.(to_const (logxor v1 v2)) + (* result is int *) + | Equal -> int_of_bool (v1 = v2) + | NotEqual -> int_of_bool (v1 <> v2) + | LessThan -> int_of_bool (v1 < v2) + | LessOrEqual -> int_of_bool (v1 <= v2) + | GreaterThan -> int_of_bool (v1 > v2) + | GreaterOrEqual -> int_of_bool (v1 >= v2) + | BitshiftLeft | BitshiftRight -> + failwith "Internal error: bitshift operations aren't handled here" + + let eval_left_shift v shift_count = E.(to_const (shift_left v shift_count)) + let eval_right_shift v shift_count = E.(to_const (shift_right v shift_count)) +end + +module IntEvaluator = ConstEvaluator (struct + include Batteries.Int32 + + let to_const i = Const.ConstInt i +end) + +let%test "not_zero" = + IntEvaluator.eval_unop Int32.zero Tacky.Not = Const.int_one + +let%test "not_one" = IntEvaluator.eval_unop Int32.one Tacky.Not = Const.int_zero + +module LongEvaluator = ConstEvaluator (struct + include Batteries.Int64 + + let to_const l = Const.ConstLong l +end) + +module UIntEvaluator = ConstEvaluator (struct + include UInt32 + + let to_const u = Const.ConstUInt u +end) + +module ULongEvaluator = ConstEvaluator (struct + include UInt64 + + let to_const ul = Const.ConstULong ul +end) + +module CharEvaluator = ConstEvaluator (struct + include Int8 + + let to_const c = Const.ConstChar c +end) + +module UCharEvaluator = ConstEvaluator (struct + include UInt8 + + let to_const uc = Const.ConstUChar uc +end) + +module DoubleEvaluator = ConstEvaluator (struct + include Float + + let to_const d = Const.ConstDouble d + let rem _ = (failwith "Remainder of double not supported" [@coverage off]) + + let lognot _ = + (failwith "Bitwise complement of double not supported" [@coverage off]) + + let logand _ = + (failwith "Bitwise complement of double not supported" [@coverage off]) + + let logor _ = + (failwith "Bitwise complement of double not supported" [@coverage off]) + + let logxor _ = + (failwith "Bitwise complement of double not supported" [@coverage off]) + + let shift_left _ = + (failwith "Bitwise shift of double not supported" [@coverage off]) + + let shift_right _ = + (failwith "Bitwise shift of double not supported" [@coverage off]) +end) + +let evaluate_unop op = function + | Const.ConstChar c -> CharEvaluator.eval_unop c op + | ConstUChar uc -> UCharEvaluator.eval_unop uc op + | ConstInt i -> IntEvaluator.eval_unop i op + | ConstUInt u -> UIntEvaluator.eval_unop u op + | ConstLong l -> LongEvaluator.eval_unop l op + | ConstULong ul -> ULongEvaluator.eval_unop ul op + | ConstDouble d -> DoubleEvaluator.eval_unop d op + +let evaluate_binop op v1 v2 = + match (v1, v2) with + | Const.ConstChar c1, Const.ConstChar c2 -> CharEvaluator.eval_binop c1 c2 op + | ConstUChar c1, ConstUChar c2 -> UCharEvaluator.eval_binop c1 c2 op + | ConstInt i1, ConstInt i2 -> IntEvaluator.eval_binop i1 i2 op + | ConstUInt i1, ConstUInt i2 -> UIntEvaluator.eval_binop i1 i2 op + | ConstLong l1, ConstLong l2 -> LongEvaluator.eval_binop l1 l2 op + | ConstULong l1, ConstULong l2 -> ULongEvaluator.eval_binop l1 l2 op + | ConstDouble d1, ConstDouble d2 -> DoubleEvaluator.eval_binop d1 d2 op + | _ -> failwith "Internal error: mismatched types" [@coverage off] + +let evaluate_leftshift v1 v2 = + let shift_count = Const.to_int v2 in + match v1 with + | Const.ConstChar c -> CharEvaluator.eval_left_shift c shift_count + | ConstUChar uc -> UCharEvaluator.eval_left_shift uc shift_count + | ConstInt i -> IntEvaluator.eval_left_shift i shift_count + | ConstUInt u -> UIntEvaluator.eval_left_shift u shift_count + | ConstLong l -> LongEvaluator.eval_left_shift l shift_count + | ConstULong ul -> ULongEvaluator.eval_left_shift ul shift_count + | ConstDouble _ -> + failwith "Internal error: bitshift operation applied to double!" + +let evaluate_rightshift v1 v2 = + let shift_count = Const.to_int v2 in + match v1 with + | Const.ConstChar c -> CharEvaluator.eval_right_shift c shift_count + | ConstUChar uc -> UCharEvaluator.eval_right_shift uc shift_count + | ConstInt i -> IntEvaluator.eval_right_shift i shift_count + | ConstUInt u -> UIntEvaluator.eval_right_shift u shift_count + | ConstLong l -> LongEvaluator.eval_right_shift l shift_count + | ConstULong ul -> ULongEvaluator.eval_right_shift ul shift_count + | ConstDouble _ -> + failwith "Internal error: bitshift operation applied to double!" + +let is_zero c = evaluate_unop Not c = Const.ConstInt Int32.one + +let optimize_instruction = function + | Tacky.Unary { op; src = Constant c; dst } -> + let new_src = evaluate_unop op c in + Some (Tacky.Copy { src = Constant new_src; dst }) + | Binary { op = BitshiftLeft; src1 = Constant c1; src2 = Constant c2; dst } -> + let new_src = evaluate_leftshift c1 c2 in + Some (Copy { src = Constant new_src; dst }) + | Binary { op = BitshiftRight; src1 = Constant c1; src2 = Constant c2; dst } + -> + let new_src = evaluate_rightshift c1 c2 in + Some (Copy { src = Constant new_src; dst }) + | Binary { op; src1 = Constant c1; src2 = Constant c2; dst } -> + let new_src = evaluate_binop op c1 c2 in + Some (Copy { src = Constant new_src; dst }) + | JumpIfZero (Constant c, target) -> + if is_zero c then Some (Jump target) else None + | JumpIfNotZero (Constant c, target) -> + if is_zero c then None else Some (Jump target) + (* type conversions *) + | Truncate { src = Constant c; dst } -> evaluate_cast c dst + | SignExtend { src = Constant c; dst } -> evaluate_cast c dst + | ZeroExtend { src = Constant c; dst } -> evaluate_cast c dst + | DoubleToInt { src = Constant c; dst } -> evaluate_cast c dst + | DoubleToUInt { src = Constant c; dst } -> evaluate_cast c dst + | IntToDouble { src = Constant c; dst } -> evaluate_cast c dst + | UIntToDouble { src = Constant c; dst } -> evaluate_cast c dst + (* if this copies b/t values of different types, we'll replace it with a copy using + * src constant w/ same type as dst *) + | Copy { src = Constant c; dst } -> evaluate_cast c dst + (* other instructions can't be constnat folded *) + | i -> Some i + +let debug_print tag ctx instructions = + if + !Settings.debug.dump_optimizations.constant_folding + && Debug.is_dump_target ctx + then ( + let tag' = tag ^ ".const_fold" in + let filename = Debug.mk_filename tag' ctx ".tacky" in + let chan = open_out filename in + let formatter = Format.formatter_of_out_channel chan in + let open Context in + Tacky_print.pp_function_definition false ctx.fun_name ctx.params formatter + instructions; + Format.pp_print_newline formatter (); + close_out chan) + else () + +let optimize ctx instructions = + debug_print "pre" ctx instructions; + let optimized_instructions = + List.filter_map optimize_instruction instructions + in + debug_print "post" ctx optimized_instructions; + optimized_instructions diff --git a/lib/optimizations/constant_folding.mli b/lib/optimizations/constant_folding.mli new file mode 100644 index 0000000..8b8036a --- /dev/null +++ b/lib/optimizations/constant_folding.mli @@ -0,0 +1 @@ +val optimize : Context.t -> Tacky.instruction list -> Tacky.instruction list diff --git a/lib/optimizations/copy_prop.ml b/lib/optimizations/copy_prop.ml new file mode 100644 index 0000000..347e7d2 --- /dev/null +++ b/lib/optimizations/copy_prop.ml @@ -0,0 +1,235 @@ +open Batteries + +module G = struct + include Cfg.TackyCfg +end + +(* represent a reaching copy as pair of tacky vals *) +type cp = { src : Tacky.tacky_val; dst : Tacky.tacky_val } [@@deriving ord] + +let pp_cp fmt copy = + Format.fprintf fmt "%a = %a" Tacky_print.pp_tacky_val copy.dst + Tacky_print.pp_tacky_val copy.src + +(* be careful to always use our own eq/compare instead of built-in one b/c 0.0 and -0.0 compare equal, and NaN doesn't equal itself, using (=) *) +module ReachingCopies = Set.Make (struct + type t = cp + + let compare = compare_cp +end) + +let eq = Tacky.equal_tacky_val + +let debug_print ~extra_tag cfg = + if + !Settings.debug.dump_optimizations.copy_propagation + && Debug.is_dump_target G.(cfg.ctx) + then + let copies_printer fmt copies = + Format.pp_open_box fmt 0; + Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.pp_print_string fmt ", ") + pp_cp fmt + (ReachingCopies.to_list copies); + Format.pp_close_box fmt () + in + let tag = "copy_prop." ^ extra_tag in + G.(print_graphviz tag copies_printer cfg) + +(* check whether two operands of Copy are, for our purposes, the same type *) +let same_type v1 v2 = + let t1, t2 = Tacky.(type_of_val v1, type_of_val v2) in + t1 = t2 || Type_utils.is_signed t1 = Type_utils.is_signed t2 + +let var_is_aliased aliased_vars = function + | Tacky.Constant _ -> false + (* all static variables are potentially aliased *) + | Var v when Set.mem v aliased_vars || Optimize_utils.is_static v -> true + | _ -> false + +let filter_updated copies updated = + (* A copy is killed if we've updated its src or destination *) + let is_killed cp = eq cp.src updated || eq cp.dst updated in + ReachingCopies.filter (not % is_killed) copies + +let transfer aliased_vars (block : ReachingCopies.t G.basic_block) + (initial_reaching_copies : ReachingCopies.t) = + let is_aliased = var_is_aliased aliased_vars in + let process_instr current_copies (_, i) = + let annotated_instr = (current_copies, i) in + let new_copies = + match i with + | Tacky.Copy { src; dst } -> + if ReachingCopies.mem { src = dst; dst = src } current_copies then + (* dst and src already have the same value, so there's no effect *) + current_copies + else if same_type src dst then + filter_updated current_copies dst |> ReachingCopies.add { src; dst } + (* if types are the same, kill dst but don't count this as a reaching copy *) + else filter_updated current_copies dst + | FunCall { dst; _ } -> + (* first filter out copies killed by dst *) + let copies' = + match dst with + | Some d -> filter_updated current_copies d + | None -> current_copies + in + + (* then filter out copies that are static *) + ReachingCopies.filter + (fun cp -> not (is_aliased cp.src || is_aliased cp.dst)) + copies' + | Store _ -> + let not_killed cp = not (is_aliased cp.src || is_aliased cp.dst) in + ReachingCopies.filter not_killed current_copies + | i -> ( + match Optimize_utils.get_dst i with + | Some dst -> filter_updated current_copies dst + | None -> current_copies) + in + (new_copies, annotated_instr) + in + let final_reaching_copies, annotated_instructions = + List.fold_left_map process_instr initial_reaching_copies block.instructions + in + { + block with + instructions = annotated_instructions; + value = final_reaching_copies; + } + +let meet ident cfg (block : ReachingCopies.t G.basic_block) = + (* arbitrartily choose value *) + let update_incoming incoming = function + | G.Entry -> ReachingCopies.empty + | Exit -> failwith "Internal error" [@coverage off] + | Block n -> + (* get current value for this block *) + let v = G.get_block_value n cfg in + ReachingCopies.inter v incoming + in + + List.fold update_incoming ident block.preds + +let collect_all_copies cfg = + let f = function + | Tacky.Copy { src; dst } when same_type src dst -> Some { src; dst } + | _ -> None + in + cfg |> G.cfg_to_instructions |> List.filter_map f |> ReachingCopies.of_list + +let find_reaching_copies aliased_vars cfg = + let ident = collect_all_copies cfg in + let starting_cfg = G.initialize_annotation cfg ident in + + let rec process_worklist current_cfg + (worklist : (int * ReachingCopies.t G.basic_block) list) = + debug_print ~extra_tag:"in_progress" current_cfg; + match worklist with + | [] -> current_cfg (* we're done *) + | (block_idx, blk) :: rest -> + let old_annotation = blk.value in + let incoming_copies = meet ident current_cfg blk in + let block' = transfer aliased_vars blk incoming_copies in + let updated_cfg = + G. + { + current_cfg with + basic_blocks = + List.modify block_idx (fun _ -> block') current_cfg.basic_blocks; + } + in + let new_worklist = + if ReachingCopies.equal old_annotation block'.value then rest + else + (* add successors to worklist *) + List.fold + (fun wklist -> function + | G.Exit -> wklist + | Entry -> + failwith "Internal error: malformed CFG" [@coverage off] + | Block n -> + if List.mem_assoc n wklist then wklist + else wklist @ [ (n, List.assoc n updated_cfg.basic_blocks) ]) + rest block'.succs + in + process_worklist updated_cfg new_worklist + in + process_worklist starting_cfg starting_cfg.basic_blocks + +let rewrite_instruction (reaching_copies, i) = + (* filter out useless copies *) + match i with + | Tacky.Copy { src; dst } + when ReachingCopies.mem { src; dst } reaching_copies + || ReachingCopies.mem { src = dst; dst = src } reaching_copies -> + None + | _ -> + (* we're not filtering it out, so replace src instead *) + let replace op = + match op with + (* we never replace constants *) + | Tacky.Constant _ -> op + | Tacky.Var _ -> ( + try + (* find th reaching copy whose destination is op *) + let matching_copy = + reaching_copies + |> ReachingCopies.to_list + |> List.find (fun cp -> eq cp.dst op) + in + matching_copy.src + (* didn't find one, just return op itself *) + with Not_found -> op) + in + + let new_i = + match i with + | Tacky.Copy { src; dst } -> Tacky.Copy { src = replace src; dst } + | Unary u -> Unary { u with src = replace u.src } + | Binary b -> + Binary { b with src1 = replace b.src1; src2 = replace b.src2 } + | Return v -> Return (Option.map replace v) + | JumpIfZero (v, target) -> JumpIfZero (replace v, target) + | JumpIfNotZero (v, target) -> JumpIfNotZero (replace v, target) + | FunCall f -> FunCall { f with args = List.map replace f.args } + | SignExtend sx -> SignExtend { sx with src = replace sx.src } + | ZeroExtend zx -> ZeroExtend { zx with src = replace zx.src } + | DoubleToInt d2i -> DoubleToInt { d2i with src = replace d2i.src } + | IntToDouble i2d -> IntToDouble { i2d with src = replace i2d.src } + | DoubleToUInt d2u -> DoubleToUInt { d2u with src = replace d2u.src } + | UIntToDouble u2d -> UIntToDouble { u2d with src = replace u2d.src } + | Truncate t -> Truncate { t with src = replace t.src } + | Load l -> Load { l with src_ptr = replace l.src_ptr } + | Store s -> Store { s with src = replace s.src } + | AddPtr ap -> + AddPtr { ap with ptr = replace ap.ptr; index = replace ap.index } + | CopyToOffset c2o -> CopyToOffset { c2o with src = replace c2o.src } + | CopyFromOffset cfo -> ( + match replace (Var cfo.src) with + | Var replaced -> CopyFromOffset { cfo with src = replaced } + | Constant _ -> failwith "internal error" [@coverage off]) + | Label _ | Jump _ | GetAddress _ -> i + in + Some (reaching_copies, new_i) + +let optimize aliased_vars (cfg : 'a Cfg.TackyCfg.t) : 'b Cfg.TackyCfg.t = + let annotated_cfg = find_reaching_copies aliased_vars cfg in + let _ = debug_print ~extra_tag:"annotated" annotated_cfg in + let rewrite_block (idx, block) = + ( idx, + G. + { + block with + instructions = List.filter_map rewrite_instruction block.instructions; + } ) + in + let transformed_cfg = + { + annotated_cfg with + basic_blocks = List.map rewrite_block annotated_cfg.basic_blocks; + } + in + let _ = debug_print ~extra_tag:"transformed" transformed_cfg in + (* remove annotations since we no longer need them *) + G.strip_annotations transformed_cfg diff --git a/lib/optimizations/copy_prop.mli b/lib/optimizations/copy_prop.mli new file mode 100644 index 0000000..9b719a2 --- /dev/null +++ b/lib/optimizations/copy_prop.mli @@ -0,0 +1,2 @@ +val optimize : + string Batteries.Set.t -> unit Cfg.TackyCfg.t -> unit Cfg.TackyCfg.t diff --git a/lib/optimizations/dead_store_elim.ml b/lib/optimizations/dead_store_elim.ml new file mode 100644 index 0000000..b507faf --- /dev/null +++ b/lib/optimizations/dead_store_elim.ml @@ -0,0 +1,179 @@ +open Batteries + +module G = struct + include Cfg.TackyCfg +end + +type annotated_block = string Set.t G.basic_block + +let debug_print ~extra_tag cfg = + if + !Settings.debug.dump_optimizations.dead_store_elimination + && Debug.is_dump_target G.(cfg.ctx) + then + let livevar_printer fmt live_vars = + Format.pp_open_box fmt 0; + Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.pp_print_string fmt ", ") + Format.pp_print_string fmt (Set.to_list live_vars); + Format.pp_close_box fmt () + in + let tag = "dse." ^ extra_tag in + G.(print_graphviz tag livevar_printer cfg) + +let transfer static_and_aliased_vars (block : annotated_block) + (end_live_variables : string Set.t) = + let remove_var var var_set = + match var with + | Tacky.Var v -> Set.remove v var_set + | Tacky.Constant _ -> failwith "Internal error" [@coverage off] + in + + let add_var v var_set = + match v with + | Tacky.Constant _ -> var_set + | Var name -> Set.add name var_set + in + let add_vars used_vals var_set = List.fold_right add_var used_vals var_set in + + let process_instr current_live_vars (_, i) = + let annotated_instr = (current_live_vars, i) in + let new_live_vars = + match i with + | Tacky.Binary b -> + current_live_vars |> remove_var b.dst |> add_vars [ b.src1; b.src2 ] + | Tacky.Unary u -> current_live_vars |> remove_var u.dst |> add_var u.src + | JumpIfZero (v, _) -> add_var v current_live_vars + | JumpIfNotZero (v, _) -> add_var v current_live_vars + | Copy c -> current_live_vars |> remove_var c.dst |> add_var c.src + | Return (Some v) -> current_live_vars |> add_var v + | FunCall f -> + let live_vars' = + match f.dst with + | Some d -> remove_var d current_live_vars + | None -> current_live_vars + in + let live_vars'' = add_vars f.args live_vars' in + Set.union live_vars'' static_and_aliased_vars + (* part II instructions *) + | SignExtend sx -> + current_live_vars |> remove_var sx.dst |> add_var sx.src + | ZeroExtend zx -> + current_live_vars |> remove_var zx.dst |> add_var zx.src + | DoubleToInt d2i -> + current_live_vars |> remove_var d2i.dst |> add_var d2i.src + | IntToDouble i2d -> + current_live_vars |> remove_var i2d.dst |> add_var i2d.src + | DoubleToUInt d2u -> + current_live_vars |> remove_var d2u.dst |> add_var d2u.src + | UIntToDouble u2d -> + current_live_vars |> remove_var u2d.dst |> add_var u2d.src + | Truncate t -> current_live_vars |> remove_var t.dst |> add_var t.src + | AddPtr { ptr; index; dst; _ } -> + current_live_vars |> remove_var dst |> add_vars [ ptr; index ] + | GetAddress { dst; _ } -> remove_var dst current_live_vars + | Load { src_ptr; dst } -> + current_live_vars + |> remove_var dst + |> add_var src_ptr + |> Set.union static_and_aliased_vars + | Store { src; dst_ptr } -> add_vars [ src; dst_ptr ] current_live_vars + | CopyToOffset { src; _ } -> add_var src current_live_vars + | CopyFromOffset { src; dst; _ } -> + current_live_vars |> remove_var dst |> add_var (Var src) + (* instructions with no impact *) + | Jump _ | Label _ | Return None -> current_live_vars + in + (new_live_vars, annotated_instr) + in + let incoming_live_vars, annotated_reversed_instructions = + block.instructions + |> List.rev + |> List.fold_left_map process_instr end_live_variables + in + { + block with + instructions = List.rev annotated_reversed_instructions; + value = incoming_live_vars; + } + +let meet static_vars cfg (block : annotated_block) = + let update_live live = function + | G.Entry -> failwith "Internal error: malformed CFG" [@coverage off] + | Exit -> Set.union live static_vars + | Block n -> Set.union live (G.get_block_value n cfg) + in + List.fold update_live Set.empty block.succs + +let find_live_variables static_vars aliased_vars (cfg : unit G.t) = + let starting_cfg = G.initialize_annotation cfg Set.empty in + let static_and_aliased_vars = Set.union static_vars aliased_vars in + let rec process_worklist current_cfg (worklist : (int * annotated_block) list) + = + debug_print ~extra_tag:"in_progress" current_cfg; + match worklist with + | [] -> current_cfg (* we're done*) + | (block_idx, blk) :: rest -> + let old_annotation = blk.value in + let live_vars_at_exit = meet static_vars current_cfg blk in + let block' = transfer static_and_aliased_vars blk live_vars_at_exit in + let updated_cfg = + G. + { + current_cfg with + basic_blocks = + List.modify block_idx (fun _ -> block') current_cfg.basic_blocks; + } + in + let new_worklist = + if Set.equal old_annotation block'.value then rest + else + List.fold + (fun wklist -> function + | G.Entry -> wklist + | Exit -> + failwith "Internal error: malformed CFG" [@coverage off] + | Block n -> + if List.mem_assoc n wklist then wklist + else (n, List.assoc n updated_cfg.basic_blocks) :: wklist) + rest block'.preds + in + process_worklist updated_cfg new_worklist + in + process_worklist starting_cfg (List.rev starting_cfg.basic_blocks) + +let is_dead_store (live_vars, i) = + match i with + | Tacky.FunCall _ -> false + | Tacky.Store _ -> false + | _ -> ( + match Optimize_utils.get_dst i with + | Some (Var v) when not (Set.mem v live_vars) -> true + | _ -> false) + +let optimize aliased_vars cfg = + let entry_is_static = function + | v, Symbols.{ attrs = StaticAttr _; _ } -> Some v + | _ -> None + in + let static_vars = + Symbols.bindings () |> List.filter_map entry_is_static |> Set.of_list + in + let annotated_cfg = find_live_variables static_vars aliased_vars cfg in + let _ = debug_print ~extra_tag:"annotated" annotated_cfg in + let rewrite_block (idx, block) = + ( idx, + G. + { + block with + instructions = List.filter (not % is_dead_store) block.instructions; + } ) + in + let transformed_cfg = + { + annotated_cfg with + basic_blocks = List.map rewrite_block annotated_cfg.basic_blocks; + } + in + let _ = debug_print ~extra_tag:"transformed" transformed_cfg in + G.strip_annotations transformed_cfg diff --git a/lib/optimizations/dead_store_elim.mli b/lib/optimizations/dead_store_elim.mli new file mode 100644 index 0000000..9b719a2 --- /dev/null +++ b/lib/optimizations/dead_store_elim.mli @@ -0,0 +1,2 @@ +val optimize : + string Batteries.Set.t -> unit Cfg.TackyCfg.t -> unit Cfg.TackyCfg.t diff --git a/lib/optimizations/optimize.ml b/lib/optimizations/optimize.ml new file mode 100644 index 0000000..bafa6d2 --- /dev/null +++ b/lib/optimizations/optimize.ml @@ -0,0 +1,48 @@ +open Batteries +open Cfg +(* main optimization pipeline *) + +let rec optimize_fun ctx (opts : Settings.optimizations) = function + | [] -> [] + | instructions -> + let aliased_vars = Address_taken.analyze instructions in + (* run the optimization pipeline *) + let constant_folded = + if opts.constant_folding then Constant_folding.optimize ctx instructions + else instructions + in + let cfg = TackyCfg.instructions_to_cfg ctx constant_folded in + let cfg1 = + if opts.unreachable_code_elimination then + Unreachable_code_elim.optimize cfg + else cfg + in + let cfg2 = + if opts.copy_propagation then Copy_prop.optimize aliased_vars cfg1 + else cfg1 + in + let cfg3 = + if opts.dead_store_elimination then + Dead_store_elim.optimize aliased_vars cfg2 + else cfg2 + in + (* once we're done optimization, convert back to instruction list *) + let optimized_instructions = TackyCfg.cfg_to_instructions cfg3 in + + if List.equal Tacky.equal_instruction instructions optimized_instructions + then optimized_instructions + (* If we found any optimizations, run it again! *) + else optimize_fun ctx opts optimized_instructions + +let optimize opts src_file tacky_program = + let open Tacky in + let (Program tls) = tacky_program in + let handle_tl = function + | Function f -> + let ctx = + Context.{ filename = src_file; fun_name = f.name; params = f.params } + in + Function { f with body = optimize_fun ctx opts f.body } + | other_tl -> other_tl + in + Program (List.map handle_tl tls) diff --git a/lib/optimizations/optimize.mli b/lib/optimizations/optimize.mli new file mode 100644 index 0000000..50a252b --- /dev/null +++ b/lib/optimizations/optimize.mli @@ -0,0 +1 @@ +val optimize : Settings.optimizations -> string -> Tacky.t -> Tacky.t diff --git a/lib/optimizations/optimize_utils.ml b/lib/optimizations/optimize_utils.ml new file mode 100644 index 0000000..e178efd --- /dev/null +++ b/lib/optimizations/optimize_utils.ml @@ -0,0 +1,23 @@ +(* a tiny helper function to get the destination of a tacky instruction; useful for both copy propagation and dead store elimination *) +let get_dst = function + | Tacky.Copy { dst; _ } -> Some dst + | FunCall { dst; _ } -> dst + | Unary { dst; _ } -> Some dst + | Binary { dst; _ } -> Some dst + | SignExtend { dst; _ } -> Some dst + | ZeroExtend { dst; _ } -> Some dst + | DoubleToInt { dst; _ } -> Some dst + | DoubleToUInt { dst; _ } -> Some dst + | UIntToDouble { dst; _ } -> Some dst + | IntToDouble { dst; _ } -> Some dst + | Truncate { dst; _ } -> Some dst + | GetAddress { dst; _ } -> Some dst + | Load { dst; _ } -> Some dst + | AddPtr { dst; _ } -> Some dst + | CopyToOffset { dst; _ } -> Some (Var dst) + | CopyFromOffset { dst; _ } -> Some dst + | Store _ -> None + | Return _ | Jump _ | JumpIfZero _ | JumpIfNotZero _ | Label _ -> None + +let is_static v = + match (Symbols.get v).attrs with Symbols.StaticAttr _ -> true | _ -> false diff --git a/lib/optimizations/optimize_utils.mli b/lib/optimizations/optimize_utils.mli new file mode 100644 index 0000000..78828c2 --- /dev/null +++ b/lib/optimizations/optimize_utils.mli @@ -0,0 +1,2 @@ +val get_dst : Tacky.instruction -> Tacky.tacky_val option +val is_static : string -> bool \ No newline at end of file diff --git a/lib/optimizations/unreachable_code_elim.ml b/lib/optimizations/unreachable_code_elim.ml new file mode 100644 index 0000000..803c8fc --- /dev/null +++ b/lib/optimizations/unreachable_code_elim.ml @@ -0,0 +1,109 @@ +open Batteries + +module G = struct + include Cfg.TackyCfg +end + +let eliminate_unreachable_blocks (cfg : unit G.t) = + let rec dfs explored node_id = + (* we've already explored this node *) + if Set.mem node_id explored then explored + else + let explored' = Set.add node_id explored in + let succs = G.get_succs node_id cfg in + List.fold_left dfs explored' succs + in + let reachable_block_ids = dfs Set.empty G.Entry in + + let f (_, (blk : unit G.basic_block)) = + if Set.mem blk.id reachable_block_ids then true + else ( + (* Not reachable - remove edges and filter it out *) + List.iter (fun p -> G.remove_edge p blk.id cfg) blk.preds; + List.iter (fun s -> G.remove_edge blk.id s cfg) blk.succs; + false) + in + + let updated_blocks = List.filter f cfg.basic_blocks in + G.{ cfg with basic_blocks = updated_blocks } + +let eliminate_useless_jumps (cfg : unit G.t) = + let drop_last lst = List.take (List.length lst - 1) lst in + let update idx ((n, (blk : unit G.basic_block)) as numbered_block) = + if idx = List.length cfg.basic_blocks - 1 then + (* don't modify last block *) + numbered_block + else + match List.last blk.instructions with + | _, Tacky.(Jump _ | JumpIfZero _ | JumpIfNotZero _) -> + let _, default_succ = List.at cfg.basic_blocks (idx + 1) in + if List.for_all (fun nd -> nd = default_succ.id) blk.succs then + (* jump instruction is useless, we can drop it *) + (n, { blk with instructions = drop_last blk.instructions }) + else numbered_block + | _ -> numbered_block + in + + { cfg with basic_blocks = List.mapi update cfg.basic_blocks } + +let eliminate_useless_labels (cfg : unit G.t) = + let update idx ((n, (blk : unit G.basic_block)) as numbered_block) = + match blk.instructions with + | (_, Tacky.Label _) :: rest -> + let default_pred = + if idx = 0 then G.Entry + else (snd (List.at cfg.basic_blocks (idx - 1))).id + in + if List.for_all (fun nd -> nd = default_pred) blk.preds then + (n, { blk with instructions = rest }) + else numbered_block + | _ -> numbered_block + in + { cfg with basic_blocks = List.mapi update cfg.basic_blocks } + +let remove_empty_blocks (cfg : unit G.t) = + let remove (_, (blk : unit G.basic_block)) = + if blk.instructions = [] then + (* block is empty, remove it + but first update edges + *) + match (blk.preds, blk.succs) with + | [ pred ], [ succ ] -> + (* add edge from predecessor to successor, remove edges from either to blk *) + G.remove_edge pred blk.id cfg; + G.remove_edge blk.id succ cfg; + G.add_edge pred succ cfg; + false + | _ -> + failwith + "Empty block should have exactly one predecessor and one successor" + [@coverage off] + else true + in + { cfg with basic_blocks = List.filter remove cfg.basic_blocks } + +(* Print CFG if debug flag is on *) +let debug_print ~extra_tag cfg = + let _ = + if + !Settings.debug.dump_optimizations.unreachable_code_elimination + && Debug.is_dump_target G.(cfg.ctx) + then + (* no annotations, so annotation printer is no-op*) + let nop_printer _fmt () = () in + let tag = "unreachable." ^ extra_tag in + G.(print_graphviz tag nop_printer cfg) + in + (* return it so we can use this in pipeline*) + cfg + +let optimize cfg = + debug_print ~extra_tag:"pre" cfg + |> eliminate_unreachable_blocks + |> debug_print ~extra_tag:"post_unreachable_block_elim" + |> eliminate_useless_jumps + |> debug_print ~extra_tag:"post_jump_elim" + |> eliminate_useless_labels + |> debug_print ~extra_tag:"post_lbl_elim" + |> remove_empty_blocks + |> debug_print ~extra_tag:"post_empty_block_elim" diff --git a/lib/optimizations/unreachable_code_elim.mli b/lib/optimizations/unreachable_code_elim.mli new file mode 100644 index 0000000..998a3bc --- /dev/null +++ b/lib/optimizations/unreachable_code_elim.mli @@ -0,0 +1 @@ +val optimize : unit Cfg.TackyCfg.t -> unit Cfg.TackyCfg.t diff --git a/lib/settings.ml b/lib/settings.ml index 85cc31c..a1a8d1e 100644 --- a/lib/settings.ml +++ b/lib/settings.ml @@ -20,7 +20,40 @@ type extra_credit = | Nan | Union -let platform = ref OS_X (* default to OS X *) +let platform = ref OS_X (* default to OS_X *) let extra_credit_flags = ref [] let int_only = ref false -let debug = ref false + +type optimizations = { + constant_folding : bool; + dead_store_elimination : bool; + unreachable_code_elimination : bool; + copy_propagation : bool; +} + +type debug_options = { + (* dumping intermediate representations *) + dump_tacky : bool; + dump_asm : bool; + (* dumping extra info about specific optimizations*) + dump_optimizations : optimizations; + (* If specified, we dump optimization info only for this function; + * otherwise dump for all functions + * doesn't impact dump_tacky/dump_asm, which always dump the whole program *) + dump_fun : string option; +} + +let debug = + ref + { + dump_tacky = false; + dump_asm = false; + dump_optimizations = + { + constant_folding = false; + dead_store_elimination = false; + unreachable_code_elimination = false; + copy_propagation = false; + }; + dump_fun = None; + } diff --git a/lib/settings.mli b/lib/settings.mli index 2d8fa52..57c3998 100644 --- a/lib/settings.mli +++ b/lib/settings.mli @@ -1,7 +1,24 @@ type stage = Lex | Parse | Validate | Tacky | Codegen | Assembly | Obj | Executable type target = OS_X | Linux type extra_credit = Bitwise | Compound | Increment | Goto | Switch | Nan | Union +type optimizations = { + constant_folding : bool; + dead_store_elimination : bool; + unreachable_code_elimination : bool; + copy_propagation : bool; +} +type debug_options = { + (* dumping intermediate representations *) + dump_tacky : bool; + dump_asm : bool; + (* dumping extra info about specific optimizations*) + dump_optimizations : optimizations; + (* If specified, we dump optimization info only for this function; + * otherwise dump for all functions + * doesn't impact dump_tacky/dump_asm, which always dump the whole program *) + dump_fun : string option; +} val platform : target ref val extra_credit_flags : extra_credit list ref -val debug : bool ref val int_only: bool ref +val debug : debug_options ref diff --git a/lib/tacky.ml b/lib/tacky.ml index 137af6a..52f772b 100644 --- a/lib/tacky.ml +++ b/lib/tacky.ml @@ -1,6 +1,8 @@ [@@@coverage exclude_file] -type unary_operator = Complement | Negate | Not [@@deriving show] +open Cnums + +type unary_operator = Complement | Negate | Not [@@deriving show, eq, ord] type binary_operator = | Add @@ -19,13 +21,39 @@ type binary_operator = | LessOrEqual | GreaterThan | GreaterOrEqual -[@@deriving show] +[@@deriving show, eq, ord] -type tacky_val = Constant of Const.t | Var of string +(* we need a custom comparison function for constants to make sure that 0.0 and -0.0 don't compare equal *) +let const_compare a b = + match (a, b) with + | Const.ConstDouble d1, Const.ConstDouble d2 + when Float.is_nan d1 && Float.is_nan d2 -> + (* For these purposes, nans should compare equal *) + 0 + | Const.ConstDouble d1, Const.ConstDouble d2 when d1 = d2 -> + Float.compare (Float.copysign 1. d1) (Float.copysign 1. d2) + | _ -> Const.compare a b + +type tacky_val = + | Constant of + (Const.t + [@compare fun a b -> const_compare a b] + [@equal fun a b -> const_compare a b = 0]) + | Var of string +[@@deriving eq, ord] let show_tacky_val = function Constant c -> Const.show c | Var v -> v let pp_tacky_val fmt v = Format.pp_print_string fmt (show_tacky_val v) +(* TODO maybe this should be in a separate module? *) +let type_of_val = function + (* note: this reports the type of ConstChar as SChar instead of Char, doesn't matter in this context *) + | Constant c -> Const.type_of_const c + | Var v -> ( + try (Symbols.get v).t + with Not_found -> + failwith ("Internal error: " ^ v ^ " not in symbol table")) + type instruction = | Return of tacky_val option | SignExtend of { src : tacky_val; dst : tacky_val } @@ -59,7 +87,7 @@ type instruction = | JumpIfNotZero of tacky_val * string | Label of string | FunCall of { f : string; args : tacky_val list; dst : tacky_val option } -[@@deriving show { with_path = false }] +[@@deriving show { with_path = false }, eq, ord] type top_level = | Function of { diff --git a/lib/tacky_print.ml b/lib/tacky_print.ml index 19023de..3c2a185 100644 --- a/lib/tacky_print.ml +++ b/lib/tacky_print.ml @@ -15,7 +15,8 @@ let pp_unary_operator out = function | Negate -> Format.pp_print_string out "-" | Not -> Format.pp_print_string out "!" -let pp_binary_operator out = function +(* optional escape_brackets argument lets us escape < and > when instructions appear in HTML-style tables in graphviz *) +let pp_binary_operator ?(escape_brackets = false) out = function | Add -> Format.pp_print_string out "+" | Subtract -> Format.pp_print_string out "-" | Multiply -> Format.pp_print_string out "*" @@ -28,10 +29,18 @@ let pp_binary_operator out = function | BitwiseXor -> Format.pp_print_string out "^" | Equal -> Format.pp_print_string out "==" | NotEqual -> Format.pp_print_string out "!=" - | LessThan -> Format.pp_print_string out "<" - | LessOrEqual -> Format.pp_print_string out "<=" - | GreaterThan -> Format.pp_print_string out ">" - | GreaterOrEqual -> Format.pp_print_string out "<=" + | LessThan -> + let s = if escape_brackets then "<" else "<" in + Format.pp_print_string out s + | LessOrEqual -> + let s = if escape_brackets then "<=" else "<=" in + Format.pp_print_string out s + | GreaterThan -> + let s = if escape_brackets then ">" else ">" in + Format.pp_print_string out s + | GreaterOrEqual -> + let s = if escape_brackets then ">=" else ">=" in + Format.pp_print_string out s let const_to_string = function | Const.ConstInt i -> Int32.to_string i @@ -46,7 +55,7 @@ let pp_tacky_val out = function | Constant i -> Format.pp_print_string out (const_to_string i) | Var s -> Format.pp_print_string out s -let pp_instruction out = function +let pp_instruction ?(escape_brackets = false) out = function | Return None -> Format.pp_print_string out "Return" | Return (Some v) -> Format.fprintf out "Return(%a)" pp_tacky_val v | Unary { op; src; dst } -> @@ -54,7 +63,8 @@ let pp_instruction out = function pp_tacky_val src | Binary { op; src1; src2; dst } -> Format.fprintf out "%a = %a %a %a" pp_tacky_val dst pp_tacky_val src1 - pp_binary_operator op pp_tacky_val src2 + (pp_binary_operator ~escape_brackets) + op pp_tacky_val src2 | Copy { src; dst } -> Format.fprintf out "%a = %a" pp_tacky_val dst pp_tacky_val src | Jump s -> Format.fprintf out "Jump(%s)" s @@ -105,7 +115,8 @@ let pp_instruction out = function | CopyFromOffset { src; offset; dst } -> Format.fprintf out "%a = %s[offset = %d]" pp_tacky_val dst src offset -let pp_function_definition global name params out body = +let pp_function_definition ?(escape_brackets = false) global name params out + body = Format.pp_open_vbox out 0; if global then Format.pp_print_string out "global "; Format.fprintf out "%s(%a):" name @@ -113,13 +124,13 @@ let pp_function_definition global name params out body = params; Format.pp_print_break out 0 4; Format.pp_open_vbox out 0; - Format.pp_print_list pp_instruction out body; + Format.pp_print_list (pp_instruction ~escape_brackets) out body; Format.pp_close_box out (); Format.pp_close_box out () -let pp_tl out = function +let pp_tl ?(escape_brackets = false) out = function | Function { global; name; params; body } -> - pp_function_definition global name params out body + pp_function_definition ~escape_brackets global name params out body | StaticVariable { global; name; init; t } -> Format.pp_open_vbox out 0; if global then Format.pp_print_string out "global "; @@ -131,20 +142,22 @@ let pp_tl out = function Initializers.pp_static_init init; Format.pp_close_box out () -let pp_program out (Program tls) = +let pp_program ?(escape_brackets = false) out (Program tls) = Format.pp_open_vbox out 0; Format.pp_print_list ~pp_sep:(fun out () -> (* print _two_ newlines b/t top levels *) Format.pp_print_cut out (); Format.pp_print_cut out ()) - pp_tl out tls; + (pp_tl ~escape_brackets) out tls; Format.pp_close_box out (); Format.pp_print_newline out () (* flush *) -let debug_print_tacky src_filename tacky_prog = - if !Settings.debug then ( - let tacky_file = Filename.chop_extension src_filename ^ ".debug.tacky" in +let debug_print_tacky ~tag ~file tacky_prog = + if !Settings.debug.dump_tacky then ( + let tacky_file = + Printf.sprintf "%s.%s.tacky" (Filename.remove_extension file) tag + in let chan = open_out tacky_file in let formatter = Format.formatter_of_out_channel chan in pp_program formatter tacky_prog; diff --git a/lib/util/cnums.ml b/lib/util/cnums.ml index 23d6806..0ce5a4c 100644 --- a/lib/util/cnums.ml +++ b/lib/util/cnums.ml @@ -6,7 +6,20 @@ module Float = struct [@@@coverage off] - type t = float [@@deriving show] + type t = float [@@deriving show, eq] + + (* Override Compare to handle NaN correctly *) + module Compare = struct + (* Ugly batteries thing *) + type bat__compare_t = float + + let ( = ) = Stdlib.( = ) + let ( > ) = Stdlib.( > ) + let ( >= ) = Stdlib.( >= ) + let ( < ) = Stdlib.( < ) + let ( <= ) = Stdlib.( <= ) + let ( <> ) = Stdlib.( <> ) + end [@@@coverage on] end @@ -14,11 +27,13 @@ end module Int8 : NumLike = struct [@@@coverage off] - type t = int32 [@@deriving show] + type t = int32 [@@deriving show, eq, ord] [@@@coverage on] let zero = Int32.zero + let lognot = Int32.lognot + let rem = Int32.rem (* internal function to sign-or-zero-extend into upper bytes *) let reset_upper_bytes x = @@ -31,6 +46,25 @@ module Int8 : NumLike = struct let bitmask = 0xffffff00l in Int32.logor x bitmask + let neg = reset_upper_bytes % Int32.neg + + module Infix = struct + let ( + ) x y = reset_upper_bytes Int32.Infix.(x + y) + let ( - ) x y = reset_upper_bytes Int32.Infix.(x - y) + + (* don't need to explicitly wrap division; if x and y are in range of int8, result will be too *) + let ( / ) = Int32.Infix.( / ) + let ( * ) x y = reset_upper_bytes Int32.Infix.(x * y) + end + + module Compare = Int32.Compare + + let logand x y = reset_upper_bytes (Int32.logand x y) + let logor x y = reset_upper_bytes (Int32.logor x y) + let logxor x y = reset_upper_bytes (Int32.logxor x y) + let shift_left x y = reset_upper_bytes (Int32.shift_left x y) + let shift_right x y = reset_upper_bytes (Int32.shift_right x y) + let check_range x = if x > 127l || x < -128l then failwith "Out of range" else x @@ -52,20 +86,59 @@ module Int8 : NumLike = struct let to_string = Int32.to_string end +module MakeCompare (C : sig + type t + + val compare : t -> t -> int +end) : Compare with type t = C.t = struct + type t = C.t + + let ( = ) x y = C.compare x y = 0 + let ( <> ) x y = C.compare x y <> 0 + let ( > ) x y = C.compare x y > 0 + let ( >= ) x y = C.compare x y >= 0 + let ( < ) x y = C.compare x y < 0 + let ( <= ) x y = C.compare x y <= 0 +end + module UInt8 : NumLike = struct [@@@coverage off] - type t = int32 [@@deriving show] + type t = int32 [@@deriving show, eq] [@@@coverage on] let zero = Int32.zero + let lognot = Int32.lognot + let compare = Int32.unsigned_compare + let rem = Int32.unsigned_rem (* internal function to sign-or-zero-extend into upper bytes *) let reset_upper_bytes x = let bitmask = 0x000000ffl in Int32.logand x bitmask + let neg = reset_upper_bytes % Int32.neg + + module Infix = struct + let ( + ) x y = reset_upper_bytes Int32.Infix.(x + y) + let ( - ) x y = reset_upper_bytes Int32.Infix.(x - y) + let ( / ) x y = Int32.unsigned_div x y + let ( * ) x y = reset_upper_bytes Int32.Infix.(x * y) + end + + module Compare = MakeCompare (struct + type t = int32 + + let compare = Int32.unsigned_compare + end) + + let logand x y = reset_upper_bytes (Int32.logand x y) + let logor x y = reset_upper_bytes (Int32.logor x y) + let logxor x y = reset_upper_bytes (Int32.logxor x y) + let shift_left x y = reset_upper_bytes (Int32.shift_left x y) + let shift_right x y = reset_upper_bytes (Int32.shift_right_logical x y) + let of_int i = let x = Int32.of_int i in reset_upper_bytes x @@ -87,11 +160,34 @@ end module UInt32 : NumLike = struct [@@@coverage off] - type t = int32 [@@deriving show] + type t = int32 [@@deriving show, eq] [@@@coverage on] let zero = Int32.zero + let compare = Int32.unsigned_compare + let rem = Int32.unsigned_rem + let neg = Int32.neg + let lognot = Int32.lognot + let shift_left x y = Int32.shift_left x y + let shift_right x y = Int32.shift_right_logical x y + + module Infix = struct + let ( + ) x y = Int32.Infix.(x + y) + let ( - ) x y = Int32.Infix.(x - y) + let ( / ) = Int32.unsigned_div + let ( * ) x y = Int32.Infix.(x * y) + end + + module Compare = MakeCompare (struct + type t = int32 + + let compare = Int32.unsigned_compare + end) + + let logand x y = Int32.logand x y + let logor x y = Int32.logor x y + let logxor x y = Int32.logxor x y let of_int = Int32.of_int let to_int x = @@ -119,11 +215,34 @@ let%test "uint_type_conversion" = module UInt64 : NumLike = struct [@@@coverage off] - type t = int64 [@@deriving show] + type t = int64 [@@deriving show, eq] [@@@coverage on] let zero = Int64.zero + let compare = Int64.unsigned_compare + let neg = Int64.neg + let lognot = Int64.lognot + let rem = Int64.unsigned_rem + + module Infix = struct + let ( + ) x y = Int64.Infix.(x + y) + let ( - ) x y = Int64.Infix.(x - y) + let ( / ) = Int64.unsigned_div + let ( * ) x y = Int64.Infix.(x * y) + end + + module Compare = MakeCompare (struct + type t = int64 + + let compare = Int64.unsigned_compare + end) + + let logand x y = Int64.logand x y + let logor x y = Int64.logor x y + let logxor x y = Int64.logxor x y + let shift_left x y = Int64.shift_left x y + let shift_right x y = Int64.shift_right_logical x y let of_int = Int64.of_int let to_int x = diff --git a/lib/util/debug.ml b/lib/util/debug.ml new file mode 100644 index 0000000..51c1cda --- /dev/null +++ b/lib/util/debug.ml @@ -0,0 +1,18 @@ +open Context + +let is_dump_target ctx = + match !Settings.debug.dump_fun with + (* If we didn't specify which fun to dump info about, dump info for all of them *) + | None -> true + (* Otherwise, check if the current fun is the target fun *) + | Some target when ctx.fun_name = target -> true + | Some _other -> false + +(* prefix is some user-friendly label indicating e.g. current optimization, ext is file extension, including . *) +let mk_filename prefix ctx ext = + let base_filename = + ctx.filename |> Filename.chop_extension |> Filename.basename + in + Unique_ids.make_label + (Printf.sprintf "%s.%s.%s" prefix ctx.fun_name base_filename) + ^ ext diff --git a/lib/util/num_interfaces.ml b/lib/util/num_interfaces.ml index 41c704e..ba81f36 100644 --- a/lib/util/num_interfaces.ml +++ b/lib/util/num_interfaces.ml @@ -1,10 +1,49 @@ +module type Infix = sig + type t + + val ( + ) : t -> t -> t + val ( - ) : t -> t -> t + val ( / ) : t -> t -> t + val ( * ) : t -> t -> t +end + +module type Compare = sig + type t + + val ( = ) : t -> t -> bool + val ( <> ) : t -> t -> bool + val ( < ) : t -> t -> bool + val ( <= ) : t -> t -> bool + val ( > ) : t -> t -> bool + val ( >= ) : t -> t -> bool +end + (* basic interface supporting integer conversions, * satisfied by both our types and the ones provided by batteries *) -module type NumLike = sig +module type BasicNumLike = sig type t + module Infix : Infix with type t := t + module Compare : Compare with type t := t + val zero : t + val compare : t -> t -> int + val equal : t -> t -> bool + val lognot : t -> t + val neg : t -> t + val rem : t -> t -> t + + (* Bitwise operations *) + val logand : t -> t -> t + val logor : t -> t -> t + val logxor : t -> t -> t + val shift_left : t -> int -> t + val shift_right : t -> int -> t +end + +module type NumLike = sig + include BasicNumLike (* conversions *) val of_int32 : int32 -> t