Skip to content
Browse files

Added code to store the arguments of allocs and functions potentially…

… containing pointers on the stack

Otherwise the garbage collector would not be able to replace those
pointers by new ones when necessary.  This does not currently handle all
cases, because my (very simple) type inference algorithm sometimes
mistakenly thinks of variables as integers when they can actually be
pointers.

So in some cases the pointers get changed correctly during garbage
collection but not all cases.
  • Loading branch information...
1 parent 4d745b0 commit a8eb8cd37d0bfba66fca71735a04cbb2f7365e17 @colinbenner committed Mar 9, 2012
Showing with 85 additions and 50 deletions.
  1. +0 −10 src/asmcomp/emit_common.ml
  2. +16 −16 src/asmcomp/linearize.ml
  3. +1 −2 src/asmcomp/linearize.mli
  4. +0 −2 src/asmcomp/printlinearize.ml
  5. +68 −20 src/asmcomp/selectgen.ml
View
10 src/asmcomp/emit_common.ml
@@ -80,10 +80,6 @@ let emit_llvm instr =
| 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
- | Linvoke(fn, lbl, dummy), args, _ ->
- emit_instr ((if res <> Nothing then reg_name res ^ " = " else "") ^ "invoke ccc " ^ string_of_type(typeof res) ^ " " ^ reg_name fn ^ "(" ^
- Printlinearize.print_array string_of_reg args ^ ") nounwind to label %" ^ lbl ^ " unwind label %" ^ dummy)
- | Llandingpad, [||], Nothing -> emit_instr ("%foo" ^ c () ^ " = landingpad i8 personality i32 (...)* @__gxx_personality_v0 catch i8* @...")
| Llabel name, [||], Nothing -> emit_label name
| Lbranch lbl, [||], Nothing -> emit_instr ("br label %" ^ lbl)
| Lcondbranch(then_label, else_label), [|cond|], Nothing ->
@@ -110,7 +106,6 @@ let emit_llvm instr =
| 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")
- | Llandingpad, _, _ -> error ("landingpad 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")
@@ -155,18 +150,13 @@ let header =
; "declare double @fabs(double) nounwind"
; "declare void @llvm.gcroot(i8**, i8*) nounwind"
; "declare i8* @llvm.stacksave()"
- ; "declare i32 @__gxx_personality_v0(...)"
- (*
; "declare " ^ calling_conv ^ " " ^ addr_type ^ " @caml_alloc1() nounwind"
; "declare " ^ calling_conv ^ " " ^ addr_type ^ " @caml_alloc2() nounwind"
; "declare " ^ calling_conv ^ " " ^ addr_type ^ " @caml_alloc3() nounwind"
; "declare " ^ calling_conv ^ " " ^ addr_type ^ " @caml_allocN(" ^ addr_type ^ ") nounwind"
- *)
; "declare void @caml_ml_array_bound_error() nounwind"
; "declare void @caml_call_gc() nounwind"
- ; "@... = internal constant i8 1"
-
; "@caml_young_ptr = external global " ^ addr_type
; "@caml_young_limit = external global " ^ addr_type
; "@caml_bottom_of_stack = external global i8*"
View
32 src/asmcomp/linearize.ml
@@ -23,8 +23,7 @@ and instruction_desc =
| Lop of binop
| Lfptosi | Lsitofp
| Lalloca | Lload | Lstore | Lgetelemptr
- | Lcall of register | Lextcall of register | Linvoke of register * label * label
- | Llandingpad
+ | Lcall of register | Lextcall of register
| Lreturn
| Llabel of label
| Lbranch of label
@@ -87,7 +86,7 @@ let reverse_instrs tmp =
-let cast_reg value dest_typ reg =
+let rec cast_reg value dest_typ reg =
let typ = typeof value in
let cast op value reg = insert (Lcast op) [|value|] reg in
begin
@@ -96,6 +95,7 @@ let cast_reg value dest_typ reg =
| (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, Address _) -> cast Inttoptr (cast_reg value int_type (new_reg "" int_type)) 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
@@ -202,10 +202,8 @@ let rec linear i =
let stackpointer = new_reg "sp" (Address byte) in
insert (Lextcall (Const("@llvm.stacksave", Function(byte, [])))) [||] stackpointer;
insert Lstore [|stackpointer; Const("@caml_bottom_of_stack", Address (Address byte))|] Nothing;
- insert (Linvoke(cast fn typ, ret_lbl, dummy_lbl)) (Array.mapi (fun i arg -> cast arg arg_typ.(i)) args) res;
- label dummy_lbl;
- insert_simple Llandingpad;
- insert_simple Lunreachable;
+ insert (Lextcall (cast fn typ)) (Array.mapi (fun i arg -> cast arg arg_typ.(i)) args) res;
+ branch ret_lbl;
label ret_lbl
else
insert (Lextcall (cast fn typ)) (Array.mapi (fun i arg -> cast arg arg_typ.(i)) args) res
@@ -364,17 +362,19 @@ let rec linear i =
label continue_lbl;
insert Lload [|caml_young_ptr|] res
(*
- let alloc, args =
+ let alloc, arg_types, args =
match len with
- 2 -> "@caml_alloc1", []
- | 3 -> "@caml_alloc2", []
- | 4 -> "@caml_alloc3", []
- | _ -> "@caml_allocN", [addr_type]
+ 2 -> "@caml_alloc1", [], [||]
+ | 3 -> "@caml_alloc2", [], [||]
+ | 4 -> "@caml_alloc3", [], [||]
+ | _ ->
+ "@caml_allocN", [addr_type],
+ [|Const("inttoptr(" ^ string_of_type int_type ^ " " ^
+ string_of_int (len-1) ^ " to " ^ string_of_type addr_type ^
+ ")", 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
- *)
-
+ insert (Lextcall (Const(alloc, Function(addr_type, arg_types)))) args res
+ *)
(* TODO tell LLVM that the garbage collection is unlikely *)
| _, _ -> error ("unknown instruction:\n" ^ Printmach.instr_to_string i)
end; linear next end
View
3 src/asmcomp/linearize.mli
@@ -19,8 +19,7 @@ and instruction_desc =
| Lop of binop
| Lfptosi | Lsitofp
| Lalloca | Lload | Lstore | Lgetelemptr
- | Lcall of register | Lextcall of register | Linvoke of register * label * label
- | Llandingpad
+ | Lcall of register | Lextcall of register
| Lreturn
| Llabel of label
| Lbranch of label
View
2 src/asmcomp/printlinearize.ml
@@ -23,8 +23,6 @@ let print_instr instr = begin
| 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)
- | Linvoke(fn, lbl, dummy) -> print_string (string_of_reg res ^ " = invoke " ^ string_of_reg fn ^ " return to " ^ lbl ^ " exception to " ^ dummy)
- | Llandingpad -> print_string ("landingpad ...")
| Llabel name -> print_string ("label " ^ name)
| Lbranch name -> print_string ("branch " ^ name)
| Lcondbranch(ifso, ifnot) -> print_string ("branch " ^ ifso ^ ", " ^ ifnot)
View
88 src/asmcomp/selectgen.ml
@@ -80,16 +80,12 @@ let insert_debug seq desc dbg arg res typ =
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);
- add_type name (strip_addrs (Address typ));
- insert seq Ialloca [||] (Reg(name, strip_addrs (Address typ))) (deref (strip_addrs (Address typ)))
+ add_type name (Address typ);
+ insert seq Ialloca [||] (Reg(name, Address typ)) typ
let load seq arg reg typ = insert seq Iload [|arg|] (new_reg reg typ) typ
let store seq value addr typ = ignore (insert seq Istore [|value; addr|] Nothing typ)
@@ -106,8 +102,6 @@ let ifthenelse seq cond ifso ifnot =
let typ = if typ = Void then typeof (last_instr ifnot).res else typ in
insert seq (Iifthenelse(ifso, ifnot)) [|cond|] (if typ = Void then Nothing else (new_reg "if_result" typ)) typ
-let alloc seq len res typ = insert seq (Ialloc len) [||] (new_reg res typ) typ
-
let binop seq op left right typ = insert seq (Ibinop op) [|left; right|] (new_reg "" typ) typ
let comp seq op left right typ = insert seq (Icomp op) [|left; right|] (new_reg "" bit) typ
@@ -179,7 +173,7 @@ let rec caml_type expect = function
| Cop(Cload mem, [arg]) ->
let typ = translate_mem mem in
ignore (caml_type (Address typ) arg);
- if not (is_float typ) then int_type else typ
+ if not (is_float typ) then addr_type else typ
| Cop(_,_) -> error "operation not available"
| Csequence(fst,snd) -> ignore (caml_type Any fst); caml_type expect snd
| Cifthenelse(cond, expr1, expr2) ->
@@ -208,10 +202,11 @@ 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 null = Const("null", addr_type);;
+
let translate_float f =
let x = Int64.bits_of_float (float_of_string f) in
"0x" ^ Printf.sprintf "%Lx" x
-
let rec compile_instr seq instr =
match instr with
| Cconst_int i ->
@@ -248,7 +243,10 @@ let rec compile_instr seq instr =
let res_arg = compile_instr seq arg in
let addr = assert (typ <> Void); alloca seq name typ in
store seq res_arg addr typ;
- compile_instr seq body
+ let result = compile_instr seq body in
+ (* This store might be the last instruction in a block. Therefore it
+ * should return the actual result computed in that block: [res] *)
+ insert seq Istore [|null; addr|] result typ
| Cassign(id, expr) ->
print_debug "Cassign";
let name = translate_id id in
@@ -273,29 +271,76 @@ let rec compile_instr seq instr =
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" fn_type
+ let store_arg arg =
+ let typ = typeof arg in
+ if is_addr typ then begin
+ let name = reg_name (new_reg "arg" Any) in
+ let name = String.sub name 1 (String.length name - 1) in
+ let res = alloca seq name typ in
+ comment seq "storing function argument on the stack...";
+ store seq arg res typ;
+ res
+ end else arg
+ in
+ let args = Array.of_list (List.map store_arg args) in
+ let load_arg arg =
+ let typ = typeof arg in
+ if is_addr typ then load seq arg "" (deref typ) else arg
+ in
+ call seq fn (Array.map load_arg 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
+ let store_arg arg =
+ let typ = typeof arg in
+ if is_addr typ then begin
+ let name = reg_name (new_reg "arg" Any) in
+ let name = String.sub name 1 (String.length name - 1) in
+ let res = alloca seq name typ in
+ comment seq "storing extcall argument on the stack...";
+ store seq arg res typ;
+ res
+ end else arg
+ in
+ let args = List.map (fun x -> store_arg (compile_instr seq x)) exprs in
Emit_common.add_function (translate_machtype typ, "ccc", fn, args);
let fn_type = Address(Function(translate_machtype typ, List.map (fun _ -> addr_type) args)) in
add_type fn fn_type;
- extcall seq (Const("@" ^ fn, fn_type)) (Array.of_list args) "extcall" fn_type alloc
+ let load_arg arg =
+ let typ = typeof arg in
+ if is_addr typ then load seq arg "" (deref typ) else arg
+ in
+ extcall seq (Const("@" ^ fn, fn_type)) (Array.map load_arg (Array.of_list args)) "extcall" fn_type alloc
| 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 alloc = alloc seq (List.length args) "alloc" addr_type in
- let alloc = getelemptr seq alloc (Const("1", int_type)) addr_type in
+ let alloc_res = new_reg "alloc" addr_type in
+ let store_arg arg =
+ let typ = typeof arg in
+ if is_addr typ then begin
+ let name = reg_name (new_reg "arg" Any) in
+ let name = String.sub name 1 (String.length name - 1) in
+ let res = alloca seq name typ in
+ comment seq "storing alloc argument on the stack...";
+ store seq arg res typ;
+ res
+ end else arg
+ in
+ let ptr = insert seq (Ialloc (List.length args)) [||] alloc_res addr_type in
+ let alloc = 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 alloc (Const(counter, int_type)) addr_type in
num := !num + 1;
+ let typ = typeof elem in
+ let elemptr = getelemptr seq alloc (Const(counter, int_type)) addr_type in
+ let value = if is_addr typ then load seq elem "" typ else elem in
+ if is_addr typ then store seq (Const("null", addr_type)) elem (deref typ);
(* The store itself returns [Nothing] but the enclosing blocks result is
- * [alloc]. vvvvv *)
- ignore (insert seq Istore [|elem; elemptr|] alloc (typeof elem))
+ * [alloc]. vvvvv *)
+ ignore (insert seq Istore [|value; elemptr|] alloc typ)
in
+ let args = List.map store_arg args in
List.iter emit_arg args;
alloc
| Cop(Cstore mem, [addr; value]) ->
@@ -404,7 +449,7 @@ and compile_operation seq op = function
match op with
| Cfloatofint -> insert seq Isitofp [|arg|] (new_reg "float_of_int" Double) Double
| Cintoffloat -> insert seq Ifptosi [|arg|] (new_reg "int_of_float" float_sized_int) float_sized_int
- | Cabsf -> extcall seq fabs [|arg|] "absf_res" (Address(Function(Double, [Double]))) false
+ | Cabsf -> extcall seq fabs [|arg|] "absf" (Address(Function(Double, [Double]))) false
| Cnegf -> binop seq Op_subf (Const("0.0", Double)) arg Double
| Cload mem ->
let typ = translate_mem mem in
@@ -426,8 +471,11 @@ let fundecl = function
let args = List.map (fun (x, typ) -> (translate_symbol (Ident.unique_name x), addr_type)) args in
try
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
+ *)
+ let typ = addr_type in
store tmp_seq (Reg("param." ^ x, addr_type)) (assert (typ <> Void); alloca tmp_seq x typ) typ
in
List.iter foo args;

0 comments on commit a8eb8cd

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