Summary: Change command line interface to include buck and llvm integration as separate subcommands. Reviewed By: kren1 Differential Revision: D15614567 fbshipit-source-id: b7618571bmaster
Josh Berdine
6 years ago
committed by
Facebook Github Bot
parent
bb9f44dee2
commit
6a2da2acc4
@ -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 "!<thin>" then
|
||||
expand_thin_archive ~context arg rev_modules
|
||||
else if String.equal thin_archive "!<arch>" 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 ("<target>" %: string)) in
|
||||
let bitcode_inputs =
|
||||
let%map_open target = target_flag
|
||||
and output =
|
||||
flag "output-modules" (optional string)
|
||||
~doc:"<file> write list of bitcode files to <file>"
|
||||
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:"<file> write linked output to <file>"
|
||||
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)]
|
||||
@ -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
|
||||
Loading…
Reference in new issue