Permalink
Browse files

Changed the generation of LLVM IR to use two intermediate representat…

…ions.

They are inspired by the Mach and Linearize representations.
  • Loading branch information...
1 parent 6906948 commit 054dce9808e9ed8fbc709782ca2b98f735a5230e @colinbenner committed Jan 16, 2012
View
1 _tags
@@ -1,6 +1,5 @@
<src/{asmcomp,bytecomp,driver,parsing,toplevel,typing,utils}>: include
<src/*/*.ml{,i}>: pkg_dynlink, pkg_findlib
-"src/ocmalllvm.native": link_llvm
#<src/*/*.mlp>: process_mlp
# OASIS_START
View
@@ -491,11 +491,6 @@ let system = BaseEnvLight.var_get "system" env;;
let windows = os_type = "Win32";;
if windows then tag_any ["windows"];;
-(* stuff for using LLVM's OCaml bindings *)
-ocaml_lib ~extern:true ~dir:"+llvm" "llvm";;
-flag ["link"]
- (S[A"-cclib"; A"-lstdc++"; A"llvm.cma"]);;
-
(* C compiler flags *)
flag ["compile"; "c"]
(S[A"-ccopt"; A("-DOS_" ^ os_type);
View
@@ -79,14 +79,11 @@ let compile_fundecl (ppf : formatter) fd_cmm =
let compile_phrase ppf p =
if !dump_cmm then fprintf ppf "%a@." Printcmm.phrase p;
- if !use_llvm then
+ let compile_fundecl = if !use_llvm then Llvmcompile.compile_fundecl else compile_fundecl ppf
+ and data = if !use_llvm then Llvmcompile.data else Emit.data in
match p with
- | Cfunction fd -> Llvmcompile.compile_fundecl fd
- | Cdata dl -> Llvmemit.data dl
- else
- match p with
- | Cfunction fd -> compile_fundecl ppf fd
- | Cdata dl -> Emit.data dl
+ | Cfunction fd -> compile_fundecl fd
+ | Cdata dl -> data dl
(* For the native toplevel: generates generic functions unless
@@ -99,6 +96,12 @@ let compile_genfuns ppf f =
| _ -> ())
(Cmmgen.generic_functions true [Compilenv.current_unit_infos ()])
+let begin_assembly () =
+ if !use_llvm then Llvmcompile.begin_assembly() else Emit.begin_assembly()
+
+let end_assembly () =
+ if !use_llvm then Llvmcompile.end_assembly() else Emit.end_assembly()
+
let compile_implementation ?toplevel prefixname ppf (size, lam) =
let suffix = if !use_llvm then ext_llvm else ext_asm in
let asmfile =
@@ -108,10 +111,10 @@ let compile_implementation ?toplevel prefixname ppf (size, lam) =
let oc = open_out asmfile in
begin try
Emitaux.output_channel := oc;
- if !use_llvm then Llvmemit.begin_assembly() else Emit.begin_assembly();
+ begin_assembly();
Closure.intro size lam
++ Cmmgen.compunit size
- ++ List.map (fun x -> Llvmcompile.read_function x; x)
+ ++ List.map (fun x -> Llvmcompile.read_function x; x) (* TODO only do this when compiling using LLVm *)
++ List.iter (compile_phrase ppf) ++ (fun () -> ());
(match toplevel with None -> () | Some f -> compile_genfuns ppf f);
@@ -127,7 +130,7 @@ let compile_implementation ?toplevel prefixname ppf (size, lam) =
(List.map Primitive.native_name !Translmod.primitive_declarations))
);
- if !use_llvm then Llvmemit.end_assembly() else Emit.end_assembly();
+ end_assembly();
close_out oc
with x ->
close_out oc;
@@ -142,7 +145,7 @@ let compile_implementation ?toplevel prefixname ppf (size, lam) =
if !Clflags.keep_asm_file then prefixname ^ ext_asm
else Filename.temp_file prefixname ext_asm
in
- let assemble = if !use_llvm then Llvmemit.assemble_file temp1 temp2 else Proc.assemble_file in
+ let assemble = if !use_llvm then Llvmcompile.assemble_file temp1 temp2 else Proc.assemble_file in
if assemble asmfile (prefixname ^ ext_obj) <> 0
then raise(Error(Assembler_error asmfile));
if !keep_asm_file then ()
View
@@ -20,6 +20,9 @@ val compile_implementation :
val compile_phrase :
Format.formatter -> Cmm.phrase -> unit
+val begin_assembly : unit -> unit
+val end_assembly : unit -> unit
+
type error = Assembler_error of string
exception Error of error
val report_error: Format.formatter -> error -> unit
View
@@ -203,7 +203,7 @@ let make_startup_file ppf filename units_list =
Emitaux.output_channel := oc;
Location.input_name := "caml_startup"; (* set name of "current" input *)
Compilenv.reset "_startup"; (* set the name of the "current" compunit *)
- if !Clflags.use_llvm then Llvmemit.begin_assembly() else Emit.begin_assembly();
+ Asmgen.begin_assembly();
let name_list =
List.flatten (List.map (fun (info,_,_) -> info.ui_defines) units_list) in
compile_phrase (Cmmgen.entry_point name_list);
@@ -229,7 +229,7 @@ let make_startup_file ppf filename units_list =
compile_phrase
(Cmmgen.frame_table("_startup" :: "_system" :: name_list));
- if !Clflags.use_llvm then Llvmemit.end_assembly() else Emit.end_assembly();
+ Asmgen.end_assembly();
close_out oc
let make_shared_startup_file ppf units filename =
@@ -238,7 +238,7 @@ let make_shared_startup_file ppf units filename =
Emitaux.output_channel := oc;
Location.input_name := "caml_startup";
Compilenv.reset "_shared_startup";
- Emit.begin_assembly();
+ Asmgen.begin_assembly();
List.iter compile_phrase
(Cmmgen.generic_functions true (List.map fst units));
compile_phrase (Cmmgen.plugin_header units);
@@ -248,7 +248,7 @@ let make_shared_startup_file ppf units filename =
(* this is to force a reference to all units, otherwise the linker
might drop some of them (in case of libraries) *)
- Emit.end_assembly();
+ Asmgen.end_assembly();
close_out oc
@@ -336,7 +336,7 @@ let link ppf objfiles output_name =
else Filename.temp_file "camlstartup" ext_asm
in
if !Clflags.use_llvm then begin
- if Llvmemit.assemble_file temp1 temp2 startup startup_obj <> 0 then
+ if Llvmcompile.assemble_file temp1 temp2 startup startup_obj <> 0 then
raise(Error(Assembler_error startup));
end else
if Proc.assemble_file startup startup_obj <> 0
View
@@ -0,0 +1,81 @@
+open Llvm_mach
+
+let error s = error ("Llvm_aux: " ^ s)
+
+let debug = ref false
+
+let print_debug str = if !debug then print_endline str
+
+let (++) x f = f x
+
+(* Print an expression in the intermediate format using a syntax inspired by
+ * S-expressions *)
+let reg_to_string = function
+ Const(value, _) -> value
+ | Reg(value, _) -> "%" ^ value
+ | Nothing -> "Nothing"
+
+let rec to_string instr =
+ let foo =
+ let typ = instr.typ in
+ let res = reg_to_string instr.res ^ " = " in
+ let typ_str = string_of_type typ ^ " " ^ res in
+ match instr.desc, instr.arg with
+ Iend, _ -> "" (* BUG? changing this to a non-empty string causes a stack overflow *)
+ | Ibinop op, [|left; right|] ->
+ typ_str ^ string_of_binop op ^ " " ^ reg_to_string left ^ " " ^ reg_to_string right
+ | Ibinop op, args -> error ("using binop " ^ string_of_binop op ^ " with " ^ string_of_int (Array.length args) ^ " arguments")
+ | Icomp op, [|left; right|] ->
+ typ_str ^ string_of_comp typ op ^ " " ^ reg_to_string left ^ " " ^ reg_to_string right
+ | Icomp op, args -> error ("using comp " ^ string_of_comp typ op ^ " with " ^ string_of_int (Array.length args) ^ " arguments")
+ | Ialloca, [||] -> string_of_type typ ^ "* " ^ res ^ "alloca " ^ string_of_type typ
+ | Ialloca, args -> error ("using alloca with " ^ string_of_int (Array.length args) ^ " arguments")
+ | Iload, [|addr|] -> typ_str ^ "load " ^ string_of_type (typeof addr) ^ " " ^ reg_to_string addr
+ | Iload, args -> error ("using load with " ^ string_of_int (Array.length args) ^ " arguments")
+ | Istore, [|value; addr|] ->
+ "store " ^ string_of_type typ ^ " " ^ reg_to_string value ^ " " ^ string_of_type (Address typ) ^ " " ^ reg_to_string addr ^ ")"
+ | Istore, args -> error ("using store with " ^ string_of_int (Array.length args) ^ " arguments")
+ | Ifptosi, [|value|] -> typ_str ^ "fptosi " ^ reg_to_string value
+ | Ifptosi, args -> error ("using fptosi with " ^ string_of_int (Array.length args) ^ " arguments")
+ | Isitofp, [|value|] -> typ_str ^ "sitofp " ^ reg_to_string value
+ | Isitofp, args -> error ("using sitofp with " ^ string_of_int (Array.length args) ^ " arguments")
+ | Igetelementptr, [|addr; offset|] -> typ_str ^ "getelementptr " ^ reg_to_string addr ^ " " ^ reg_to_string offset
+ | Igetelementptr, args -> error ("using getelementptr with " ^ string_of_int (Array.length args) ^ " arguments")
+ | Icall fn, args ->
+ let args = Array.to_list args in
+ typ_str ^ "call " ^ reg_to_string fn ^ "(" ^ String.concat " " (List.map reg_to_string args) ^ ")"
+ | Iextcall fn, args ->
+ let args = Array.to_list args in
+ typ_str ^ "c-call " ^ reg_to_string fn ^ "(" ^ String.concat " " (List.map reg_to_string args) ^ ")"
+ | Iifthenelse(ifso, ifnot), [|cond|] ->
+ "if " ^ reg_to_string cond ^ " then {\n" ^ to_string ifso ^ "} else {\n" ^ to_string ifnot ^ "}"
+ | Iifthenelse(_,_), args -> error ("using ifthenelse with " ^ string_of_int (Array.length args) ^ " arguments")
+ | Iswitch(indexes, blocks), [|value|] ->
+ "switch (" ^ string_of_type typ ^ " " ^ reg_to_string value ^ ") {\n\t" ^
+ String.concat "\n\t" (Array.to_list (Array.map to_string blocks)) ^ "}"
+ | Iswitch(_,_), args -> error ("using switch with " ^ string_of_int (Array.length args) ^ " arguments")
+ | Ireturn, [|value|] ->
+ "return " ^ string_of_type typ ^ " " ^ reg_to_string value
+ | Ireturn, args -> error ("using return with " ^ string_of_int (Array.length args) ^ " arguments")
+ | Iloop instr, [||] -> "loop {\n" ^ to_string instr ^ "}"
+ | Iloop _, args -> error ("using loop with " ^ string_of_int (Array.length args) ^ " arguments")
+ | Iexit i, [||] -> "goto exit" ^ string_of_int i
+ | Iexit _, args -> error ("using exit with " ^ string_of_int (Array.length args) ^ " arguments")
+ | Icatch(i, instr1, instr2), [|instr; res|] ->
+ "catch " ^ reg_to_string res ^ " = " ^ reg_to_string instr (* TODO figure out what to do here *)
+ | Icatch(_,_,_), args -> error ("using catch with " ^ string_of_int (Array.length args) ^ " arguments")
+ | Iraise, [|exn|] -> "raise " ^ reg_to_string exn
+ | Iraise, args -> error ("using raise with " ^ string_of_int (Array.length args) ^ " arguments")
+ | Itrywith(try_instr, with_instr), [||] -> "try {\n" ^ to_string try_instr ^ "} with {\n" ^ to_string with_instr ^ "}"
+ | Itrywith(_,_), args -> error ("using try-with with " ^ string_of_int (Array.length args) ^ " arguments")
+ | Ialloc len, [||] -> typ_str ^ "alloc " ^ string_of_int len
+ | Ialloc _, args -> error ("using alloc with " ^ string_of_int (Array.length args) ^ " arguments")
+ | Iunreachable, [||] -> "unreachable"
+ | Iunreachable, args -> error ("using unreachable with " ^ string_of_int (Array.length args) ^ " arguments")
+ | Icomment s, [||] -> "comment " ^ s
+ | Icomment _, args -> error ("using comment with " ^ string_of_int (Array.length args) ^ " arguments")
+ (*| _, args -> error ("unknown instruction with " ^ string_of_int
+ * (Array.length args) ^ " arguments")*)
+ in
+ if foo = "" then foo
+ else foo ^ "\n" ^ to_string instr.next
View
@@ -0,0 +1,11 @@
+val debug : bool ref
+(* Print a debugging message to stdout *)
+val print_debug : string -> unit
+
+val (++) : 'a -> ('a -> 'b) -> 'b
+
+val reg_to_string : Llvm_mach.ssa_reg -> string
+
+(* Print the internal representation of an LLVM instruction in a notation
+ * inspired by S-expressions *)
+val to_string : Llvm_mach.instruction -> string
Oops, something went wrong.

0 comments on commit 054dce9

Please sign in to comment.