Skip to content
Browse files

Fixed a couple of bugs in the LLVM back end

The compiler can now be used to compile itself.  The resulting binary
however fails during garbage collection.
  • Loading branch information...
1 parent f2715a8 commit 5a2ae52bfb7fc246833bb576de15baeff19cecc5 @colinbenner committed Feb 21, 2012
View
2 _oasis
@@ -41,7 +41,7 @@ Executable ocamlllvm
MainIs: ocamlllvm.ml
# CSources: jitrun/camlnat.h, jitrun/jit.c, jitrun/str.c
BuildDepends: dynlink, findlib (>= 1.2.7)
- CompiledObject: byte
+ CompiledObject: native
#Executable test
# Path: tests
View
6 _tags
@@ -3,10 +3,10 @@
#<src/*/*.mlp>: process_mlp
# OASIS_START
-# DO NOT EDIT (digest: 3ffc46df62a60cbbfb46eaf06d424c39)
+# DO NOT EDIT (digest: 7a621d6363b4c54cd85bdfaa6aa08ff0)
# Executable ocamlllvm
-"src/ocamlllvm.byte": pkg_findlib
-"src/ocamlllvm.byte": pkg_dynlink
+"src/ocamlllvm.native": pkg_findlib
+"src/ocamlllvm.native": pkg_dynlink
<src/*.ml{,i}>: pkg_findlib
<src/*.ml{,i}>: pkg_dynlink
# OASIS_STOP
View
4 setup.ml
@@ -1,7 +1,7 @@
(* setup.ml generated for the first time by OASIS v0.2.0 *)
(* OASIS_START *)
-(* DO NOT EDIT (digest: 55d92b14fa6330bca1934668d817bb70) *)
+(* DO NOT EDIT (digest: 09cec38566e39e10be104b40d8662343) *)
(*
Regenerated by OASIS v0.2.0
Visit http://oasis.forge.ocamlcore.org for more information and
@@ -5050,7 +5050,7 @@ let setup_t =
bs_build = [(OASISExpr.EBool true, true)];
bs_install = [(OASISExpr.EBool true, true)];
bs_path = "src";
- bs_compiled_object = Byte;
+ bs_compiled_object = Native;
bs_build_depends =
[
FindlibPackage ("dynlink", None);
View
6 src/asmcomp/asmgen.ml
@@ -114,7 +114,7 @@ let compile_implementation ?toplevel prefixname ppf (size, lam) =
begin_assembly();
Closure.intro size lam
++ Cmmgen.compunit size
- ++ List.map (fun x -> Llvmcompile.read_function x; x) (* TODO only do this when compiling using LLVm *)
+ ++ List.map (fun x -> if !use_llvm then Llvmcompile.read_function x; x)
++ List.iter (compile_phrase ppf) ++ (fun () -> ());
(match toplevel with None -> () | Some f -> compile_genfuns ppf f);
@@ -139,11 +139,11 @@ let compile_implementation ?toplevel prefixname ppf (size, lam) =
end;
let temp1 =
if !Clflags.keep_asm_file then prefixname ^ ".opt" ^ ext_llvm
- else Filename.temp_file (prefixname ^ ".opt") ext_llvm
+ else Filename.temp_dir_name ^ "/" ^ Filename.basename prefixname ^ ext_llvm
in
let temp2 =
if !Clflags.keep_asm_file then prefixname ^ ext_asm
- else Filename.temp_file prefixname ext_asm
+ else Filename.temp_dir_name ^ "/" ^ Filename.basename prefixname ^ ext_asm
in
let assemble = if !use_llvm then Llvmcompile.assemble_file temp1 temp2 else Proc.assemble_file in
if assemble asmfile (prefixname ^ ext_obj) <> 0
View
74 src/asmcomp/llvm_linearize.ml
@@ -104,7 +104,21 @@ let cast_reg value dest_typ reg =
let cast value dest_typ = cast_reg value dest_typ (register "" dest_typ)
-let alloca result = assert (typeof result <> Address Void); insert Lalloca [||] result; result
+let allocas : (string, instruction) Hashtbl.t = Hashtbl.create 10
+
+let alloca result =
+ assert (typeof result <> Address Void);
+ if Hashtbl.mem allocas (reg_name result) then begin
+ insert_simple (Lcomment "stripped an alloca, using the one with the same name already existing");
+ Const(reg_name result, typeof (Hashtbl.find allocas (reg_name result)).res)
+ end else begin
+ Hashtbl.add allocas (reg_name result) {desc = Lalloca; next = end_instr; arg = [||]; res = result; dbg = Debuginfo.none};
+ if is_addr (deref (typeof result)) then
+ insert (Lextcall (Const("@llvm.gcroot", Function(Void, [Address (Address byte); Address byte]))))
+ [|cast result (Address (Address byte)); Const("null", Address byte)|] Nothing;
+ result
+ end
+
let load addr result = insert Lload [|addr|] result; result
let branch lbl = insert_simple (Lbranch lbl)
let label lbl = insert_simple (Llabel lbl)
@@ -137,13 +151,7 @@ let rec linear i =
insert (Lcomp op) [|cast left typ; cast right typ|] res
| Ialloca, [||] ->
print_debug "Ialloca";
- (*
ignore (alloca res)
- *)
- let a = alloca res in
- if is_addr (deref (typeof a)) then
- insert (Lextcall (Const("@llvm.gcroot", Function(Void, [Address (Address byte); Address byte]))))
- [|cast a (Address (Address byte)); Const("null", Address byte)|] Nothing;
| Iload, [|addr|] ->
print_debug "Iload";
ignore (load (cast addr (Address typ)) res)
@@ -186,17 +194,16 @@ let rec linear i =
insert (Lcondbranch(then_lbl, else_lbl)) [|cond|] Nothing;
label then_lbl;
linear ifso;
- if typeof (last_instr ifso).Llvm_mach.res = Void then ()
- else insert Lstore [|cast (last_instr ifso).Llvm_mach.res (typeof res); if_res|] Nothing;
+ if typeof (last_instr ifso).Llvm_mach.res <> Void
+ then insert Lstore [|cast (last_instr ifso).Llvm_mach.res (typeof res); cast if_res (Address (typeof res))|] Nothing;
branch endif_lbl;
label else_lbl;
linear ifnot;
- if typeof (last_instr ifnot).Llvm_mach.res = Void then ()
- else insert Lstore [|cast (last_instr ifnot).Llvm_mach.res (typeof res); if_res|] Nothing;
+ if typeof (last_instr ifnot).Llvm_mach.res <> Void
+ then insert Lstore [|cast (last_instr ifnot).Llvm_mach.res (typeof res); cast if_res (Address (typeof res))|] Nothing;
branch endif_lbl;
label endif_lbl;
- if typeof res = Void then ()
- else insert Lload [|if_res|] res
+ if typeof res <> Void then insert Lload [|cast if_res (Address (typeof res))|] res
| Iswitch(indexes, blocks), [|value|] ->
print_debug "Iswitch";
let c = c () in
@@ -215,11 +222,12 @@ let rec linear i =
(fun i block ->
label ("case" ^ string_of_int i ^ c);
linear block;
- if typ <> Void then
+ if typ <> Void then begin
let res = (last_instr block).Llvm_mach.res in
if typeof res <> Void then
- insert Lstore [|cast (last_instr block).Llvm_mach.res typ; switch_res|] Nothing;
- branch ("endswitch" ^ c);
+ insert Lstore [|cast (last_instr block).Llvm_mach.res typ; switch_res|] Nothing
+ end;
+ branch ("endswitch" ^ c)
) blocks;
label ("endswitch" ^ c);
insert Lload [|switch_res|] res
@@ -341,26 +349,28 @@ let rec linear i =
end; linear next end
-
-let move_allocas_to_entry_block instr =
- let allocas = ref [] in
- let rec helper prev instr =
- match instr.desc with
- | Lend -> !allocas
- | Lalloca -> allocas := instr :: !allocas; prev.next <- instr.next; helper prev prev.next
- | _ -> helper instr instr.next
- in
- let allocas = helper instr instr.next in
- List.iter (fun i -> i.next <- instr.next; instr.next <- i) allocas;
- instr
-
-
-
let rec len instr =
match instr.desc with
Lend -> 0
| _ -> 1 + len instr.next
+
+let insert_allocas allocas instrs =
+ let instr = ref instrs.next in
+ let insert_alloca a =
+ a.next <- !instr;
+ instr := a;
+ in
+ List.iter insert_alloca allocas;
+ !instr
+
+let get_allocas () =
+ (* Hashtbl.fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c *)
+ let result = Hashtbl.fold (fun _ b c -> b :: c) allocas [] in
+ Hashtbl.clear allocas;
+ result
+
+
let fundecl f =
try
counter := 0;
@@ -372,7 +382,7 @@ let fundecl f =
instr_seq := [];
{ fun_name = f.name;
fun_args = List.map (fun (name, typ) -> Reg(name, typ)) f.args;
- fun_body = move_allocas_to_entry_block instrs }
+ fun_body = insert_allocas (get_allocas()) instrs }
with Llvm_error s ->
print_endline ("error while linearising " ^ f.name);
print_endline (to_string f.body);
View
44 src/asmcomp/llvm_selectgen.ml
@@ -90,12 +90,19 @@ let insert_debug seq desc dbg arg res typ =
seq := (desc, arg, res, typ, dbg) :: !seq;
res
+let add_type name typ =
+ Hashtbl.replace types name typ
+
+let rec strip_addrs = function
+ | Address (Address _ as typ) -> strip_addrs typ
+ | typ -> typ
+
let comment seq str = ignore (insert seq (Icomment str) [||] Nothing Void)
let alloca seq name typ =
assert (typ <> Void);
- Hashtbl.add types name (Address typ);
- insert seq Ialloca [||] (Reg(name, Address typ)) typ
+ add_type name (strip_addrs (Address typ));
+ insert seq Ialloca [||] (Reg(name, strip_addrs (Address typ))) (deref (strip_addrs (Address typ)))
let load seq arg reg typ = insert seq Iload [|arg|] (register reg typ) typ
let store seq value addr typ = ignore (insert seq Istore [|value; addr|] Nothing typ)
@@ -121,14 +128,15 @@ let getelemptr seq addr offset typ =
insert seq Igetelementptr [|addr; offset|] (register "" (typeof addr)) typ
(* }}} *)
-let add_type name typ =
- Hashtbl.add types name typ
+let is_function = function
+ | Function(_,_) | Address(Function(_,_)) -> true
+ | _ -> false
(* very simple type inference algorithm used to determine which type an
* identifier has *)
(* {{{ *)
let rec caml_type expect = function
- | Cconst_int _ -> int_type
+ | Cconst_int _ -> addr_type
| Cconst_natint _ -> int_type
| Cconst_float _ -> Double
| Cconst_symbol _ -> addr_type
@@ -142,7 +150,7 @@ let rec caml_type expect = function
| Clet(id,arg,body) ->
let name = translate_id id in
let typ = caml_type Any arg in
- if not (Hashtbl.mem types name) then
+ if not (Hashtbl.mem types name) || not (is_function (get_type name)) then
add_type name (if typ = Any || typ = Void then addr_type else typ);
caml_type expect body
| Cassign(id,expr) ->
@@ -189,9 +197,14 @@ let rec caml_type expect = function
| Csequence(fst,snd) -> ignore (caml_type Any fst); caml_type expect snd
| Cifthenelse(cond, expr1, expr2) ->
ignore (caml_type int_type cond);
- let typ = caml_type Any expr1 in caml_type typ expr2
- | Cswitch(expr,is,exprs) -> Array.iter (fun x -> ignore (caml_type expect x)) exprs; expect (* TODO figure out the real type *)
- | Cloop expr -> ignore (caml_type Any expr); Void
+ let typ = caml_type expect expr1 in
+ let typ2 = caml_type (if typ <> Void then typ else expect) expr2 in
+ if typ <> Void then typ else typ2
+ | Cswitch(expr,is,exprs) ->
+ let typ = ref Void in
+ Array.iter (fun x -> let t = caml_type expect x in if t <> Void then typ := t) exprs;
+ !typ
+ | Cloop expr -> ignore (caml_type Void expr); Void
| Ccatch(i,ids,expr1,expr2) ->
ignore (caml_type expect expr1);
ignore (caml_type expect expr2);
@@ -281,18 +294,19 @@ let rec compile_instr seq instr =
| Cop(Calloc, args) -> (* TODO figure out how much space a single element needs *)
print_debug "Calloc";
let args = List.map (compile_instr seq) args in
- let ptr = alloc seq (List.length args) "alloc" addr_type in
- let header = getelemptr seq ptr (Const("1", int_type)) addr_type in
+ let alloc = alloc seq (List.length args) "alloc" addr_type in
+ let alloc = getelemptr seq alloc (Const("1", int_type)) addr_type in
let num = ref (-1) in
let emit_arg elem =
let counter = string_of_int !num in
- let elemptr = getelemptr seq header (Const(counter, int_type)) addr_type in
+ let elemptr = getelemptr seq alloc (Const(counter, int_type)) addr_type in
num := !num + 1;
- ignore (insert seq Istore [|elem; elemptr|] ptr (typeof elem))
- (*store seq elem elemptr (typeof elem)*)
+ (* The store itself returns [Nothing] but the enclosing blocks result is
+ * [alloc]. vvvvv *)
+ ignore (insert seq Istore [|elem; elemptr|] alloc (typeof elem))
in
List.iter emit_arg args;
- header
+ alloc
| Cop(Cstore mem, [addr; value]) ->
print_debug "Cstore";
store seq (compile_instr seq value) (compile_instr seq addr) (translate_mem mem);
View
34 src/asmcomp/llvmemit.ml
@@ -63,6 +63,8 @@ let translate_comp typ =
let print_array f arr =
String.concat ", " (Array.to_list (Array.map f arr))
+(* Produce a verbose representation of an Instruktion. Used to produce debugging
+* output in case something goes wrong when generating LLVM IR. *)
let to_string instr = begin
let res = instr.res in
match instr.desc with
@@ -95,26 +97,26 @@ let emit_op reg op typ args =
emit_instr (reg_name reg ^ " = " ^ op ^ " " ^ string_of_type typ ^ " " ^
String.concat ", " (List.map reg_name args))
-let arg_list args =
- String.concat ", " (List.map string_of_reg args)
+let arg_list args = String.concat ", " (List.map string_of_reg args)
let emit_cast reg op value typ =
emit_instr (reg_name reg ^ " = " ^ op ^ " " ^ string_of_reg value ^ " to " ^
string_of_type (typeof reg))
let rec instr_iter f instr =
- match instr.desc with
- Lend -> ()
- | _ -> f instr; instr_iter f instr.next
+ if instr.desc <> Lend then begin
+ f instr;
+ instr_iter f instr.next
+ end
let emit_call res cc fn args =
let fn = " " ^ reg_name fn ^ "(" ^ print_array string_of_reg args ^ ") nounwind" in
emit_instr ((if res <> Nothing then reg_name res ^ " = " else "") ^ "call " ^
cc ^ " " ^ (if res <> Nothing then string_of_type (typeof res) else "void") ^ fn)
let emit_llvm instr =
- let { desc = desc; next = next; arg = arg; res = res; dbg = dbg } = instr in begin
- match desc, arg, res with
+ let { desc = desc; next = next; arg = arg; res = res; dbg = dbg } = instr in
+ begin match desc, arg, res with
Lend, _, _ -> ()
| Lop op, [|left; right|], Reg(_, typ) ->
emit_op res (string_of_binop op) typ [left; right]
@@ -124,14 +126,13 @@ let emit_llvm instr =
emit_cast res (string_of_cast op) value typ
| Lalloca, [||], Reg(_, typ) ->
emit_instr (reg_name res ^ " = alloca " ^ string_of_type (try deref typ with Cast_error s -> error "dereferencing result type of Lalloca failed"))
- | Lload, [|addr|], Reg(_, typ) -> emit_op res "load" (typeof addr) [addr]
- | Lload, [|addr|], Const(_, typ) -> emit_op res "load" (typeof addr) [addr]
+ | Lload, [|addr|], Reg(_, _) -> emit_op res "load" (typeof addr) [addr]
| Lstore, [|value; addr|], Nothing ->
emit_instr ("store " ^ arg_list [value; addr])
- | Lgetelemptr, [|addr; offset|], Reg(_, typ) ->
+ | Lgetelemptr, [|addr; offset|], Reg(_, _) ->
emit_instr (reg_name res ^ " = getelementptr " ^ arg_list [addr; offset])
- | Lfptosi, [|value|], Reg(name, typ) -> emit_cast res "fptosi" value typ
- | Lsitofp, [|value|], Reg(name, typ) -> emit_cast res "sitofp" value typ
+ | Lfptosi, [|value|], Reg(_, typ) -> emit_cast res "fptosi" value typ
+ | Lsitofp, [|value|], Reg(_, typ) -> emit_cast res "sitofp" value typ
| Lcall fn, args, _ -> emit_call res calling_conv fn args
| Lextcall fn, args, _ -> emit_call res "ccc" fn args
| Llabel name, [||], Nothing -> emit_label name
@@ -189,7 +190,6 @@ let fundecl = function { fun_name = name; fun_args = args; fun_body = body } ->
*)
let header =
let addr_type = string_of_type addr_type in
- let undef = addr_type ^ " undef" in
[ "; vim: set ft=llvm:"
(*
; "%jump_buf_t = type [5 x " ^ addr_type ^ "]"
@@ -207,7 +207,7 @@ let header =
; "declare " ^ calling_conv ^ " " ^ addr_type ^ " @caml_allocN(" ^ addr_type ^ ") nounwind"
; "declare void @caml_ml_array_bound_error() nounwind"
; "declare void @caml_call_gc() nounwind"
- ; "@caml_exception_pointer = external global " ^ addr_type
+(* ; "@caml_exception_pointer = external global " ^ addr_type*)
; "@caml_young_ptr = external global " ^ addr_type
; "@caml_young_limit = external global " ^ addr_type
; "@caml_bottom_of_stack = external global " ^ addr_type
@@ -245,7 +245,11 @@ let emit_function_declarations () =
List.iter fn (List.filter (fun (_, _, name, _) -> not (List.mem name (List.map fst !local_functions))) !functions)
let emit_constant_declarations () =
- List.iter (fun name -> if List.mem name (List.map (fun (_,_,x,_) -> x) !functions) then () else emit_nl ("@" ^ name ^ " = external global " ^ string_of_type int_type)) !constants
+ List.iter (fun name ->
+ if not (List.mem name (List.map (fun (_,_,x,_) -> x) !functions)) &&
+ not (List.mem name (List.map fst !local_functions)) then
+ emit_nl ("@" ^ name ^ " = external global " ^ string_of_type int_type))
+ !constants
(* Emission of data *)
View
10 src/asmrun/amd64.S
@@ -358,7 +358,7 @@ FUNCTION(G(caml_start_program))
movq %rsp, %r14
#else
movq %rdi, %rbp
- movq caml_jump_buffer@GOTPCREL(%rip), %rdi
+ movq GREL(caml_jump_buffer)(%rip), %rdi
callq setjmp@plt
testq %rax, %rax
jnz .Lfoobar /* if rax = 0 this is the first return */
@@ -395,7 +395,7 @@ FUNCTION(G(caml_start_program))
ret
.Lfoobar:
/* move the pointer to the exception into the first argument register */
- movq caml_exn@GOTPCREL(%rip), %rax
+ movq GREL(caml_exn)(%rip), %rax
movq (%rax), %rax
.L108:
/* Exception handler*/
@@ -424,7 +424,7 @@ FUNCTION(G(caml_raise_exn))
popq %r14
ret
#else
- movq caml_jump_buffer@GOTPCREL(%rip), %rdi
+ movq GREL(caml_jump_buffer)(%rip), %rdi
movq $1, %rsi
callq longjmp@plt
#endif
@@ -453,9 +453,9 @@ FUNCTION(G(caml_raise_exception))
LOAD_VAR(caml_young_ptr,%r15) /* Reload alloc ptr */
ret
#else
- movq caml_exn@GOTPCREL(%rip), %rsi
+ movq GREL(caml_exn)(%rip), %rsi
movq %rdi, (%rsi)
- movq caml_jump_buffer@GOTPCREL(%rip), %rdi
+ movq GREL(caml_jump_buffer)(%rip), %rdi
movq $1, %rsi
callq longjmp@plt
#endif
View
12 src/asmrun/fail.c
@@ -50,22 +50,22 @@ extern caml_generated_constant
extern void caml_raise_exception (value bucket) Noreturn;
-char * caml_exception_pointer = NULL;
+//char * caml_exception_pointer = NULL;
void caml_raise(value v)
{
Unlock_exn();
- if (caml_exception_pointer == NULL) caml_fatal_uncaught_exception(v);
+// if (caml_exception_pointer == NULL) caml_fatal_uncaught_exception(v);
#ifndef Stack_grows_upwards
#define PUSHED_AFTER <
#else
#define PUSHED_AFTER >
#endif
- while (caml_local_roots != NULL &&
- (char *) caml_local_roots PUSHED_AFTER caml_exception_pointer) {
- caml_local_roots = caml_local_roots->next;
- }
+// while (caml_local_roots != NULL &&
+// (char *) caml_local_roots PUSHED_AFTER caml_exception_pointer) {
+// caml_local_roots = caml_local_roots->next;
+// }
#undef PUSHED_AFTER
caml_raise_exception(v);
View
2 src/asmrun/roots.c
@@ -110,7 +110,7 @@ void caml_init_frame_descriptors(void)
d = (frame_descr *)(tbl + 1);
for (j = 0; j < len; j++) {
h = Hash_retaddr(d->retaddr);
- while (caml_frame_descriptors[h] != NULL) {
+ while (caml_frame_descriptors[h] != NULL) { // infitine loop
h = (h+1) & caml_frame_descriptors_mask;
}
caml_frame_descriptors[h] = d;
View
4 src/asmrun/signals_asm.c
@@ -158,7 +158,7 @@ DECLARE_SIGNAL_HANDLER(trap_handler)
sigprocmask(SIG_UNBLOCK, &mask, NULL);
}
#endif
- caml_exception_pointer = (char *) CONTEXT_EXCEPTION_POINTER;
+// caml_exception_pointer = (char *) CONTEXT_EXCEPTION_POINTER;
caml_young_ptr = (char *) CONTEXT_YOUNG_PTR;
#if defined(SYS_rhapsody)
caml_bottom_of_stack = (char *) CONTEXT_SP;
@@ -196,7 +196,7 @@ DECLARE_SIGNAL_HANDLER(segv_handler)
) {
/* Turn this into a Stack_overflow exception */
#if defined(CONTEXT_YOUNG_PTR) && defined(CONTEXT_EXCEPTION_POINTER)
- caml_exception_pointer = (char *) CONTEXT_EXCEPTION_POINTER;
+// caml_exception_pointer = (char *) CONTEXT_EXCEPTION_POINTER;
caml_young_ptr = (char *) CONTEXT_YOUNG_PTR;
#endif
caml_raise_stack_overflow();
View
2 src/asmrun/stack.h
@@ -125,7 +125,7 @@ extern char * caml_top_of_stack;
extern char * caml_bottom_of_stack;
extern uintnat caml_last_return_address;
extern value * caml_gc_regs;
-extern char * caml_exception_pointer;
+//extern char * caml_exception_pointer;
extern value caml_globals[];
extern intnat caml_globals_inited;
extern intnat * caml_frametable[];
View
2 src/driver/optmain.ml
@@ -159,7 +159,7 @@ module Options = Main_args.Make_optcomp_options (struct
let _dscheduling = set dump_scheduling
let _dlinear = set dump_linear
let _dstartup = set keep_startup_file
- let _llvm = set use_llvm
+ let _llvm = clear use_llvm
let anonymous = anonymous
end);;
View
BIN src/stdlib/.filename.ml.swp
Binary file not shown.
View
2 src/utils/clflags.ml
@@ -78,7 +78,7 @@ let dump_combine = ref false (* -dcombine *)
let native_code = ref false (* set to true under ocamlopt *)
let inline_threshold = ref 10
-let use_llvm = ref false (* -llvm *)
+let use_llvm = ref true (* -llvm *)
let dont_write_files = ref false (* set to true under ocamldoc *)

0 comments on commit 5a2ae52

Please sign in to comment.
Something went wrong with that request. Please try again.