Skip to content

Commit

Permalink
Some changes for debugging the interface to the garbage collector
Browse files Browse the repository at this point in the history 
The type inference on the Cmm code now assumes every let-binding can
contain a pointer.  Every argument of function calls and alloc
instructions is computed, saved on the stack.  They are loaded as soon
as they are needed to call the function/store the values.  It seemed
like this might fix the GC-problem, but it did not.  During garbage
collection some strange bugs occur...
  • Loading branch information
@colinbenner
colinbenner committed Mar 15, 2012
1 parent 749463a commit afd2373
Show file tree
Hide file tree
Showing 10 changed files with 280 additions and 242 deletions.
12 changes: 12 additions & 0 deletions src/asmcomp/aux.ml
View file
@@ -1,3 +1,5 @@
open Reg

(* (*
val debug : bool ref val debug : bool ref
(* Print a debugging message to stdout *) (* Print a debugging message to stdout *)
Expand Down Expand Up @@ -33,3 +35,13 @@ let translate_symbol s =
| _ -> result := !result ^ Printf.sprintf "$%02x" (Char.code c) | _ -> result := !result ^ Printf.sprintf "$%02x" (Char.code c)
done; done;
!result !result

let const value typ = Const(value, typ);;
let global name typ = const ("@" ^ name) typ;;

let caml_young_ptr = const "@caml_young_ptr" (Address addr_type)
let caml_young_limit = const "@caml_young_limit" (Address addr_type)
let setjmp = global "setjmp" (function_type (Integer 32) [Address byte])
let longjmp = global "longjmp" (function_type Void [Address byte; Integer 32])
let caml_exn = global "caml_exn" (Address addr_type)
let jmp_buf = global "caml_jump_buffer" (Address Jump_buffer)
7 changes: 2 additions & 5 deletions src/asmcomp/emit_common.ml
View file
Expand Up @@ -70,7 +70,7 @@ let emit_llvm instr =
| Lcast op, [|value|], Reg(_, typ) -> | Lcast op, [|value|], Reg(_, typ) ->
emit_cast res (string_of_cast op) value typ emit_cast res (string_of_cast op) value typ
| Lalloca, [||], Reg(_, 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")) emit_instr (reg_name res ^ " = alloca " ^ string_of_type (deref typ))
| Lload, [|addr|], Reg(_, _) -> emit_op res "load" (typeof addr) [addr] | Lload, [|addr|], Reg(_, _) -> emit_op res "load" (typeof addr) [addr]
| Lstore, [|value; addr|], Nothing -> | Lstore, [|value; addr|], Nothing ->
emit_instr ("store " ^ arg_list [value; addr]) emit_instr ("store " ^ arg_list [value; addr])
Expand All @@ -92,8 +92,7 @@ let emit_llvm instr =
String.concat "\n\t\t" (Array.to_list (Array.mapi fn lbls)) ^ String.concat "\n\t\t" (Array.to_list (Array.mapi fn lbls)) ^
"\n\t]") "\n\t]")
| Lreturn, [||], Nothing -> emit_instr "ret void" | Lreturn, [||], Nothing -> emit_instr "ret void"
| Lreturn, [|value|], Nothing -> | Lreturn, [|value|], Nothing -> emit_instr ("ret " ^ string_of_reg value)
emit_instr ("ret " ^ string_of_reg value)
| Lunreachable, [||], Nothing -> emit_instr "unreachable" | Lunreachable, [||], Nothing -> emit_instr "unreachable"
| Lcomment s, [||], Nothing -> emit_instr ("; " ^ s) | Lcomment s, [||], Nothing -> emit_instr ("; " ^ s)


Expand Down Expand Up @@ -171,8 +170,6 @@ let functions : (string * string * string * string list) list ref = ref []


let local_functions = ref [] let local_functions = ref []


let module_asm () = emit_string "module asm \""

let add_const str = let add_const str =
if List.exists (fun x -> String.compare x str == 0) !constants if List.exists (fun x -> String.compare x str == 0) !constants
then () then ()
Expand Down
126 changes: 56 additions & 70 deletions src/asmcomp/linearize.ml
View file
Expand Up @@ -7,7 +7,7 @@ let error s = error ("Llvm_linearize: " ^ s)


type label = string type label = string


type cast = Zext | Trunc | Bitcast | Inttoptr | Ptrtoint type cast = Zext | Sext | Trunc | Bitcast | Inttoptr | Ptrtoint


type instruction = type instruction =
{ mutable desc: instruction_desc; { mutable desc: instruction_desc;
Expand Down Expand Up @@ -47,6 +47,7 @@ let rec end_instr =


let string_of_cast = function let string_of_cast = function
Zext -> "zext" Zext -> "zext"
| Sext -> "sext"
| Trunc -> "trunc" | Trunc -> "trunc"
| Bitcast -> "bitcast" | Bitcast -> "bitcast"
| Inttoptr -> "inttoptr" | Inttoptr -> "inttoptr"
Expand Down Expand Up @@ -120,8 +121,8 @@ let alloca result =
end else begin end else begin
Hashtbl.add allocas (reg_name result) {desc = Lalloca; next = end_instr; arg = [||]; res = result; dbg = Debuginfo.none}; Hashtbl.add allocas (reg_name result) {desc = Lalloca; next = end_instr; arg = [||]; res = result; dbg = Debuginfo.none};
if is_addr (deref (typeof result)) then if is_addr (deref (typeof result)) then
insert (Lextcall (Const("@llvm.gcroot", Function(Void, [Address (Address byte); Address byte])))) insert (Lextcall (global "llvm.gcroot" (function_type Void [Address (Address byte); Address byte])))
[|cast result (Address (Address byte)); Const("null", Address byte)|] Nothing; [|cast result (Address (Address byte)); const "null" (Address byte)|] Nothing;
result result
end end


Expand All @@ -142,8 +143,7 @@ let rec last_instr instr =
Iend -> instr Iend -> instr
| _ -> last_instr instr.Mach.next | _ -> last_instr instr.Mach.next


let caml_young_ptr = Const("@caml_young_ptr", Address addr_type) let block_res instr = (last_instr instr).Mach.res
let caml_young_limit = Const("@caml_young_limit", Address addr_type)


let current_function = ref "" let current_function = ref ""


Expand All @@ -154,156 +154,140 @@ let rec linear i =
match desc, arg with match desc, arg with
Iend, [||] -> error "this case should never be reached" Iend, [||] -> error "this case should never be reached"
| Ibinop op, [|left; right|] -> | Ibinop op, [|left; right|] ->
print_debug "Ibinop";
insert (Lop op) [|cast left typ; cast right typ|] res insert (Lop op) [|cast left typ; cast right typ|] res
| Icomp op, [|left; right|] -> | Icomp op, [|left; right|] ->
print_debug "Icomp";
insert (Lcomp op) [|cast left typ; cast right typ|] res insert (Lcomp op) [|cast left typ; cast right typ|] res
| Ialloca, [||] -> | Ialloca, [||] -> ignore (alloca res)
print_debug "Ialloca"; | Iload, [|addr|] -> ignore (load (cast addr (Address typ)) res)
ignore (alloca res)
| Iload, [|addr|] ->
print_debug "Iload";
ignore (load (cast addr (Address typ)) res)
| Istore, [|value; addr|] -> | Istore, [|value; addr|] ->
print_debug "Istore";
insert Lstore [|cast value typ; cast addr (Address typ)|] Nothing insert Lstore [|cast value typ; cast addr (Address typ)|] Nothing
| Ifptosi, [|value|] -> | Ifptosi, [|value|] -> insert Lfptosi [|cast value Double|] res
print_debug "Ifptosi"; | Isitofp, [|value|] -> insert Lsitofp [|cast value int_type|] res
insert Lfptosi [|cast value Double|] res | Izext, [|value|] -> insert (Lcast Zext) [|(*no cast necessary*)value|] res
| Isitofp, [|value|] -> | Isext, [|value|] -> insert (Lcast Sext) [|(*no cast necessary*)value|] res
print_debug "Isitofp";
insert Lsitofp [|cast value int_type|] res
| Igetelementptr, [|addr; offset|] -> | Igetelementptr, [|addr; offset|] ->
print_debug "Igetelementptr";
if typeof res = typ then if typeof res = typ then
insert Lgetelemptr [|cast addr typ; cast offset int_type|] res insert Lgetelemptr [|cast addr typ; cast offset int_type|] res
else else
let tmp_reg = new_reg "" typ in let tmp_reg = new_reg "" typ in
insert Lgetelemptr [|cast addr typ; cast offset int_type|] tmp_reg; insert Lgetelemptr [|cast addr typ; cast offset int_type|] tmp_reg;
ignore (cast_reg tmp_reg (typeof res) res) ignore (cast_reg tmp_reg (typeof res) res)
| Icall fn, args -> | Icall fn, args ->
print_debug "Icall"; let ret = ret_type typ in
let ret = match typ with Address(Function(ret,_)) -> ret | _ -> error "not a function" in
if typeof res = ret then if typeof res = ret then
insert (Lcall (cast fn typ)) (Array.map (fun arg -> cast arg addr_type) args) res insert (Lcall (cast fn typ)) (Array.map (fun arg -> cast arg addr_type) args) res
else else
let tmp_reg = new_reg "" ret in let tmp_reg = new_reg "" ret in
insert (Lcall (cast fn typ)) (Array.map (fun arg -> cast arg addr_type) args) tmp_reg; insert (Lcall (cast fn typ)) (Array.map (fun arg -> cast arg addr_type) args) tmp_reg;
ignore (cast_reg tmp_reg (typeof res) res) ignore (cast_reg tmp_reg (typeof res) res)
| Iextcall(fn, alloc), args -> | Iextcall(fn, alloc), args ->
print_debug "Iextcall"; let arg_types = Array.of_list (arg_types typ) in
let arg_typ = Array.of_list (match typ with Address(Function(_, args)) -> args | _ -> error "not a function") in let insert_call () =
insert (Lextcall (cast fn typ)) (Array.mapi (fun i arg -> cast arg arg_types.(i)) args) res
in
if alloc then if alloc then
let c = c () in let c = c () in
let dummy_lbl, ret_lbl = "dummy" ^ c, "ret" ^ c in let dummy_lbl, ret_lbl = "dummy" ^ c, "ret" ^ c in
insert Lstore [|Const("blockaddress(" ^ !current_function ^ ", %" ^ ret_lbl ^ ")", Address (Integer 8)); insert Lstore [|const ("blockaddress(" ^ !current_function ^ ", %" ^ ret_lbl ^ ")") (Address byte);
Const("@caml_last_return_address", Address(Address (Integer 8)))|] Nothing; global "caml_last_return_address" (Address(Address byte))|] Nothing;
let stackpointer = new_reg "sp" (Address byte) in let stackpointer = new_reg "sp" (Address byte) in
insert (Lextcall (Const("@llvm.stacksave", Function(byte, [])))) [||] stackpointer; insert (Lextcall (global "llvm.stacksave" (function_type byte []))) [||] stackpointer;
insert Lstore [|stackpointer; Const("@caml_bottom_of_stack", Address (Address byte))|] Nothing; insert Lstore [|stackpointer; global "caml_bottom_of_stack" (Address (Address byte))|] Nothing;
insert (Lextcall (cast fn typ)) (Array.mapi (fun i arg -> cast arg arg_typ.(i)) args) res; insert_call ();
branch ret_lbl; branch ret_lbl;
label ret_lbl label ret_lbl
else else
insert (Lextcall (cast fn typ)) (Array.mapi (fun i arg -> cast arg arg_typ.(i)) args) res insert_call ()
| Iifthenelse(ifso, ifnot), [|cond|] -> | Iifthenelse(ifso, ifnot), [|cond|] ->
print_debug "Iifthenelse";
assert (typeof cond = bit); assert (typeof cond = bit);
let counter = c () in let counter = c () in
let then_lbl, else_lbl, endif_lbl = "then" ^ counter, "else" ^ counter, "endif" ^ counter 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 (assert (typeof res <> Void); alloca (new_reg "if_tmp" (Address (typeof res)))) in let if_res = if typeof res = Void then Nothing else (assert (typeof res <> Void); alloca (new_reg "if_tmp" (Address (typeof res)))) in
insert (Lcondbranch(then_lbl, else_lbl)) [|cond|] Nothing; insert (Lcondbranch(then_lbl, else_lbl)) [|cond|] Nothing;

label then_lbl; label then_lbl;
linear ifso; linear ifso;
if typeof (last_instr ifso).Mach.res <> Void let ifso_res = block_res ifso in
then insert Lstore [|cast (last_instr ifso).Mach.res (typeof res); cast if_res (Address (typeof res))|] Nothing; if typeof ifso_res <> Void
then insert Lstore [|cast (block_res ifso) (typeof res); cast if_res (Address (typeof res))|] Nothing;
branch endif_lbl; branch endif_lbl;

label else_lbl; label else_lbl;
linear ifnot; linear ifnot;
if typeof (last_instr ifnot).Mach.res <> Void let ifnot_res = block_res ifnot in
then insert Lstore [|cast (last_instr ifnot).Mach.res (typeof res); cast if_res (Address (typeof res))|] Nothing; if typeof ifnot_res <> Void
then insert Lstore [|cast ifnot_res (typeof res); cast if_res (Address (typeof res))|] Nothing;
branch endif_lbl; branch endif_lbl;

label endif_lbl; label endif_lbl;
if typeof res <> Void then insert Lload [|cast if_res (Address (typeof res))|] res if typeof res <> Void then insert Lload [|cast if_res (Address (typeof res))|] res
| Iswitch(indexes, blocks), [|value|] -> | Iswitch(indexes, blocks), [|value|] ->
print_debug "Iswitch";
let c = c () in let c = c () in
let labels = Array.map (fun i -> "case" ^ string_of_int i ^ c) indexes in let labels = Array.map (fun i -> "case" ^ string_of_int i ^ c) indexes in
let switch_res = alloca (new_reg "" (assert (typ <> Address Void); if typ <> Void then Address typ else addr_type)) in let switch_res = alloca (new_reg "" (assert (typ <> Address Void); if typ <> Void then Address typ else addr_type)) in
insert (Lswitch("default" ^ c, labels)) [|cast value int_type|] Nothing; insert (Lswitch("default" ^ c, labels)) [|cast value int_type|] Nothing;
label ("default" ^ c); label ("default" ^ c);
insert Lstore [|Const("@caml_exn_Match_failure", addr_type); Const("@caml_exn", Address addr_type)|] Nothing; insert Lstore [|global "caml_exn_Match_failure" addr_type; caml_exn|] Nothing;
(* insert (Lextcall (Const("@llvm.eh.sjlj.longjmp", Function(Void, [Address byte])))) (* insert (Lextcall (Const("@llvm.eh.sjlj.longjmp", Function(Void, [Address byte]))))
[|cast (Const("@caml_jump_buffer", Address Jump_buffer)) (Address byte)|] Nothing; [|cast jmp_buf (Address byte)|] Nothing;
*) *)
insert (Lextcall (Const("@longjmp", Function(Void, [Address byte; Integer 32])))) insert (Lextcall longjmp) [|cast jmp_buf (Address byte); const "1" (Integer 32)|] Nothing;
[|cast (Const("@caml_jump_buffer", Address Jump_buffer)) (Address byte); Const("1", Integer 32)|] Nothing;
insert_simple Lunreachable; insert_simple Lunreachable;
Array.iteri Array.iteri
(fun i block -> (fun i block ->
label ("case" ^ string_of_int i ^ c); label ("case" ^ string_of_int i ^ c);
linear block; linear block;
if typ <> Void then begin if typ <> Void then begin
let res = (last_instr block).Mach.res in let res = block_res block in
if typeof res <> Void then if typeof res <> Void then
insert Lstore [|cast (last_instr block).Mach.res typ; switch_res|] Nothing insert Lstore [|cast res typ; switch_res|] Nothing
end; end;
branch ("endswitch" ^ c) branch ("endswitch" ^ c))
) blocks; blocks;
label ("endswitch" ^ c); label ("endswitch" ^ c);
insert Lload [|switch_res|] res insert Lload [|switch_res|] res
| Ireturn, [|value|] -> | Ireturn, [|value|] ->
print_debug "Ireturn"; if Void = typ then insert Lreturn [|const "undef" addr_type|] Nothing
if Void = typ then insert Lreturn [|Const("undef", addr_type)|] Nothing
else insert Lreturn [|cast value typ|] Nothing else insert Lreturn [|cast value typ|] Nothing
| Iunreachable, [||] -> | Iunreachable, [||] ->
print_debug "Iunreachable";
insert_simple Lunreachable insert_simple Lunreachable
| Icomment s, [||] -> | Icomment s, [||] ->
print_debug "Icomment";
insert_simple (Lcomment s) insert_simple (Lcomment s)
| Iraise, [|exn|] -> | Iraise, [|exn|] ->
print_debug "Iraise"; insert Lstore [|cast exn addr_type; caml_exn|] Nothing;
insert Lstore [|cast exn addr_type; Const("@caml_exn", Address addr_type)|] Nothing;
(* (*
insert (Lextcall (Const("@llvm.eh.sjlj.longjmp", Function(Void, [Address byte])))) insert (Lextcall (Const("@llvm.eh.sjlj.longjmp", Function(Void, [Address byte]))))
[|cast (Const("@caml_jump_buffer", Address Jump_buffer)) (Address byte)|] Nothing; [|cast jmp_buf (Address byte)|] Nothing;
*) *)
insert (Lextcall (Const("@longjmp", Function(Void, [Address byte; Integer 32])))) insert (Lextcall (global "longjmp" (function_type Void [Address byte; Integer 32])))
[|cast (Const("@caml_jump_buffer", Address Jump_buffer)) (Address byte); Const("1", Integer 32)|] Nothing; [|cast jmp_buf (Address byte);
const "1" (Integer 32)|] Nothing;
insert_simple Lunreachable insert_simple Lunreachable
| Itrywith(try_instr, with_instr), [||] -> | Itrywith(try_instr, with_instr), [||] ->
print_debug "Itrywith";
let c = c() in let c = c() in
let try_lbl, with_lbl, cont_lbl = "try" ^ c, "with" ^ c, "cont" ^ c in let try_lbl, with_lbl, cont_lbl = "try" ^ c, "with" ^ c, "cont" ^ c in
let old_jmp_buf = alloca (new_reg "old_jmp_buf" (Address Jump_buffer)) in let old_jmp_buf = alloca (new_reg "old_jmp_buf" (Address Jump_buffer)) in
let temp_buf = load (Const("@caml_jump_buffer", Address Jump_buffer)) (new_reg "" Jump_buffer) in let temp_buf = load jmp_buf (new_reg "" Jump_buffer) in
insert Lstore [|temp_buf; old_jmp_buf|] Nothing; insert Lstore [|temp_buf; old_jmp_buf|] Nothing;
let set_jmp_res = new_reg "" (Integer 32) in let set_jmp_res = new_reg "" (Integer 32) in
(* insert (Lextcall setjmp) [|cast jmp_buf (Address byte)|] set_jmp_res;
insert (Lextcall (Const("@llvm.eh.sjlj.setjmp", Function(Integer 32, [Address byte]))))
[|cast (Const("@caml_jump_buffer", Address Jump_buffer)) (Address byte)|] set_jmp_res;
*)
insert (Lextcall (Const("@setjmp", Function(Integer 32, [Address byte]))))
[|cast (Const("@caml_jump_buffer", Address Jump_buffer)) (Address byte)|] set_jmp_res;
let tmp = if typ <> Void then alloca (new_reg "try_with_tmp" (Address typ)) else Nothing in let tmp = if typ <> Void then alloca (new_reg "try_with_tmp" (Address typ)) else Nothing in
let cond = new_reg "" bit in let cond = new_reg "" bit in
insert (Lcomp Comp_eq) [|set_jmp_res; Const("0", int_type)|] cond; insert (Lcomp Comp_eq) [|set_jmp_res; Const("0", int_type)|] cond;
insert (Lcondbranch(try_lbl, with_lbl)) [|cond|] Nothing; insert (Lcondbranch(try_lbl, with_lbl)) [|cond|] Nothing;


let try_res = (last_instr try_instr).Mach.res in
label try_lbl; label try_lbl;
linear try_instr; linear try_instr;
let try_res = block_res try_instr in
if typeof try_res <> Void then insert Lstore [|cast try_res typ; tmp|] Nothing; if typeof try_res <> Void then insert Lstore [|cast try_res typ; tmp|] Nothing;
let temp_buf = load old_jmp_buf (new_reg "" Jump_buffer) in let temp_buf = load old_jmp_buf (new_reg "" Jump_buffer) in
insert Lstore [|temp_buf; Const("@caml_jump_buffer", Address Jump_buffer)|] Nothing; insert Lstore [|temp_buf; jmp_buf|] Nothing;
branch cont_lbl; branch cont_lbl;


let with_res = (last_instr with_instr).Mach.res in let with_res = (last_instr with_instr).Mach.res in
label with_lbl; label with_lbl;
let temp_buf = load old_jmp_buf (new_reg "" Jump_buffer) in let temp_buf = load old_jmp_buf (new_reg "" Jump_buffer) in
insert Lstore [|temp_buf; Const("@caml_jump_buffer", Address Jump_buffer)|] Nothing; insert Lstore [|temp_buf; jmp_buf|] Nothing;
linear with_instr; linear with_instr;
if typeof with_res <> Void then insert Lstore [|cast with_res typ; tmp|] Nothing; if typeof with_res <> Void then insert Lstore [|cast with_res typ; tmp|] Nothing;
branch cont_lbl; branch cont_lbl;
Expand All @@ -313,34 +297,34 @@ let rec linear i =
| Icatch(i, body, handler), [||] -> | Icatch(i, body, handler), [||] ->
let c = c () in let c = c () in
Hashtbl.add exits i c; Hashtbl.add exits i c;
print_debug "Icatch";
let tmp = if typ <> Void then alloca (new_reg "catch_tmp" (Address typ)) else Nothing in let tmp = if typ <> Void then alloca (new_reg "catch_tmp" (Address typ)) else Nothing in
linear body; linear body;
let body_res = (last_instr body).Mach.res in let body_res = (last_instr body).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"); if typeof body_res <> Void then insert Lstore [|cast body_res typ; tmp|] Nothing
else insert_simple (Lcomment "nothing to store in body");
branch ("endcatch" ^ c); branch ("endcatch" ^ c);

label ("exit" ^ string_of_int i ^ c); label ("exit" ^ string_of_int i ^ c);
Hashtbl.remove exits i; Hashtbl.remove exits i;
linear handler; linear handler;
let handler_res = (last_instr handler).Mach.res in let handler_res = (last_instr handler).Mach.res in
if typeof handler_res <> Void then insert Lstore [|cast handler_res typ; tmp|] Nothing if typeof handler_res <> Void then insert Lstore [|cast handler_res typ; tmp|] Nothing
else insert_simple (Lcomment "nothing to store in handler"); else insert_simple (Lcomment "nothing to store in handler");
branch ("endcatch" ^ c); branch ("endcatch" ^ c);

label ("endcatch" ^ c); label ("endcatch" ^ c);
if typ <> Void then insert Lload [|tmp|] res if typ <> Void then insert Lload [|tmp|] res
| Iloop body, [||] -> | Iloop body, [||] ->
print_debug "Iloop";
let lbl = "loop" ^ c() in let lbl = "loop" ^ c() in
branch lbl; branch lbl;


label lbl; label lbl;
linear body; linear body;
branch lbl branch lbl
| Iexit i, [||] -> | Iexit i, [||] ->
print_debug "Iexit";
branch ("exit" ^ string_of_int i ^ Hashtbl.find exits i) branch ("exit" ^ string_of_int i ^ Hashtbl.find exits i)
| Ialloc len, [||] -> | Ialloc len, [||] ->
print_debug "Ialloc";
let counter = c () in let counter = c () in
let collect_lbl, continue_lbl = "collect" ^ counter, "continue" ^ counter in let collect_lbl, continue_lbl = "collect" ^ counter, "continue" ^ counter in
insert_simple (Lcomment ("allocating " ^ string_of_int len ^ "*8 bytes")); insert_simple (Lcomment ("allocating " ^ string_of_int len ^ "*8 bytes"));
Expand All @@ -361,6 +345,7 @@ let rec linear i =


label continue_lbl; label continue_lbl;
insert Lload [|caml_young_ptr|] res insert Lload [|caml_young_ptr|] res

(* (*
let alloc, arg_types, args = let alloc, arg_types, args =
match len with match len with
Expand All @@ -375,6 +360,7 @@ let rec linear i =
in in
insert (Lextcall (Const(alloc, Function(addr_type, arg_types)))) args res insert (Lextcall (Const(alloc, Function(addr_type, arg_types)))) args res
*) *)

(* TODO tell LLVM that the garbage collection is unlikely *) (* TODO tell LLVM that the garbage collection is unlikely *)
| _, _ -> error ("unknown instruction:\n" ^ Printmach.instr_to_string i) | _, _ -> error ("unknown instruction:\n" ^ Printmach.instr_to_string i)
end; linear next end end; linear next end
Expand Down
2 changes: 1 addition & 1 deletion src/asmcomp/linearize.mli
View file
Expand Up @@ -3,7 +3,7 @@ open Mach


type label = string type label = string


type cast = Zext | Trunc | Bitcast | Inttoptr | Ptrtoint type cast = Zext | Sext | Trunc | Bitcast | Inttoptr | Ptrtoint


type instruction = type instruction =
{ mutable desc: instruction_desc; { mutable desc: instruction_desc;
Expand Down
2 changes: 1 addition & 1 deletion src/asmcomp/mach.ml
View file
Expand Up @@ -21,7 +21,7 @@ and instruction_desc =
| Ibinop of binop | Ibinop of binop
| Icomp of comp | Icomp of comp
| Ialloca | Iload | Istore | Ialloca | Iload | Istore
| Isitofp | Ifptosi | Isitofp | Ifptosi | Izext | Isext
| Igetelementptr | Igetelementptr
| Icall of register | Iextcall of register * bool | Icall of register | Iextcall of register * bool
| Iifthenelse of instruction * instruction | Iifthenelse of instruction * instruction
Expand Down
2 changes: 1 addition & 1 deletion src/asmcomp/mach.mli
View file
Expand Up @@ -20,7 +20,7 @@ and instruction_desc =
| Ibinop of binop | Ibinop of binop
| Icomp of comp | Icomp of comp
| Ialloca | Iload | Istore | Ialloca | Iload | Istore
| Isitofp | Ifptosi | Isitofp | Ifptosi | Izext | Isext
| Igetelementptr | Igetelementptr
| Icall of register | Iextcall of register * bool | Icall of register | Iextcall of register * bool
| Iifthenelse of instruction * instruction | Iifthenelse of instruction * instruction
Expand Down
4 changes: 4 additions & 0 deletions src/asmcomp/printmach.ml
View file
Expand Up @@ -21,6 +21,10 @@ let rec instr_to_string instr =
| Istore, [|value; addr|] -> | Istore, [|value; addr|] ->
"store " ^ string_of_reg value ^ " " ^ string_of_reg addr "store " ^ string_of_reg value ^ " " ^ string_of_reg addr
| Istore, args -> error ("using store with " ^ string_of_int (Array.length args) ^ " arguments") | Istore, args -> error ("using store with " ^ string_of_int (Array.length args) ^ " arguments")
| Izext, [|value|] -> typ_str ^ "zext " ^ reg_name value
| Izext, args -> error ("using zext with " ^ string_of_int (Array.length args) ^ " arguments")
| Isext, [|value|] -> typ_str ^ "sext " ^ reg_name value
| Isext, args -> error ("using sext with " ^ string_of_int (Array.length args) ^ " arguments")
| Ifptosi, [|value|] -> typ_str ^ "fptosi " ^ reg_name value | Ifptosi, [|value|] -> typ_str ^ "fptosi " ^ reg_name value
| Ifptosi, args -> error ("using fptosi with " ^ string_of_int (Array.length args) ^ " arguments") | Ifptosi, args -> error ("using fptosi with " ^ string_of_int (Array.length args) ^ " arguments")
| Isitofp, [|value|] -> typ_str ^ "sitofp " ^ reg_name value | Isitofp, [|value|] -> typ_str ^ "sitofp " ^ reg_name value
Expand Down

0 comments on commit afd2373

Please sign in to comment.