Permalink
Browse files

Fixed a bug that caused errors when calculating offsets

The offsets calculated when handling a Calloc were intended to be word
offsets but were used as byte offsets.

Programs containing integer arithmetic, printing integers and references
work as expected. However, converting float to string does not work at
the moment while converting float to int does.
  • Loading branch information...
1 parent 4d7b20b commit 2a75c15ce966ca6680ac92f3b29d901df5121d23 @colinbenner committed Dec 30, 2011
Showing with 26 additions and 24 deletions.
  1. +0 −1 src/asmcomp/asmlink.ml
  2. +5 −4 src/asmcomp/llvm_types.ml
  3. +3 −1 src/asmcomp/llvm_types.mli
  4. +13 −13 src/asmcomp/llvmcompile.ml
  5. +5 −5 src/asmcomp/llvmemit.ml
View
@@ -336,7 +336,6 @@ let link ppf objfiles output_name =
else Filename.temp_file "camlstartup" ext_asm
in
if !Clflags.use_llvm then begin
- print_endline ("assembling " ^ startup ^ " into " ^ startup_obj ^ " using " ^ temp1 ^ " and " ^ temp2);
if Llvmemit.assemble_file temp1 temp2 startup startup_obj <> 0 then
raise(Error(Assembler_error startup));
end else
@@ -48,12 +48,13 @@ type llvm_instr =
let error s = raise (Llvm_error s)
-let size_int = 8 * Arch.size_int
-let size_float = 8 * Arch.size_float
+let size_addr = Arch.size_addr
+let size_int = Arch.size_int
+let size_float = Arch.size_float
-let int_type = Integer size_int
+let int_type = Integer (8 * size_int)
let addr_type = Address int_type
-let float_sized_int = Integer size_float
+let float_sized_int = Integer (8 * size_float)
let rec string_of_type = function
| Integer i -> "i" ^ string_of_int i
@@ -47,7 +47,9 @@ type llvm_instr =
(* Raise an Llvm_error with the string given as an argument. *)
val error : string -> 'a
-(* The length of an integer (and an address) in bits *)
+(* The length of an address in bits *)
+val size_addr : int
+(* The length of an integer in bits *)
val size_int : int
(* The length of a floating point number *)
val size_float : int
View
@@ -95,17 +95,17 @@ let cast value dest_typ =
then Lcast(Zext, value, typ, dest_typ)
else Lcast(Trunc, value, typ, dest_typ)
| (Integer i, Address _) ->
- if i == size_int
+ if i == size_int * 8
then Lcast(Inttoptr, value, typ, dest_typ)
else error ("could not cast integer of size " ^ string_of_int i ^ " to pointer")
| (Integer i, Double) ->
- if i == size_float
+ if i == size_float * 8
then Lcast(Bitcast, value, typ, dest_typ)
else error ("could not cast integer of size " ^ string_of_int i ^ " to pointer")
| (Integer _, Function(_,_)) -> Lcast(Inttoptr, value, typ, dest_typ)
| (Integer _, _) -> error ("invalid cast from integer to " ^ string_of_type dest_typ)
| (Double, Integer i) ->
- if i == size_float
+ if i == size_float * 8
then Lcast(Bitcast, value, typ, dest_typ)
else error ("could not cast float to integer of size " ^ string_of_int i)
| (Address i, Address j) -> if i == j then value else Lcast(Bitcast, value, typ, dest_typ)
@@ -277,7 +277,7 @@ let rec helper in_tail_position in_try_block instr =
| Ctuple [] -> Lconst(";", Void)
| Ctuple exprs -> begin
(* TODO What is Ctuple used for? Implement that. *)
- Lconst(";tuple_res", Void)
+ Lconst("tuple_res", Void)
end
| Cop(Capply(typ, debug), Cconst_symbol s :: args) ->
@@ -301,18 +301,18 @@ let rec helper in_tail_position in_try_block instr =
let c = c() in
let data = Lcaml_alloc (List.length args) in (* TODO figure out how much space a single element needs *)
let args = List.map (helper false in_try_block) args in
- let num = ref (-1) in
+ let num = ref (-size_int) in
let ptr = load (Lvar("%alloc" ^ c, Address addr_type)) in
let emit_arg x =
- num := !num + 1;
- let num = string_of_int !num in
- let header = getelementptr ptr (Lconst("1", int_type)) in
- let elemptr = getelementptr header (Lconst(num, int_type)) in
+ let counter = string_of_int !num in
+ let header = getelementptr ptr (Lconst(string_of_int size_int, int_type)) in
+ let elemptr = getelementptr header (Lconst(counter, int_type)) in
+ num := !num + size_int;
store x elemptr
in
store data (alloca ("alloc" ^ c) addr_type)
@@ List.fold_left (fun a b -> a @@ emit_arg b) ptr args
- @@ getelementptr ptr (Lconst("1", int_type))
+ @@ getelementptr ptr (Lconst(string_of_int size_int, int_type))
| Cop(Cstore mem, [addr; value]) ->
let addr = helper false in_try_block addr in
let value = helper false in_try_block value in
@@ -333,7 +333,7 @@ let rec helper in_tail_position in_try_block instr =
let arr = helper false in_try_block arr in
let index = helper false in_try_block index in
assert (typeof arr <> Void);
- let header = getelementptr (cast arr addr_type) (Lconst("-" ^ string_of_int Arch.size_addr, int_type)) in
+ let header = getelementptr (cast arr addr_type) (Lconst("-" ^ string_of_int size_addr, int_type)) in
let length = load header in
let cond = comp "icmp ule" (typeof length) index length in
let c = c () in
@@ -452,8 +452,8 @@ and compile_operation in_try_block op = function
| [arg] -> begin
let arg = helper false in_try_block arg in
match op with
- | Cfloatofint -> Lcast(Sitofp, arg, Integer size_float, Double)
- | Cintoffloat -> Lcast(Fptosi, arg, Double, Integer size_float)
+ | Cfloatofint -> Lcast(Sitofp, arg, float_sized_int, Double)
+ | Cintoffloat -> Lcast(Fptosi, arg, Double, float_sized_int)
| Cabsf -> Lccall(Double, Lvar("@fabs", Any), [arg])
| Cnegf -> binop Op_subf Double (Lconst("0.0", Double)) arg
| Cload mem ->
View
@@ -84,7 +84,7 @@ let rec lower instr =
if len = 2 then Lccall(addr_type, Lvar("@caml_alloc1", Any), [])
else if len = 3 then Lccall(addr_type, Lvar("@caml_alloc2", Any), [])
else if len = 4 then Lccall(addr_type, Lvar("@caml_alloc3", Any), [])
- else Lccall(addr_type, Lvar("@caml_allocN", Any), [Linttoptr(Lconst(string_of_int (len-1), int_type), int_type, addr_type)])
+ else Lccall(addr_type, Lvar("@caml_allocN", Any), [Lcast(Inttoptr, Lconst(string_of_int (len-1), int_type), int_type, addr_type)])
*)
(* TODO rewrite the code so it does not create a loop *)
(* TODO tell LLVM that the garbage collection is unlikely *)
@@ -275,10 +275,10 @@ let header =
[ "; vim: set ft=llvm:"
; "declare double @fabs(double)"
; "declare void @caml_raise_exn(" ^ addr_type ^ ") noreturn"
- ; "declare ccc " ^ addr_type ^ " @caml_alloc1()"
- ; "declare ccc " ^ addr_type ^ " @caml_alloc2()"
- ; "declare ccc " ^ addr_type ^ " @caml_alloc3()"
- ; "declare ccc " ^ addr_type ^ " @caml_allocN(" ^ addr_type ^ ")"
+ ; "declare " ^ calling_conv ^ " " ^ addr_type ^ " @caml_alloc1()"
+ ; "declare " ^ calling_conv ^ " " ^ addr_type ^ " @caml_alloc2()"
+ ; "declare " ^ calling_conv ^ " " ^ addr_type ^ " @caml_alloc3()"
+ ; "declare " ^ calling_conv ^ " " ^ addr_type ^ " @caml_allocN(" ^ addr_type ^ ")"
; "declare ccc void @caml_call_gc()"
; "@caml_exception_pointer = external global " ^ addr_type ^ ""
; "@caml_young_ptr = external global " ^ addr_type ^ ""

0 comments on commit 2a75c15

Please sign in to comment.