Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Fixed a couple of bugs that introduced when writing the new intermedi…

…ate representations

Also fixed the bug that caused floating point numbers to be printed with
a '.' as the last character, whether there was one already or not.
Instead the '.' is now only printed, when the fractional part is not 0.
  • Loading branch information...
commit 5af63f573642f42e2d200a31b5acaa79e4a05ec6 1 parent 054dce9
@colinbenner authored
View
57 src/asmcomp/llvm_aux.ml
@@ -10,63 +10,72 @@ let (++) x f = f x
(* Print an expression in the intermediate format using a syntax inspired by
* S-expressions *)
-let reg_to_string = function
+let reg_name = function
Const(value, _) -> value
| Reg(value, _) -> "%" ^ value
- | Nothing -> "Nothing"
+ | Nothing -> "null_register"
+
+let string_of_reg = function
+ Const(value, typ) -> string_of_type typ ^ " " ^ value
+ | Reg(value, typ) -> string_of_type typ ^ " %" ^ value
+ | Nothing -> "void null_register"
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
+ let res = instr.res in
+ let typ_str = string_of_reg 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
+ typ_str ^ string_of_binop op ^ " " ^ reg_name left ^ " " ^ reg_name 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
+ typ_str ^ string_of_comp typ op ^ " " ^ reg_name left ^ " " ^ reg_name 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, [||] -> string_of_reg 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, [|addr|] -> typ_str ^ "load " ^ string_of_reg 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 ^ ")"
+ "store " ^ string_of_reg value ^ " " ^ string_of_reg addr
| Istore, args -> error ("using store with " ^ string_of_int (Array.length args) ^ " arguments")
- | Ifptosi, [|value|] -> typ_str ^ "fptosi " ^ reg_to_string value
+ | Ifptosi, [|value|] -> typ_str ^ "fptosi " ^ reg_name value
| Ifptosi, args -> error ("using fptosi with " ^ string_of_int (Array.length args) ^ " arguments")
- | Isitofp, [|value|] -> typ_str ^ "sitofp " ^ reg_to_string value
+ | Isitofp, [|value|] -> typ_str ^ "sitofp " ^ reg_name 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, [|addr; offset|] -> typ_str ^ "getelementptr " ^ reg_name addr ^ " " ^ reg_name 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) ^ ")"
+ typ_str ^ "call " ^ reg_name fn ^ "(" ^ String.concat " " (List.map string_of_reg 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) ^ ")"
+ typ_str ^ "c-call " ^ reg_name fn ^ "(" ^ String.concat " " (List.map string_of_reg args) ^ ")"
| Iifthenelse(ifso, ifnot), [|cond|] ->
- "if " ^ reg_to_string cond ^ " then {\n" ^ to_string ifso ^ "} else {\n" ^ to_string ifnot ^ "}"
+ "if returning " ^ string_of_reg res ^ " (" ^ reg_name 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)) ^ "}"
+ "switch returning " ^ string_of_reg res ^ " (" ^ string_of_type typ ^ " " ^ reg_name value ^ ") {\ncase:\n" ^
+ String.concat "\ncase:\n" (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
+ "return " ^ string_of_type typ ^ " " ^ reg_name value
| Ireturn, args -> error ("using return with " ^ string_of_int (Array.length args) ^ " arguments")
- | Iloop instr, [||] -> "loop {\n" ^ to_string instr ^ "}"
+ | Iloop instr, [||] -> "loop returning " ^ string_of_reg res ^ " {\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
+ | Icatch(i, instr1, instr2), [||] ->
+ "catch returning " ^ string_of_reg res ^ " {\n" ^ to_string instr1 ^
+ "} exit with (" ^ string_of_int i ^ ") {\n" ^ to_string instr2
+ | Icatch(i, instr1, instr2), args -> error ("using catch with " ^ string_of_int (Array.length args) ^ " arguments")
+ | Iraise, [|exn|] -> "raise " ^ reg_name 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(try_instr, with_instr), [||] ->
+ "try returning " ^ string_of_reg res ^ " {\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")
View
4 src/asmcomp/llvm_aux.mli
@@ -4,7 +4,9 @@ val print_debug : string -> unit
val (++) : 'a -> ('a -> 'b) -> 'b
-val reg_to_string : Llvm_mach.ssa_reg -> string
+val reg_name : Llvm_mach.ssa_reg -> string
+
+val string_of_reg : Llvm_mach.ssa_reg -> string
(* Print the internal representation of an LLVM instruction in a notation
* inspired by S-expressions *)
View
184 src/asmcomp/llvm_linearize.ml
@@ -83,50 +83,43 @@ let register str typ = Llvm_mach.register str typ
let cast_reg value dest_typ reg =
let typ = typeof value in
- if typ = dest_typ then value else begin
- let cast op value = insert (Lcast op) [|value|] reg in
+ let cast op value reg = insert (Lcast op) [|value|] reg in
begin
match typ, dest_typ with
- | (Integer i, Integer j) ->
- if i < j then cast Zext value
- else cast Trunc value
- | (Integer i, Address _) ->
- if i == size_int * 8 then cast Inttoptr value
- else error ("could not cast integer of size " ^ string_of_int i ^ " to pointer")
- | (Integer i, Double) ->
- if i == size_float * 8 then cast Bitcast value
- else error ("could not cast integer of size " ^ string_of_int i ^ " to pointer")
- | (Integer _, Function(_,_)) -> cast Bitcast value
- | (Integer _, _) -> error ("invalid cast from integer to " ^ string_of_type dest_typ)
- | (Double, Integer i) ->
- if i == size_float * 8 then cast Bitcast value
- else error ("could not cast float to integer of size " ^ string_of_int i)
- | (Address _, Address _) -> cast Bitcast value
- | (Address _, Integer _) -> cast Ptrtoint value
- | (Double, Address _) -> error "invalid cast: Double -> Address _"
+ | (a, b) when a = b -> ()
+ | (Integer i, Integer j) when i < j -> cast Zext value reg
+ | (Integer i, Integer j) when i > j -> cast Trunc value reg
+ | (Integer i, Address _) when i = size_int * 8 -> cast Inttoptr value reg
+ | (Integer i, Double) when i = size_float * 8 -> cast Bitcast value reg
+ | (Integer _, Function(_,_)) -> cast Bitcast value reg
+ | (Double, Integer i) when i = size_float * 8 -> cast Bitcast value reg
+ | (Address _, Address _) -> cast Bitcast value 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 ^
- " to " ^ string_of_type dest_typ);
+ " to " ^ string_of_type dest_typ)
end;
- reg
- 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 = insert Lalloca [||] result; result
+let alloca result = assert (typeof result <> 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)
let getelemptr addr offset res = insert Lgetelemptr [|addr; offset|] res; res
let counter = ref 0
-let c () = counter := !counter + 1; string_of_int !counter
+let c () = counter := !counter + 1; "." ^ string_of_int !counter
+
+let exits = Hashtbl.create 10
let rec last_instr instr =
match instr.Llvm_mach.next.Llvm_mach.desc with
Iend -> instr
| _ -> last_instr instr.Llvm_mach.next
-(* TODO emit appropriate casts *)
let rec linear i =
let { Llvm_mach.desc = desc; Llvm_mach.next = next; Llvm_mach.arg = arg;
Llvm_mach.res = res; Llvm_mach.typ = typ; Llvm_mach.dbg = dbg } = i in
@@ -162,50 +155,73 @@ let rec linear i =
insert Lsitofp [|cast value int_type|] res
| Igetelementptr, [|addr; offset|] ->
print_debug "Igetelementptr";
- let tmp_reg = register "" typ in
- insert Lgetelemptr [|cast addr typ; cast offset int_type|] tmp_reg;
- ignore (cast_reg tmp_reg (typeof res) res)
+ if typeof res = typ then
+ insert Lgetelemptr [|cast addr typ; cast offset int_type|] res
+ else
+ let tmp_reg = register "" typ in
+ insert Lgetelemptr [|cast addr typ; cast offset int_type|] tmp_reg;
+ ignore (cast_reg tmp_reg (typeof res) res)
| Icall fn, args ->
print_debug "Icall";
- insert (Lcall (cast fn typ)) (Array.map (fun arg -> cast arg addr_type) args) res
+ let ret = match typ with Address(Function(ret,_)) -> ret | _ -> error "not a function" in
+ if typeof res = ret then
+ insert (Lcall (cast fn typ)) (Array.map (fun arg -> cast arg addr_type) args) res
+ else
+ let tmp_reg = register "" ret in
+ insert (Lcall (cast fn typ)) (Array.map (fun arg -> cast arg addr_type) args) tmp_reg;
+ ignore (cast_reg tmp_reg (typeof res) res)
| Iextcall fn, args ->
print_debug "Iextcall";
- insert (Lextcall (cast fn typ)) (Array.map (fun arg -> cast arg addr_type) args) res
+ let arg_typ = Array.of_list (match typ with Address(Function(_, args)) -> args | _ -> error "not a function") in
+ insert (Lextcall (cast fn typ)) (Array.mapi (fun i arg -> cast arg arg_typ.(i)) args) res
| Iifthenelse(ifso, ifnot), [|cond|] ->
print_debug "Iifthenelse";
assert (typeof cond = bit);
- let then_lbl = "then" ^ c() in
- let else_lbl = "else" ^ c() in
- let endif_lbl = "endif" ^ c() in
+ 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
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 [|(last_instr ifso).Llvm_mach.res; if_res|] Nothing;
+ else insert Lstore [|cast (last_instr ifso).Llvm_mach.res (typeof res); if_res|] Nothing;
branch endif_lbl;
label else_lbl;
linear ifnot;
if typeof (last_instr ifnot).Llvm_mach.res = Void then ()
- else insert Lstore [|(last_instr ifnot).Llvm_mach.res; if_res|] Nothing;
+ else insert Lstore [|cast (last_instr ifnot).Llvm_mach.res (typeof res); if_res|] Nothing;
branch endif_lbl;
label endif_lbl;
if typeof res = Void then ()
else insert Lload [|if_res|] res
| Iswitch(indexes, blocks), [|value|] ->
print_debug "Iswitch";
- ()
- (*
- let value_reg = register "" int_type in
- n := linear next !n;
- Array.iter (fun block -> n := linear block !n) blocks;
- n := instr_cons (Lswitch(default, labels)) (* TODO is this correct? *)
- [|value_reg|] Nothing !n;
- cast value value_reg !n
- *)
+ 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
+ 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;
+ insert_simple Lunreachable;
+ Array.iteri
+ (fun i block ->
+ label ("case" ^ string_of_int i ^ c);
+ linear block;
+ if typ <> Void then
+ 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);
+ ) blocks;
+ label ("endswitch" ^ c);
+ insert Lload [|switch_res|] res
| Ireturn, [|value|] ->
print_debug "Ireturn";
- insert Lreturn [|cast value typ|] Nothing
+ if Void = typ then insert Lreturn [|cast (Const("123456789", int_type)) addr_type|] Nothing
+ else insert Lreturn [|cast value typ|] Nothing
| Iunreachable, [||] ->
print_debug "Iunreachable";
insert_simple Lunreachable
@@ -215,28 +231,68 @@ let rec linear i =
| Iraise, [|exn|] ->
print_debug "Iraise";
insert Lstore [|cast exn 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;
+ insert (Lextcall (Const("@llvm.eh.sjlj.longjmp", Function(Void, [Address byte])))) [|cast (Const("@jmp_buf", Address Jump_buffer)) (Address byte)|] Nothing
| Itrywith(try_instr, with_instr), [||] ->
print_debug "Itrywith";
+ 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 (cast (Const("@jmp_buf", Address Jump_buffer)) (Address byte)) (register "temp_buf" 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;
- ignore (load (Const("@exn", addr_type)) res)
- | Icatch(i, instr1, instr2), [||] ->
+ let set_jmp_res = register "" (Integer 32) in
+ insert (Lextcall (Const("@llvm.eh.sjlj.setjmp", Function(Integer 32, [Address byte]))))
+ [|cast (Const("@jmp_buf", Address Jump_buffer)) (Address byte)|] set_jmp_res;
+ let tmp = if typ <> Void then alloca (register "try_with_tmp" (Address typ)) else Nothing in
+ let cond = register "" bit in
+ insert (Lcomp Comp_eq) [|set_jmp_res; Const("0", int_type)|] cond;
+ insert (Lcondbranch(try_lbl, with_lbl)) [|cond|] Nothing;
+
+ let try_res = (last_instr try_instr).Llvm_mach.res in
+ label try_lbl;
+ linear try_instr;
+ if typeof try_res <> Void then insert Lstore [|cast try_res typ; tmp|] Nothing;
+ branch cont_lbl;
+
+ let with_res = (last_instr with_instr).Llvm_mach.res in
+ label with_lbl;
+ linear with_instr;
+ if typeof with_res <> Void then insert Lstore [|cast with_res typ; tmp|] Nothing;
+ branch cont_lbl;
+
+ label cont_lbl;
+ if typ <> Void then insert Lload [|tmp|] res
+ | Icatch(i, body, handler), [||] ->
+ let c = c () in
+ Hashtbl.add exits i c;
print_debug "Icatch";
- ()
+ let tmp = if typ <> Void then alloca (register "catch_tmp" (Address typ)) else Nothing in
+ 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);
+ 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");
+ if typ <> Void then insert Lload [|tmp|] res
| Iexit i, [||] ->
print_debug "Iexit";
- ()
+ branch ("exit" ^ string_of_int i ^ Hashtbl.find exits i)
| Ialloc len, [||] ->
print_debug "Ialloc";
- let begin_lbl, collect_lbl, continue_lbl = "begin" ^ c(), "collect" ^ c(), "continue" ^ c() in
+ let counter = c () in
+ let begin_lbl, collect_lbl, continue_lbl = "begin" ^ counter, "collect" ^ counter, "continue" ^ counter in
insert_simple (Lcomment ("allocating " ^ string_of_int len ^ "*8 bytes"));
branch begin_lbl;
label begin_lbl;
let young_limit = load (Const("@caml_young_limit", Address addr_type)) (register "young_limit" addr_type) in
let young_ptr = load (Const("@caml_young_ptr", Address addr_type)) (register "young_ptr" addr_type) in
- let nyp = getelemptr young_ptr (Const(string_of_int (-len), int_type)) (register "" (typeof young_ptr)) in
+ let nyp = getelemptr young_ptr (Const(string_of_int (-len), int_type)) (*register "" (typeof young_ptr)*) res in
let cmp_res = register "enough_memory" bit in
insert (Lcomp Comp_lt) [|nyp; young_limit|] cmp_res;
insert (Lcondbranch(collect_lbl, continue_lbl)) [|cmp_res|] Nothing;
@@ -244,21 +300,23 @@ let rec linear i =
insert_simple (Lextcall (Const("@caml_call_gc", Function(Void, []))));
branch begin_lbl;
label continue_lbl;
- insert Lstore [|nyp; Const("@caml_young_ptr", Address addr_type)|] Nothing;
- insert (Lcast Bitcast) [|nyp|] res
+ insert Lstore [|nyp; Const("@caml_young_ptr", Address addr_type)|] Nothing
(*
- if len = 2 then Iccall(addr_type, Ivar("@caml_alloc1", Any), [])
- else if len = 3 then Iccall(addr_type, Ivar("@caml_alloc2", Any), [])
- else if len = 4 then Iccall(addr_type, Ivar("@caml_alloc3", Any), [])
- else Iccall(addr_type, Ivar("@caml_allocN", Any), [Icast(Inttoptr, Iconst(string_of_int (len-1), int_type), int_type, addr_type)])
- *)
+ let alloc, args =
+ match len with
+ 2 -> "@caml_alloc1", []
+ | 3 -> "@caml_alloc2", []
+ | 4 -> "@caml_alloc3", []
+ | _ -> "@caml_allocN", [addr_type]
+ in
+ insert (Lextcall (Const(alloc, Function(addr_type, args))))
+ (if len > 4 then [|Const("inttoptr(" ^ string_of_type int_type ^ " " ^ string_of_int (len-1) ^ " to " ^ string_of_type addr_type ^ ")", addr_type)|] else [||]) res
+ *)
+
(* TODO rewrite the code so it does not create a loop *)
(* TODO tell LLVM that the garbage collection is unlikely *)
| _, _ -> error ("unknown instruction:\n" ^ Llvm_aux.to_string i)
end; linear next end
-(*
- @@ Istore(addr_type, Icast(Igetelementptr(young_ptr, Iconst(offset, int_type)), typeof young_ptr, addr_type), Ialloca(new_young, addr_type))
- *)
let rec len instr =
match instr.desc with
View
20 src/asmcomp/llvm_mach.ml
@@ -1,8 +1,6 @@
exception Llvm_error of string
exception Cast_error of string
-type 'a error = Just of 'a | Error of string
-
type llvm_type =
Integer of int (* bitwidth *)
| Double
@@ -122,23 +120,11 @@ let string_of_binop = function
| Op_mulf -> "fmul"
| Op_divf -> "fdiv"
-let rec typeof = function
+let typeof = function
Const(_, typ) -> typ
| Reg(_, typ) -> typ
| Nothing -> Void
-let return x = Just x
-let fail x = Error x
-
-let (>>=) value fn = match value with
- | Just value -> fn value
- | Error s -> fail s
-
-let (+++) a b = match a, b with
- | Just a, Just b -> return (a,b)
- | Error e, _ -> fail e
- | _, Error e -> fail e
-
let reg_counter = ref 0
let reset_counter () = reg_counter := 0
let new_reg () = reg_counter := !reg_counter + 1; "." ^ string_of_int !reg_counter
@@ -156,7 +142,7 @@ let string_of_comp typ =
| Comp_gt -> "fcmp ogt"
| Comp_ge -> "fcmp oge"
end
- | Address _ -> begin
+ | Integer _ -> begin
function
| Comp_eq -> "icmp eq"
| Comp_ne -> "icmp ne"
@@ -165,7 +151,7 @@ let string_of_comp typ =
| Comp_gt -> "icmp sgt"
| Comp_ge -> "icmp sge"
end
- | Integer _ -> begin
+ | Address _ -> begin
function
| Comp_eq -> "icmp eq"
| Comp_ne -> "icmp ne"
View
8 src/asmcomp/llvm_mach.mli
@@ -1,8 +1,6 @@
exception Llvm_error of string
exception Cast_error of string
-type 'a error = Just of 'a | Error of string
-
type llvm_type =
Integer of int (* bitwidth *)
| Double
@@ -98,12 +96,6 @@ val deref : llvm_type -> llvm_type
(* Returns the type of result of the given instruction. *)
val typeof : ssa_reg -> llvm_type
-(* The usual monad functions for ['a error]. *)
-val return : 'a -> 'a error
-val fail : string -> 'a error
-val (>>=) : 'a error -> ('a -> 'b error) -> 'b error
-val (+++) : 'a error -> 'b error -> ('a * 'b) error
-
val reset_counter : unit -> unit
val register : string -> llvm_type -> ssa_reg
View
107 src/asmcomp/llvm_selectgen.ml
@@ -11,11 +11,6 @@ let c () = label_counter := !label_counter + 1; string_of_int !label_counter
let types = Hashtbl.create 10
-(*let vars = Hashtbl.create 10
-let is_def = Hashtbl.mem vars*)
-
-let exits = Hashtbl.create 10
-
(* {{{ *)
let translate_op = function
| Caddi -> Op_addi
@@ -123,10 +118,11 @@ let comp seq op left right typ = insert seq (Icomp op) [|left; right|] (register
let getelemptr seq addr offset typ =
insert seq Igetelementptr [|addr; offset|] (register "" (typeof addr)) typ
-
-let return seq value typ = insert seq Ireturn [|value|] Nothing typ
(* }}} *)
+let add_type name typ =
+ Hashtbl.add types name typ
+
(* very simple type inference algorithm used to determine which type an
* identifier has *)
(* {{{ *)
@@ -139,23 +135,23 @@ let rec caml_type expect = function
| Cconst_natpointer _ -> addr_type
| Cvar id ->
let name = translate_id id in
- if expect <> Any && not (Hashtbl.mem types name) then
- Hashtbl.add types name expect;
+ if not (Hashtbl.mem types name) then
+ add_type name (if expect = Any then addr_type else expect);
expect
| Clet(id,arg,body) ->
let name = translate_id id in
let typ = caml_type Any arg in
- if not (Hashtbl.mem types name) then begin
- Hashtbl.add types name (if typ = Any then addr_type else typ);
- end;
+ if not (Hashtbl.mem types name) then
+ add_type name (if typ = Any || typ = Void then addr_type else typ);
caml_type expect body
| Cassign(id,expr) ->
- Hashtbl.add types (translate_id id) (caml_type Any expr);
+ let typ = caml_type Any expr in
+ add_type (translate_id id) 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
| Cop(Cextcall(fn, typ, alloc, debug), exprs) -> ignore (List.map (caml_type Any) exprs); expect
- | Cop(Calloc, _) -> addr_type (* this is always the correct result type of an allocation *)
+ | Cop(Calloc, exprs) -> List.iter (fun x -> ignore (caml_type Any x)) exprs; addr_type (* this is always the correct result type of an allocation *)
| Cop(Cstore mem, [addr; value]) -> let typ = caml_type Any value in ignore (caml_type (Address typ) addr); Void
| Cop(Craise debug, args) -> ignore (List.map (caml_type Any) args); Void
| Cop(Ccheckbound debug, [arr; index]) -> ignore (caml_type int_type index); ignore (caml_type addr_type arr); Void
@@ -193,29 +189,32 @@ let rec caml_type expect = function
| 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) -> expect (* TODO figure out the real type *)
+ | 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
| Ccatch(i,ids,expr1,expr2) ->
ignore (caml_type expect expr1);
ignore (caml_type expect expr2);
expect
- | Cexit(i,exprs) -> Void (* TODO process exprs *)
+ | Cexit(i,exprs) -> List.iter (fun x -> ignore (caml_type expect x)) exprs; expect
| Ctrywith(try_expr, id, with_expr) ->
- ignore (caml_type expect try_expr);
- Hashtbl.add types (translate_id id) addr_type; (* the exception's type *)
- caml_type expect with_expr
+ let typ = caml_type expect try_expr in
+ add_type (translate_id id) addr_type; (* the exception's type *)
+ let with_typ = caml_type expect with_expr in
+ if typ = Void then with_typ else typ
(* }}} *)
let fabs = Const("@fabs", Address(Function(Double, [Double])))
let reverse_instrs tmp = let seq = ref dummy_instr in List.iter (insert_instr_debug seq) !tmp; !seq
-
let rec compile_instr seq instr =
match instr with
- | Cconst_int i -> Const(string_of_int i, int_type)
- | Cconst_natint i -> Const(Nativeint.to_string i, int_type)
- | Cconst_float f -> Const(f, Double)
+ | Cconst_int i ->
+ insert seq (Ibinop Op_addi) [|Const(string_of_int i, int_type); Const("0", int_type)|] (register "" int_type) int_type
+ | Cconst_natint i ->
+ insert seq (Ibinop Op_addi) [|Const(Nativeint.to_string i, int_type); Const("0", int_type)|] (register "" int_type) int_type
+ | Cconst_float f ->
+ insert seq (Ibinop Op_addf) [|Const(f, Double); Const("0.0", Double)|] (register "" Double) Double
| Cconst_symbol s ->
let typ =
try Hashtbl.find types (translate_symbol s)
@@ -226,11 +225,12 @@ let rec compile_instr seq instr =
| Function(_,_) -> ()
| _ -> add_const (translate_symbol s) (* TODO why not store the actual type of the symbol? *)
end;
- Const("@" ^ translate_symbol s, if is_addr typ then typ else Address typ)
+ insert seq Igetelementptr [|Const("@" ^ translate_symbol s, if is_addr typ then typ else Address typ); Const("0", int_type)|]
+ (register (translate_symbol s) int_type) addr_type
| Cconst_pointer i ->
- Const("inttoptr(" ^ string_of_type int_type ^ " " ^ string_of_int i ^ " to " ^ string_of_type addr_type ^ ")", addr_type)
+ insert seq Igetelementptr [|Const(string_of_int i, int_type); Const("0", int_type)|] (register "" addr_type) addr_type
| Cconst_natpointer i ->
- Const("inttoptr(" ^ string_of_type int_type ^ " " ^ Nativeint.to_string i ^ " to " ^ string_of_type addr_type ^ ")", addr_type)
+ insert seq Igetelementptr [|Const(Nativeint.to_string i, int_type); Const("0", int_type)|] (register "" addr_type) addr_type
| Cvar id ->
print_debug "Cvar";
let name = translate_id id in
@@ -261,33 +261,34 @@ let rec compile_instr seq instr =
let arg_types = Array.to_list (Array.make (List.length args) addr_type) in
let typ = Address(Function(addr_type, arg_types)) in
add_function (addr_type, calling_conv, translate_symbol s, arg_types);
- Hashtbl.add types (translate_symbol s) typ;
- call seq (compile_instr seq symb) (Array.of_list args) "call_res" typ
+ add_type (translate_symbol s) typ;
+ call seq (compile_instr seq symb) (Array.of_list args) "call" typ
| Cop(Capply(typ, debug), clos :: args) ->
print_debug "Capply closure...";
let args = List.map (compile_instr seq) args in
let fn_type = Address(Function(addr_type, List.map (fun _ -> addr_type) args)) in
let fn = compile_instr seq clos in
- call seq fn (Array.of_list args) "call_res" fn_type
+ call seq fn (Array.of_list args) "call" fn_type
| Cop(Capply(_,_), []) -> error "no function specified"
| Cop(Cextcall(fn, typ, alloc, debug), exprs) ->
print_debug "Cextcall";
let args = List.map (compile_instr seq) exprs in
add_function (translate_machtype typ, "ccc", fn, args);
let fn_type = Address(Function(translate_machtype typ, List.map (fun _ -> addr_type) args)) in
- Hashtbl.add types fn fn_type;
- extcall seq (Const("@" ^ fn, fn_type)) (Array.of_list args) "extcall_res" fn_type
+ add_type fn fn_type;
+ extcall seq (Const("@" ^ fn, fn_type)) (Array.of_list args) "extcall" fn_type
| 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" (Address byte) 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 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
num := !num + 1;
- store seq elem elemptr (typeof elem)
+ ignore (insert seq Istore [|elem; elemptr|] ptr (typeof elem))
+ (*store seq elem elemptr (typeof elem)*)
in
List.iter emit_arg args;
header
@@ -331,34 +332,29 @@ let rec compile_instr seq instr =
let blocks = Array.map (fun x -> let seq = ref [] in ignore (compile_instr seq x); reverse_instrs seq) exprs in
let typ = try typeof (List.find (fun x -> typeof (last_instr x).res <> Void) (Array.to_list blocks)).res with Not_found -> Void in
add_const "caml_exn_Match_failure";
- let default =
- instr_cons Iraise [|Const("@caml_exn_Match_failure", addr_type)|] Nothing Void
- (instr_cons Iunreachable [||] Nothing Void dummy_instr)
- in
- let blocks = Array.append [|default|] blocks in
- insert seq (Iswitch(indices, blocks)) [|value|] (register "switch_res" typ) typ
+ insert seq (Iswitch(indices, blocks)) [|value|] (register "switch" typ) typ
| Cloop expr ->
print_debug "Cloop";
let seq = ref [] in
ignore (compile_instr seq expr);
insert seq (Iloop (reverse_instrs seq)) [||] Nothing Void
- | Ccatch(i, ids, expr1, expr2) ->
+ | Ccatch(i, ids, body, handler) ->
print_debug "Ccatch";
- let c = c () in
let fn id =
let id = translate_id id in
- Hashtbl.add types id addr_type;
+ add_type id addr_type;
ignore (alloca seq id addr_type)
in
List.iter fn ids;
- Hashtbl.add exits i c;
- Hashtbl.remove exits i;
- comment seq "catching...";
- let instr1 = ref [] in
- let instr2 = ref [] in
- ignore (compile_instr instr1 expr1);
- ignore (compile_instr instr2 expr2);
- insert seq (Icatch(i, reverse_instrs instr1, reverse_instrs instr2)) [||] Nothing Void
+ let instr_body = ref [] in
+ let instr_handler = ref [] in
+ ignore (compile_instr instr_body body);
+ ignore (compile_instr instr_handler handler);
+ let body_instrs = reverse_instrs instr_body in
+ let handler_instrs = reverse_instrs instr_handler in
+ let typ = typeof (last_instr body_instrs).res in
+ let typ = if typ = Void then typeof (last_instr handler_instrs).res else typ in
+ insert seq (Icatch(i, body_instrs, handler_instrs)) [||] (if typ = Void then Nothing else register "catch_foo" typ) typ
| Cexit(i, exprs) ->
print_debug "Cexit";
List.iter (fun x -> ignore (compile_instr seq x)) exprs;
@@ -369,9 +365,13 @@ let rec compile_instr seq instr =
let with_seq = ref [] in
(* TODO figure out what to do with id *)
ignore (compile_instr try_seq try_expr);
- ignore (load with_seq (Const("@exn", Address addr_type)) "exn" addr_type);
+ ignore (insert with_seq Iload [|Const("@exn", Address addr_type)|] (Const("%" ^ translate_id id, addr_type)) addr_type);
ignore (compile_instr with_seq with_expr);
- insert seq (Itrywith(reverse_instrs try_seq, reverse_instrs with_seq)) [||] Nothing Void
+ let try_instrs = reverse_instrs try_seq in
+ let with_instrs = reverse_instrs with_seq in
+ let typ = typeof (last_instr try_instrs).res in
+ let typ = if typ = Void then typeof (last_instr with_instrs).res else typ in
+ insert seq (Itrywith(try_instrs, with_instrs)) [||] (if typ = Void then Nothing else register "try_with" typ) typ
and compile_operation seq op = function
| [l;r] -> begin
@@ -428,7 +428,8 @@ let fundecl = function
in
List.iter foo args;
let body = compile_instr tmp_seq body in
- ignore (return tmp_seq body (if typeof body <> Void then addr_type else Void));
+
+ ignore (insert tmp_seq Ireturn [|body|] Nothing (if typeof body <> Void then addr_type else Void));
let argument_list = List.map (fun (id, _) -> "param." ^ id, addr_type) in
List.iter (insert_instr_debug instr_seq) !tmp_seq;
{name = translate_symbol name; args = argument_list args; body = !instr_seq}
View
131 src/asmcomp/llvmemit.ml
@@ -60,27 +60,6 @@ let translate_comp typ =
end
| _ -> error "no comparison operations are defined for this type"
-let emit_label lbl = emit_nl (lbl ^ ":")
-let emit_instr instr = emit_nl ("\t" ^ instr)
-
-let emit_op reg op typ args =
- emit_instr (reg_to_string reg ^ " = " ^ op ^ " " ^ string_of_type typ ^ " " ^
- String.concat ", " (List.map reg_to_string args))
-
-let arg_list args =
- String.concat ", " (List.map (fun x -> string_of_type (typeof x) ^ " " ^ reg_to_string x) args)
-
-let emit_cast reg op value typ =
- emit_instr (reg_to_string reg ^ " = " ^ op ^ " " ^ string_of_type (typeof value) ^
- " " ^ reg_to_string 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
-
-let print_reg reg = string_of_type (typeof reg) ^ " " ^ reg_to_string reg
-
let print_array f arr =
String.concat ", " (Array.to_list (Array.map f arr))
@@ -88,17 +67,17 @@ let to_string instr = begin
let res = instr.res in
match instr.desc with
Lend -> print_string "end"
- | Lop op -> print_string (print_reg res ^ " = op " ^ string_of_binop op)
- | Lcomp op -> print_string (print_reg res ^ " = comp " ^ string_of_comp (typeof instr.arg.(0)) op)
- | Lcast op -> print_string (print_reg res ^ " = cast " ^ string_of_cast op)
- | Lalloca -> print_string (print_reg res ^ " = alloca " ^ string_of_type (try deref (typeof res) with Cast_error s -> error ("dereferencing alloca argument " ^ reg_to_string res ^ " failed")))
- | Lload -> print_string (print_reg res ^ " = load")
+ | Lop op -> print_string (string_of_reg res ^ " = op " ^ string_of_binop op)
+ | Lcomp op -> print_string (string_of_reg res ^ " = comp " ^ string_of_comp (typeof instr.arg.(0)) op)
+ | Lcast op -> print_string (string_of_reg res ^ " = cast " ^ string_of_cast op)
+ | Lalloca -> print_string (string_of_reg res ^ " = alloca " ^ string_of_type (try deref (typeof res) with Cast_error s -> error ("dereferencing alloca argument " ^ reg_name res ^ " failed")))
+ | Lload -> print_string (string_of_reg res ^ " = load")
| Lstore -> print_string ("store ")
- | Lgetelemptr -> print_string (print_reg res ^ " = getelemptr")
- | Lfptosi -> print_string (print_reg res ^ " = fptosi")
- | Lsitofp -> print_string (print_reg res ^ " = sitofp")
- | Lcall fn -> print_string (print_reg res ^ " = call " ^ print_reg fn)
- | Lextcall fn -> print_string (print_reg res ^ " = extcall " ^ print_reg fn)
+ | Lgetelemptr -> print_string (string_of_reg res ^ " = getelemptr")
+ | Lfptosi -> print_string (string_of_reg res ^ " = fptosi")
+ | Lsitofp -> print_string (string_of_reg res ^ " = sitofp")
+ | Lcall fn -> print_string (string_of_reg res ^ " = call " ^ string_of_reg fn)
+ | Lextcall fn -> print_string (string_of_reg res ^ " = extcall " ^ string_of_reg fn)
| Llabel name -> print_string ("label " ^ name)
| Lbranch name -> print_string ("branch " ^ name)
| Lcondbranch(ifso, ifnot) -> print_string ("branch " ^ ifso ^ ", " ^ ifnot)
@@ -107,13 +86,31 @@ let to_string instr = begin
| Lunreachable -> print_string ("unreachable")
| Lcomment _ -> print_string ("comment")
end;
- print_endline (" (" ^ print_array print_reg instr.arg ^ ")")
+ print_endline (" (" ^ print_array string_of_reg instr.arg ^ ")")
+
+let emit_label lbl = emit_nl (lbl ^ ":")
+let emit_instr instr = emit_nl ("\t" ^ instr)
+
+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 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
let emit_call res cc fn args =
- let reg_type reg = string_of_type (typeof reg) in
- let fn = " " ^ reg_to_string fn ^ " (" ^ print_array (fun x -> reg_type x ^ " " ^ reg_to_string x) args ^ ") nounwind" in
- emit_instr ((if res <> Nothing then reg_to_string res ^ " = " else "") ^ "call " ^
- cc ^ " " ^ (if res <> Nothing then reg_type res else "void") ^ fn)
+ 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
@@ -126,13 +123,13 @@ let emit_llvm instr =
| Lcast op, [|value|], Reg(_, typ) ->
emit_cast res (string_of_cast op) value typ
| Lalloca, [||], Reg(_, typ) ->
- emit_instr (reg_to_string 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]
+ 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]
| Lstore, [|value; addr|], Nothing ->
emit_instr ("store " ^ arg_list [value; addr])
| Lgetelemptr, [|addr; offset|], Reg(_, typ) ->
- emit_instr (reg_to_string res ^ " = getelementptr " ^ arg_list [addr; offset])
+ 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
| Lcall fn, args, _ -> emit_call res calling_conv fn args
@@ -140,48 +137,40 @@ let emit_llvm instr =
| Llabel name, [||], Nothing -> emit_label name
| Lbranch lbl, [||], Nothing -> emit_instr ("br label %" ^ lbl)
| Lcondbranch(then_label, else_label), [|cond|], Nothing ->
- emit_instr ("br i1 " ^ reg_to_string cond ^ ", label %" ^ then_label ^ ", label %" ^ else_label)
+ emit_instr ("br i1 " ^ reg_name cond ^ ", label %" ^ then_label ^ ", label %" ^ else_label)
| Lswitch(default, lbls), [|value|], Nothing ->
let typ = string_of_type (typeof value) in
let fn i lbl = typ ^ " " ^ string_of_int i ^ ", label %" ^ lbl in
- emit_instr ("switch " ^ typ ^ " " ^ reg_to_string value ^ ", label %" ^
- default ^ " [\n" ^
+ emit_instr ("switch " ^ typ ^ " " ^ reg_name value ^ ", label %" ^
+ default ^ " [\n\t\t" ^
String.concat "\n\t\t" (Array.to_list (Array.mapi fn lbls)) ^
- "\t]")
+ "\n\t]")
| Lreturn, [||], Nothing -> emit_instr "ret void"
| Lreturn, [|value|], Nothing ->
- emit_instr ("ret " ^ string_of_type (typeof value) ^ " " ^ reg_to_string value)
+ emit_instr ("ret " ^ string_of_reg value)
| Lunreachable, [||], Nothing -> emit_instr "unreachable"
| Lcomment s, [||], Nothing -> emit_instr ("; " ^ s)
- | _, _, _ -> error "unknown instruction"
- end
-(*
-and call cc ret fn args =
- let args =
- let fn x =
- match emit_llvm x with
- | Just s -> string_of_type (typeof x) ^ " " ^ s
- | Error s -> error ("failed to emit code for arguments of call:\n" ^ s)
- in
- String.concat ", " (List.map fn args)
- in
- let f fn =
- if ret == Void then begin
- emit_instr ("call " ^ cc ^ " " ^ string_of_type ret ^ " " ^ fn ^ "(" ^ args ^ ") nounwind");
- fail "void function does not return anything";
- end else begin
- let result = "%result" ^ c() in
- emit_instr (result ^ " = call " ^ cc ^ " " ^ string_of_type ret ^ " " ^ fn ^ "(" ^ args ^ ") nounwind");
- return result
- end
- in
- emit_llvm fn >>= f
- *)
+ | Lop op, _, _ -> error ("binop " ^ string_of_binop op ^ " used with " ^ string_of_int (Array.length arg) ^ " arguments")
+ | Lcomp op, _, _ -> error ("comp " ^ string_of_comp (typeof arg.(0)) op ^ " used with " ^ string_of_int (Array.length arg) ^ " arguments")
+ | Lcast op, _, _ -> error ("cast " ^ string_of_cast op ^ " used with " ^ string_of_int (Array.length arg) ^ " arguments")
+ | Lalloca, _, _ -> error ("alloca with " ^ string_of_int (Array.length arg) ^ " arguments")
+ | Lload, _, _ -> error ("load with " ^ string_of_int (Array.length arg) ^ " arguments")
+ | Lstore, _, _ -> error ("store with " ^ string_of_int (Array.length arg) ^ " arguments")
+ | Lgetelemptr, _, _ -> error ("getelemptr with " ^ string_of_int (Array.length arg) ^ " arguments")
+ | Lfptosi, _, _ -> error ("fptosi with " ^ string_of_int (Array.length arg) ^ " arguments")
+ | Lsitofp, _, _ -> error ("sitofp with " ^ string_of_int (Array.length arg) ^ " arguments")
+ | Llabel name, _, _ -> error ("label with " ^ string_of_int (Array.length arg) ^ " arguments")
+ | Lbranch lbl, _, _ -> error ("branch with " ^ string_of_int (Array.length arg) ^ " arguments")
+ | Lcondbranch(then_label, else_label), _, _ -> error ("condbranch with " ^ string_of_int (Array.length arg) ^ " arguments")
+ | Lswitch(default, lbls), _, _ -> error ("switch with " ^ string_of_int (Array.length arg) ^ " arguments")
+ | Lreturn, _, _ -> error ("return with " ^ string_of_int (Array.length arg) ^ " arguments")
+ | Lunreachable, _, _ -> error ("unreachable with " ^ string_of_int (Array.length arg) ^ " arguments")
+ | Lcomment s, _, _ -> error ("comment with " ^ string_of_int (Array.length arg) ^ " arguments")
+ end
let fundecl = function { fun_name = name; fun_args = args; fun_body = body } ->
- let fn reg = string_of_type (typeof reg) ^ " " ^ reg_to_string reg in
- let args = String.concat ", " (List.map fn args) in
+ 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\" {");
begin
Please sign in to comment.
Something went wrong with that request. Please try again.