Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Finally fixed the bug that caused an additional "." when printing flo…

…ating point numbers and a few others

The generated LLVM was totally wrong for catch statements.  The with
block was always executed, not just when using the exit statement.
  • Loading branch information...
commit 8f7b982fa882db2ed696f43470cf589ad6455d1e 1 parent 5af63f5
@colinbenner authored
View
15 src/asmcomp/llvm_linearize.ml
@@ -97,14 +97,14 @@ let cast_reg value dest_typ reg =
| (Address _, Integer _) -> cast Ptrtoint value reg
| (Double, Address _) -> let tmp = register "tmp" float_sized_int in cast Bitcast value tmp; cast Inttoptr tmp reg
| (Address _, Double) -> let tmp = register "tmp" float_sized_int in cast Ptrtoint value tmp; cast Bitcast tmp reg
- | (a, b) -> error ("error while trying to cast " ^ string_of_type typ ^
+ | (a, b) -> error ("error while trying to cast " ^ string_of_reg value ^
" to " ^ string_of_type dest_typ)
end;
if typ = dest_typ then value else reg
let cast value dest_typ = cast_reg value dest_typ (register "" dest_typ)
-let alloca result = assert (typeof result <> Void); insert Lalloca [||] result; result
+let alloca result = assert (typeof result <> Address Void); insert Lalloca [||] result; result
let load addr result = insert Lload [|addr|] result; result
let branch lbl = insert_simple (Lbranch lbl)
let label lbl = insert_simple (Llabel lbl)
@@ -179,7 +179,7 @@ let rec linear i =
assert (typeof cond = bit);
let counter = c () in
let then_lbl, else_lbl, endif_lbl = "then" ^ counter, "else" ^ counter, "endif" ^ counter in
- let if_res = if typeof res = Void then Nothing else alloca (register "if_tmp" (Address (typeof res))) in
+ let if_res = if typeof res = Void then Nothing else (assert (typeof res <> Void); alloca (register "if_tmp" (Address (typeof res)))) in
insert (Lcondbranch(then_lbl, else_lbl)) [|cond|] Nothing;
label then_lbl;
linear ifso;
@@ -198,10 +198,9 @@ let rec linear i =
print_debug "Iswitch";
let c = c () in
let labels = Array.map (fun i -> "case" ^ string_of_int i ^ c) indexes in (* TODO create the correct labels *)
- let switch_res = alloca (register "" (if typ <> Void then Address typ else addr_type)) in
+ let switch_res = alloca (register "" (assert (typ <> Address Void); if typ <> Void then Address typ else addr_type)) in
insert (Lswitch("default" ^ c, labels)) [|cast value int_type|] Nothing;
label ("default" ^ c);
- (* TODO throw an exception saying that the match was invalid*)
insert Lstore [|Const("@caml_exn_Match_failure", addr_type); Const("@exn", Address addr_type)|] Nothing;
insert (Lextcall (Const("@llvm.eh.sjlj.longjmp", Function(Void, [Address byte]))))
[|cast (Const("@jmp_buf", Address Jump_buffer)) (Address byte)|] Nothing;
@@ -237,8 +236,6 @@ let rec linear i =
let c = c() in
let try_lbl, with_lbl, cont_lbl = "try" ^ c, "with" ^ c, "cont" ^ c in
(* TODO write exception handling code *)
- (* call setjmp *)
- (* if setjmp returned 0 *)
let old_jmp_buf = alloca (register "old_jmp_buf" (Address Jump_buffer)) in
let temp_buf = load (Const("@jmp_buf", Address Jump_buffer)) (register "" Jump_buffer) in
insert Lstore [|temp_buf; old_jmp_buf|] Nothing;
@@ -272,13 +269,15 @@ let rec linear i =
linear body;
let body_res = (last_instr body).Llvm_mach.res in
if typeof body_res <> Void then insert Lstore [|cast body_res typ; tmp|] Nothing else insert_simple (Lcomment "nothing to store in body");
- branch ("exit" ^ string_of_int i ^ c);
+ branch ("endcatch" ^ c);
label ("exit" ^ string_of_int i ^ c);
Hashtbl.remove exits i;
linear handler;
let handler_res = (last_instr handler).Llvm_mach.res in
if typeof handler_res <> Void then insert Lstore [|cast handler_res typ; tmp|] Nothing
else insert_simple (Lcomment "nothing to store in handler");
+ branch ("endcatch" ^ c);
+ label ("endcatch" ^ c);
if typ <> Void then insert Lload [|tmp|] res
| Iexit i, [||] ->
print_debug "Iexit";
View
2  src/asmcomp/llvm_mach.ml
@@ -97,7 +97,7 @@ let rec string_of_type = function
| Jump_buffer -> "%jump_buf_t"
| Void -> "void"
| Function(ret, args) -> string_of_type ret ^ " (" ^ String.concat ", " (List.map string_of_type args) ^ ")"
- | Any -> (*error "unable to infer type"*) "void"
+ | Any -> (*error "unable to infer type"*) "Any"
let deref typ = match typ with
| Address typ -> typ
View
9 src/asmcomp/llvm_selectgen.ml
@@ -93,6 +93,7 @@ let insert_debug seq desc dbg arg res 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
@@ -146,7 +147,7 @@ let rec caml_type expect = function
caml_type expect body
| Cassign(id,expr) ->
let typ = caml_type Any expr in
- add_type (translate_id id) typ;
+ add_type (translate_id id) (if typ = Any || typ = Void then addr_type else typ);
expect
| Ctuple exprs -> ignore (List.map (caml_type Any) exprs); Any
| Cop(Capply(typ, debug), exprs) -> ignore (List.map (caml_type Any) exprs); expect
@@ -241,7 +242,7 @@ let rec compile_instr seq instr =
let name = translate_id id in
let typ = get_type name in
let res_arg = compile_instr seq arg in
- let addr = alloca seq name typ in (* TODO check whether the variable already exists *)
+ let addr = assert (typ <> Void); alloca seq name typ in (* TODO check whether the variable already exists *)
store seq res_arg addr typ;
compile_instr seq body
| Cassign(id, expr) ->
@@ -249,7 +250,7 @@ let rec compile_instr seq instr =
let name = translate_id id in
let value = compile_instr seq expr in
let typ = get_type name in
- store seq value (Const(name, typ)) (deref typ);
+ store seq value (Reg(name, typ)) (deref typ);
Nothing
| Ctuple [] -> Nothing
| Ctuple exprs ->
@@ -424,7 +425,7 @@ let fundecl = function
let foo (x, typ) =
let typ = try Hashtbl.find types x with Not_found -> addr_type in
let typ = if is_int typ then typ else addr_type in
- store tmp_seq (Reg("param." ^ x, addr_type)) (alloca tmp_seq x typ) typ
+ store tmp_seq (Reg("param." ^ x, addr_type)) (assert (typ <> Void); alloca tmp_seq x typ) typ
in
List.iter foo args;
let body = compile_instr tmp_seq body in
View
2  src/asmcomp/llvmemit.ml
@@ -172,7 +172,7 @@ let emit_llvm instr =
let fundecl = function { fun_name = name; fun_args = args; fun_body = body } ->
let args = String.concat ", " (List.map string_of_reg args) in
emit_nl ("define " ^ calling_conv ^ " " ^ string_of_type addr_type ^
- " @" ^ name ^ "(" ^ args ^ ") nounwind gc \"ocaml\" {");
+ " @" ^ name ^ "(" ^ args ^ ") nounwind noinline gc \"ocaml\" {");
begin
try instr_iter emit_llvm body
with Llvm_error s ->
Please sign in to comment.
Something went wrong with that request. Please try again.