diff --git a/sledge/Makefile b/sledge/Makefile index 1b0b3f503..43aedc30e 100644 --- a/sledge/Makefile +++ b/sledge/Makefile @@ -10,16 +10,10 @@ EXES = src/sledge INSTALLS = sledge FMTS = @_build/dev/src/fmt -facebook/Makefile: - -@${MAKE} -s -C ../facebook setup - -@${MAKE} -s -C facebook - --include facebook/Makefile - DBG_TARGETS = $(patsubst %,_build/dev/%.exe,$(EXES)) $(patsubst %,_build/dev/%.install,$(INSTALLS)) OPT_TARGETS = $(patsubst %,_build/release/%.exe,$(EXES)) $(patsubst %,_build/release/%.install,$(INSTALLS)) -DUNEINS = $(shell find src facebook model -name dune.in) +DUNEINS = $(shell find src model -name dune.in) DUNES = $(patsubst %.in,%,$(DUNEINS)) .PHONY: dunes @@ -29,7 +23,7 @@ dunes: $(DUNES) @cat $+ > $@ .PHONY: setup -setup: facebook/Makefile dunes +setup: dunes .PHONY: check check: setup diff --git a/sledge/dune-common.in b/sledge/dune-common.in index 70aece458..eff44432c 100644 --- a/sledge/dune-common.in +++ b/sledge/dune-common.in @@ -38,11 +38,11 @@ let flags exe_or_lib deps = ppx_import ppx_compare ppx_custom_printf - ppx_deriving_cmdliner ppx_expect ppx_hash ppx_here ppx_inline_test + ppx_let ppx_sexp_conv ppx_sexp_value ppx_trace diff --git a/sledge/sledge.opam b/sledge/sledge.opam index 5af7da2ea..c9ebcad46 100644 --- a/sledge/sledge.opam +++ b/sledge/sledge.opam @@ -12,18 +12,17 @@ build: [ depends: [ "ocaml" "base" {>= "v0.12.0"} - "cmdliner" - "core_kernel" + "core" "crunch" {build} "ctypes" "ctypes-foreign" "dune" {build} "llvm" {= "8.0.0"} "ppx_compare" - "ppx_deriving_cmdliner" {>= "0.4.2"} "ppx_import" "ppx_hash" "shexp" + "yojson" "zarith" ] synopsis: "SLEdge analyzer" diff --git a/sledge/src/config.ml b/sledge/src/config.ml index ecbc6436c..44b36196e 100644 --- a/sledge/src/config.ml +++ b/sledge/src/config.ml @@ -5,56 +5,32 @@ * LICENSE file in the root directory of this source tree. *) -(** Configuration options *) +(** Configuration options from config file *) -let trace_conv = - let parse s = - Trace.parse s - |> Result.map_error ~f:(fun _ -> `Msg ("Invalid trace spec: " ^ s)) - in - let print fs {trace_all; trace_mods_funs} = - let pf fmt = Format.fprintf fs fmt in - if trace_all then pf "*" - else - Map.iteri trace_mods_funs - ~f:(fun ~key:mod_name ~data:{trace_mod; trace_funs} -> - ( match trace_mod with - | Some true -> pf "+%s" mod_name - | Some false -> pf "-%s" mod_name - | None -> () ) ; - Map.iteri trace_funs ~f:(fun ~key:fun_name ~data:fun_enabled -> - if fun_enabled then pf "+%s.%s" mod_name fun_name - else pf "-%s.%s" mod_name fun_name ) ) - in - (parse, print) +let config_file_env_var = "SLEDGE_CONFIG" +let exe_relative_config_file_path = "config" -type t = - { bound: int [@aka ["b"]] [@default 1] - (** Specify bound on execution exploration *) - ; compile_only: bool [@aka ["c"]] - (** Do not analyze: terminate after translating input LLVM to LLAIR. *) - ; input: string [@pos 0] [@docv "input.bc"] - (** LLVM bitcode file to analyze, in either binary $(b,.bc) or - textual $(b,.ll) form. *) - ; output: string option [@aka ["o"]] [@docv "output.llair"] - (** Dump $(i,input.bc) translated to LLAIR in human-readable form to - $(i,output.llair), or $(b,-) for $(b,stdout). *) - ; trace: Trace.config - [@aka ["t"]] [@docv "spec"] [@conv trace_conv] [@default Trace.none] - (** Enable debug tracing according to $(i,spec), which is a sequence - of module and function names separated by $(b,+) or $(b,-). For - example, $(b,Control-Control.exec_inst) enables all tracing in - the $(b,Control) module except the $(b,Control.exec_inst) - function. The $(i,spec) value $(b,* )enables all debug tracing. *) - } -[@@deriving cmdliner] +let config_file = + match Core.Sys.getenv config_file_env_var with + | Some file -> file + | None -> + Filename.concat + (Filename.dirname Caml.Sys.executable_name) + exe_relative_config_file_path -let run main = - let info = Cmdliner.Term.info "sledge" ~version:Version.version in - Cmdliner.Term.eval (cmdliner_term (), info) - |> function - | `Error _ -> Caml.exit 1 - | `Help | `Version -> Caml.exit 0 - | `Ok {bound; compile_only; input; output; trace} -> - Trace.init ~config:trace () ; - main ~bound ~compile_only ~input ~output +let contents = + try Yojson.Basic.from_file config_file + with Sys_error _ -> + warn + "could not read config file %s@\n\ + The path to the config file can be overridden by the %s environment \ + variable." + config_file config_file_env_var () ; + `Assoc [] + +let find key = Yojson.Basic.Util.(to_string_option (member key contents)) + +let find_exn key = + match find key with + | Some data -> data + | None -> fail "%s not specified in config file %s" key config_file diff --git a/sledge/src/config.mli b/sledge/src/config.mli index ee6ab2857..6b44087d4 100644 --- a/sledge/src/config.mli +++ b/sledge/src/config.mli @@ -5,15 +5,7 @@ * LICENSE file in the root directory of this source tree. *) -(** Configuration options *) +(** Configuration options from config file *) -val run : - ( bound:int - -> compile_only:bool - -> input:string - -> output:string option - -> 'a) - -> 'a -(** [run main] parses command line options, performs some imperative - initialization, and then executes [main] passing the configuration - options. *) +val find : string -> string option +val find_exn : string -> string diff --git a/sledge/src/dune.in b/sledge/src/dune.in index b24b48821..d9f068a57 100644 --- a/sledge/src/dune.in +++ b/sledge/src/dune.in @@ -22,7 +22,7 @@ Jbuild_plugin.V1.send (public_name sledge) (package sledge) %s - (libraries cmdliner %s)) + (libraries shexp.process yojson %s)) |} (flags `exe deps) (libraries deps) diff --git a/sledge/src/import/dune.in b/sledge/src/import/dune.in index 02cf67d82..bab3f4faf 100644 --- a/sledge/src/import/dune.in +++ b/sledge/src/import/dune.in @@ -16,7 +16,7 @@ Jbuild_plugin.V1.send (name import) (public_name llair.import) %s - (libraries core_kernel core_kernel.fheap zarith %s)) + (libraries core core_kernel.fheap zarith %s)) |} (flags `lib deps) (libraries deps) diff --git a/sledge/src/import/import.ml b/sledge/src/import/import.ml index a3f47aafb..ee57eb87a 100644 --- a/sledge/src/import/import.ml +++ b/sledge/src/import/import.ml @@ -31,6 +31,7 @@ include ( external ( == ) : 'a -> 'a -> bool = "%eq" include Stdio +module Command = Core.Command module Hash_queue = Core_kernel.Hash_queue (** Tuple operations *) diff --git a/sledge/src/import/import.mli b/sledge/src/import/import.mli index acdd521a1..05efd2b75 100644 --- a/sledge/src/import/import.mli +++ b/sledge/src/import/import.mli @@ -32,6 +32,7 @@ include module type of ( external ( == ) : 'a -> 'a -> bool = "%eq" include module type of Stdio +module Command = Core.Command module Hash_queue = Core_kernel.Hash_queue (** Tuple operations *) diff --git a/sledge/src/llair/frontend.ml b/sledge/src/llair/frontend.ml index ad26fd6e2..45a518aa3 100644 --- a/sledge/src/llair/frontend.ml +++ b/sledge/src/llair/frontend.ml @@ -1320,15 +1320,14 @@ let xlate_function : x -> Llvm.llvalue -> Llair.func = |> [%Trace.retn fun {pf} -> pf "@\n%a" Llair.Func.pp] -let transform ~gdce : Llvm.llmodule -> unit = +let transform : Llvm.llmodule -> unit = fun llmodule -> let pm = Llvm.PassManager.create () in - if gdce then ( - Llvm_ipo.add_internalize_predicate pm (fun fn -> - List.exists - ["__llair_main"; "_Z12__llair_mainv"; "main"] - ~f:(String.equal fn) ) ; - Llvm_ipo.add_global_dce pm ) ; + Llvm_ipo.add_internalize_predicate pm (fun fn -> + List.exists + ["__llair_main"; "_Z12__llair_mainv"; "main"] + ~f:(String.equal fn) ) ; + Llvm_ipo.add_global_dce pm ; Llvm_scalar_opts.add_lower_atomic pm ; Llvm_scalar_opts.add_scalar_repl_aggregation pm ; Llvm_scalar_opts.add_scalarizer pm ; @@ -1337,12 +1336,10 @@ let transform ~gdce : Llvm.llmodule -> unit = Llvm.PassManager.run_module llmodule pm |> (ignore : bool -> _) ; Llvm.PassManager.dispose pm -let translate : string -> Llair.t = - fun file -> - [%Trace.call fun {pf} -> pf "%s" file] +let link_in : Llvm.llcontext -> Llvm.lllinker -> string -> unit = + fun llcontext link_ctx bc_file -> + [%Trace.call fun {pf} -> pf "%s" bc_file] ; - Llvm.install_fatal_error_handler invalid_llvm ; - let llcontext = Llvm.global_context () in let read_and_parse bc_file = let llmemorybuffer = try Llvm.MemoryBuffer.of_file bc_file @@ -1351,34 +1348,31 @@ let translate : string -> Llair.t = try Llvm_irreader.parse_ir llcontext llmemorybuffer with Llvm_irreader.Error msg -> invalid_llvm msg in - let single_bc_input = - List.exists - ~f:(fun suffix -> String.is_suffix file ~suffix) - [".bc"; ".ll"] - in + Llvm_linker.link_in link_ctx (read_and_parse bc_file) + |> + [%Trace.retn fun {pf} _ -> pf ""] + +let translate : string list -> Llair.t = + fun inputs -> + [%Trace.call fun {pf} -> + pf "%a" (List.pp "@ " Format.pp_print_string) inputs] + ; + Llvm.install_fatal_error_handler invalid_llvm ; + let llcontext = Llvm.global_context () in let llmodule = - if single_bc_input then read_and_parse file - else - let llmodule = - let model_memorybuffer = - Llvm.MemoryBuffer.of_string - (Option.value_exn (Model.read "/cxxabi.bc")) - in - Llvm_irreader.parse_ir llcontext model_memorybuffer - in - let link_ctx = Llvm_linker.get_linker llmodule in - let link_in bc_file = - [%Trace.info "linking in %s" bc_file] ; - Llvm_linker.link_in link_ctx (read_and_parse bc_file) - in - In_channel.with_file file ~f:(In_channel.iter_lines ~f:link_in) ; - Llvm_linker.linker_dispose link_ctx ; - llmodule + let model_memorybuffer = + Llvm.MemoryBuffer.of_string + (Option.value_exn (Model.read "/cxxabi.bc")) + in + Llvm_irreader.parse_ir llcontext model_memorybuffer in + let link_ctx = Llvm_linker.get_linker llmodule in + List.iter inputs ~f:(link_in llcontext link_ctx) ; + Llvm_linker.linker_dispose link_ctx ; assert ( Llvm_analysis.verify_module llmodule |> Option.for_all ~f:invalid_llvm ) ; - transform ~gdce:(not single_bc_input) llmodule ; + transform llmodule ; scan_names_and_locs llmodule ; let lldatalayout = Llvm_target.DataLayout.of_string (Llvm.data_layout llmodule) diff --git a/sledge/src/llair/frontend.mli b/sledge/src/llair/frontend.mli index 8f8086977..86ff79a6a 100644 --- a/sledge/src/llair/frontend.mli +++ b/sledge/src/llair/frontend.mli @@ -9,6 +9,6 @@ exception Invalid_llvm of string -val translate : string -> Llair.t -(** Translate the compilation unit in the named (llvm or bitcode) file to +val translate : string list -> Llair.t +(** Translate the compilation units in the named (llvm or bitcode) files to LLAIR. Attempts to raise [Invalid_llvm] when the input is invalid LLVM. *) diff --git a/sledge/src/sledge.ml b/sledge/src/sledge.ml index 7082b001a..58e60f354 100644 --- a/sledge/src/sledge.ml +++ b/sledge/src/sledge.ml @@ -5,44 +5,168 @@ * LICENSE file in the root directory of this source tree. *) -(** Sledge executable entry point *) - -let main ~bound ~compile_only ~input ~output = - try - let program = - if String.is_suffix input ~suffix:".llair" then - In_channel.with_file input ~f:(fun ic -> - (Marshal.from_channel ic : Llair.t) ) - else - let program = Frontend.translate input in - Trace.flush () ; - Out_channel.with_file (input ^ ".llair") ~f:(fun oc -> - Marshal.to_channel oc program [Marshal.Closures] ) ; - program +(** SLEdge command line interface *) + +open Command.Let_syntax + +type 'a param = 'a Command.Param.t + +(* reverse application in the Command.Param applicative *) +let ( |*> ) : 'a param -> ('a -> 'b) param -> 'b param = + fun x f -> x |> Command.Param.apply f + +(* function composition in the Command.Param applicative *) +let ( >*> ) : ('a -> 'b) param -> ('b -> 'c) param -> ('a -> 'c) param = + fun f' g' -> Command.Param.both f' g' >>| fun (f, g) -> f >> g + +(* define a command, with trace flag, and with action wrapped in reporting *) +let command ~summary ?readme param = + let trace_flag = + let open Command.Param in + flag "trace" ~doc:" enable debug tracing" + (optional_with_default Trace.none + (Arg_type.create (fun s -> Trace.parse s |> Result.ok_exn))) + >>| fun config -> Trace.init ~config () + in + let wrap main () = + try + main () |> ignore ; + Trace.flush () ; + Format.printf "@\nRESULT: Success@." + with exn -> + let bt = Caml.Printexc.get_raw_backtrace () in + Trace.flush () ; + ( match exn with + | Frontend.Invalid_llvm msg -> + Format.printf "@\nRESULT: Invalid input: %s@." msg + | Unimplemented msg -> + Format.printf "@\nRESULT: Unimplemented: %s@." msg + | Failure msg -> Format.printf "@\nRESULT: Internal error: %s@." msg + | _ -> + Format.printf "@\nRESULT: Unknown error: %s@." + (Caml.Printexc.to_string exn) ) ; + Caml.Printexc.raise_with_backtrace exn bt + in + Command.basic ~summary ?readme (trace_flag *> param >>| wrap) + +let marshal program file = + Out_channel.with_file file ~f:(fun oc -> + Marshal.to_channel oc program [Marshal.Closures] ) + +let unmarshal file () = + In_channel.with_file + ~f:(fun ic -> (Marshal.from_channel ic : Llair.t)) + file + +let analyze = + let%map_open bound = + flag "bound" + (optional_with_default 1 int) + ~doc:" stop execution exploration at depth " + in + fun program () -> Control.exec_pgm ~bound (program ()) + +let analyze_cmd = + let summary = "analyze LLAIR code" in + let readme () = + "The file must be binary LLAIR, such as produced by `sledge \ + translate`." + in + let param = + Command.Param.(anon ("" %: string) >>| unmarshal |*> analyze) + in + command ~summary ~readme param + +let translate = + let%map_open output = + flag "output-llair" (optional string) + ~doc:" write generated LLAIR to " + in + fun bitcode_inputs () -> + let program = Frontend.translate bitcode_inputs in + Option.iter ~f:(marshal program) output ; + program + +let llvm_grp = + let translate_inputs = + let expand_argsfile input = + if Char.(input.[0] = '@') then + In_channel.with_file ~f:In_channel.input_lines + (String.subo ~pos:1 input) + else [input] + in + let open Command.Param in + let input_arg = Arg_type.map string ~f:expand_argsfile in + anon + (map_anons ~f:List.concat + (non_empty_sequence_as_list ("" %: input_arg))) + |*> translate + in + let translate_cmd = + let summary = "translate LLVM bitcode to LLAIR" in + let readme () = + "Translate one or more LLVM bitcode files to LLAIR. Each \ + filename may be either: an LLVM bitcode file, in binary (.bc) or \ + textual (.ll) form; or of the form @, where \ + names a file containing one per line." + in + let param = translate_inputs in + command ~summary ~readme param + in + let analyze_cmd = + let summary = "analyze LLVM bitcode" in + let readme () = + "Analyze code in one or more LLVM bitcode files. This is a \ + convenience wrapper for the sequence `sledge llvm translate`; \ + `sledge analyze`." in - Option.iter output ~f:(function - | "-" -> Format.printf "%a@." Llair.pp program - | filename -> - Out_channel.with_file filename ~f:(fun oc -> + let param = translate_inputs |*> analyze in + command ~summary ~readme param + in + let summary = "integration with LLVM" in + let readme () = + "Code can be provided by one or more LLVM bitcode files." + in + Command.group ~summary ~readme ~preserve_subcommand_order:() + [("analyze", analyze_cmd); ("translate", translate_cmd)] + +let disassemble_cmd = + let summary = "print LLAIR code in textual form" in + let readme () = + "The file must be LLAIR code, as produced by `sledge llvm \ + translate`." + in + let param = + let%map_open input = anon ("" %: string) + and output = + flag "output" (optional string) + ~doc: + " write generated textual LLAIR to , or to standard \ + output if omitted" + in + fun () -> + let program = unmarshal input () in + match output with + | None -> Format.printf "%a@." Llair.pp program + | Some file -> + Out_channel.with_file file ~f:(fun oc -> let fs = Format.formatter_of_out_channel oc in - Format.fprintf fs "%a@." Llair.pp program ) ) ; - if not compile_only then ( - Control.exec_pgm ~bound program ; - Trace.flush () ) ; - Format.printf "@\nRESULT: Success@." - with exn -> - let bt = Caml.Printexc.get_raw_backtrace () in - Trace.flush () ; - ( match exn with - | Frontend.Invalid_llvm msg -> - Format.printf "@\nRESULT: Invalid input: %s@." msg - | Unimplemented msg -> - Format.printf "@\nRESULT: Unimplemented: %s@." msg - | Failure msg -> Format.printf "@\nRESULT: Internal error: %s@." msg - | _ -> - Format.printf "@\nRESULT: Unknown error: %s@." - (Caml.Printexc.to_string exn) ) ; - Caml.Printexc.raise_with_backtrace exn bt + Format.fprintf fs "%a@." Llair.pp program ) + in + command ~summary ~readme param + +let summary = "SLEdge static analyzer" + +let readme () = + "The [-trace ] argument of each subcommand enables debug tracing \ + according to , which is a sequence of module and function names \ + separated by + or -. For example, M-M.f enables all tracing in the M \ + module except the M.f function. The value * enables all debug \ + tracing." ;; -Config.run main +Command.run ~version:Version.version ~build_info:"" + (Command.group ~summary ~readme ~preserve_subcommand_order:() + [ ("buck", Sledge_buck.main ~command ~analyze:(translate >*> analyze)) + ; ("llvm", llvm_grp); ("analyze", analyze_cmd) + ; ("disassemble", disassemble_cmd) ]) diff --git a/sledge/src/sledge_buck.ml b/sledge/src/sledge_buck.ml new file mode 100644 index 000000000..db0bbab22 --- /dev/null +++ b/sledge/src/sledge_buck.ml @@ -0,0 +1,212 @@ +(* + * Copyright (c) 2019-present, Facebook, Inc. + * + * This source code is licensed under the MIT license found in the + * LICENSE file in the root directory of this source tree. + *) + +(** sledge-buck integration *) + +module Process = Shexp_process +open Process.Infix + +(* directory relative to buck root containing llvm binaries *) +let llvm_bin = lazy (Option.value (Config.find "llvm-bin-dir") ~default:"") + +(* buck build mode to specify an LTO build *) +let mode = lazy (Config.find_exn "buck-build-mode") + +(* resolve relative path wrt root *) +let make_absolute root path = + if Filename.is_relative path then Filename.concat root path else path + +(* initial working directory *) +let cwd = Unix.getcwd () + +(* query buck for root *) +let buck_root = + let open Process in + lazy (String.strip (eval (run "buck" ["root"] |- read_all))) + +(* use buck root for working directory *) +let context () = + let open Process in + Context.create ~cwd:(Path (Lazy.force buck_root)) () + +(* invoke the LTO build for the target *) +let buck_build ~context target = + let open Process in + eval ~context (run "buck" ["build"; "@mode/" ^ Lazy.force mode; target]) + +(* split a fully-qualified buck target into file and rule *) +let parse_target target = + try Scanf.sscanf target "//%s@:%s" (fun file rule -> (file, rule)) + with Scanf.Scan_failure _ | End_of_file -> + fail "could not parse target: %s" target () + +(* compute the filename of the linker.argsfile for the target *) +let argsfile ~context target = + let file, rule = parse_target target in + Printf.sprintf "%s/buck-out/%s/bin/%s/%s#binary/linker.argsfile" + Process.(eval ~context cwd_logical) + (Lazy.force mode) file rule + +(* add a file to the list of modules, if it exists *) +let add_module ?archive_name ~context file rev_modules = + let open Process in + if eval ~context (file_exists file) then file :: rev_modules + else ( + ( match archive_name with + | None -> warn "%s doesn't exist" file () + | Some archive_name -> + warn "%s doesn't exist in archive: %s" file + (Filename.basename archive_name) + () ) ; + rev_modules ) + +(* use llvm-ar to get toc of an archive *) +let expand_thin_archive ~context archive_name rev_modules = + let open Process in + eval ~context + ( run (Lazy.force llvm_bin ^ "llvm-ar") ["t"; archive_name] + |- fold_lines ~init:rev_modules ~f:(fun rev_modules line -> + return (add_module ~archive_name ~context line rev_modules) ) ) + +(* Use llvm-ar to check if the archive contains any bitcode files; if it + does, fail for now as it doesn't seem to happen. *) +let expand_arch_archive ~context archive_name = + let number_of_bitcode_files = + let open Process in + eval ~context + ( run (Lazy.force llvm_bin ^ "llvm-ar") ["t"; archive_name] + |- fold_lines ~init:0 ~f:(fun acc name -> + return + (let _, is_bc = + eval ~context + (* Need to run_exit_status, because otherwise llvm-ar + gets -8 signal; which is strange. Repeating the + command in bash doesn't signal and this works. *) + ( run_exit_status + (Lazy.force llvm_bin ^ "llvm-ar") + ["p"; archive_name; name] + |+ run "head" ["-c2"] + |+ read_all ) + in + if String.equal is_bc "BC" then ( + warn "found bc file %s in %s" name archive_name () ; + acc + 1 ) + else acc) ) ) + in + number_of_bitcode_files = 0 + || fail "found %d bitcode files in archive %s" number_of_bitcode_files + archive_name () + +(* find bitcode module(s) in a linker arg *) +let parse_linker_arg ~context rev_modules arg = + if String.is_suffix arg ~suffix:".o" then + add_module ~context arg rev_modules + else if String.is_suffix arg ~suffix:".a" then + let thin_archive = + String.strip Process.(eval (run "head" ["-1"; arg] |- read_all)) + in + if String.equal thin_archive "!" then + expand_thin_archive ~context arg rev_modules + else if String.equal thin_archive "!" then ( + assert (expand_arch_archive ~context arg) ; + rev_modules ) + else fail "unknown type of archive file %s" thin_archive () + else rev_modules + +(* build target and find constituent bitcode modules *) +let bitcode_files_of ~target = + let context = context () in + buck_build ~context target ; + let modules = + In_channel.with_file + (argsfile ~context target) + ~f:(In_channel.fold_lines ~init:[] ~f:(parse_linker_arg ~context)) + |> List.rev + in + List.map ~f:(make_absolute (Lazy.force buck_root)) modules + +(* link and optimize the modules *) +let llvm_link_opt ~output modules = + let context = context () in + let open Process in + eval ~context + ( run + (Lazy.force llvm_bin ^ "llvm-link") + ( "-internalize" :: "-internalize-public-api-list=main" :: "-o=-" + :: modules ) + |- run (Lazy.force llvm_bin ^ "opt") ["-o=" ^ output; "-globaldce"] ) + +(** command line interface *) + +open Command.Let_syntax + +let ( |*> ) x f = x |> Command.Param.apply f + +let abs_path_arg = + Command.Param.(Arg_type.map string ~f:(make_absolute cwd)) + +let main ~(command : unit Command.basic_command) ~analyze = + let target_flag = Command.Param.(anon ("" %: string)) in + let bitcode_inputs = + let%map_open target = target_flag + and output = + flag "output-modules" (optional string) + ~doc:" write list of bitcode files to " + in + let bitcode_files = bitcode_files_of ~target in + ( match output with + | Some file -> Out_channel.write_lines file bitcode_files + | None -> + Format.printf "%a" + (List.pp " " Format.pp_print_string) + bitcode_files ) ; + bitcode_files + in + let bitcode_cmd = + let summary = "report bitcode files in buck target" in + let readme () = + "Build a buck target and report the included bitcode files." + in + let param = bitcode_inputs >>| fun _ () -> () in + command ~summary ~readme param + in + let analyze_cmd = + let summary = "analyze buck target" in + let readme () = + "Analyze code in a buck target. This is a convenience wrapper for \ + the sequence `sledge buck bitcode`; `sledge llvm translate`; \ + `sledge analyze`." + in + let param = bitcode_inputs |*> analyze in + command ~summary ~readme param + in + let link_cmd = + let summary = "link buck target to LLVM bitcode" in + let readme () = + "Link code in a buck target to a single LLVM bitcode module. This \ + also internalizes all symbols except `main` and removes dead code." + in + let param = + let%map_open target = target_flag + and output = + flag "output" (required abs_path_arg) + ~doc:" write linked output to " + in + fun () -> llvm_link_opt ~output (bitcode_files_of ~target) + in + command ~summary ~readme param + in + let summary = "integration with Buck" in + let readme () = + "Code can be provided by a buck build target, such as \ + //fully/qualified/build:target. The mechanism used to integrate with \ + buck uses the arguments passed to the linker, so the target must \ + specify a binary that will be linked, not for instance a library \ + archive." + in + Command.group ~summary ~readme ~preserve_subcommand_order:() + [("analyze", analyze_cmd); ("bitcode", bitcode_cmd); ("link", link_cmd)] diff --git a/sledge/src/sledge_buck.mli b/sledge/src/sledge_buck.mli new file mode 100644 index 000000000..e05bc83a6 --- /dev/null +++ b/sledge/src/sledge_buck.mli @@ -0,0 +1,11 @@ +(* + * Copyright (c) 2019-present, Facebook, Inc. + * + * This source code is licensed under the MIT license found in the + * LICENSE file in the root directory of this source tree. + *) + +val main : + command:unit Command.basic_command + -> analyze:(string list -> unit -> unit) Command.Param.t + -> Command.t diff --git a/sledge/src/version.ml.in b/sledge/src/version.ml.in index cce512956..3c019420c 100644 --- a/sledge/src/version.ml.in +++ b/sledge/src/version.ml.in @@ -8,4 +8,4 @@ (** Version information populated by build system *) let debug = [%debug] -let version = "%%VERSION%%" ^ if debug then "-dbg" else "-opt" +let version = "%%VERSION%%" ^ if debug then "-dbg" else ""