Permalink
Browse files

Added runtime code, fixed a few bugs, restructured some code

- added the asmrun, byterun and config directories from the OCaml
  distribution
- fixed a bug that caused the compiled code to load data from the wrong
  address (in particular it looked for some data at an n word offset
  instead of an n byte offset)
- moved the type definitions for the intermediate data to a separate
  module
  • Loading branch information...
1 parent 822c4bc commit 4d7b20bf8a57de684b2f64249f1696b32e2442d7 @colinbenner colinbenner committed Dec 28, 2011
Showing with 29,921 additions and 457 deletions.
  1. +6 −0 src/VERSION
  2. +4 −3 src/asmcomp/asmgen.ml
  3. +4 −3 src/asmcomp/asmlink.ml
  4. +141 −0 src/asmcomp/llvm_types.ml
  5. +83 −0 src/asmcomp/llvm_types.mli
  6. +137 −135 src/asmcomp/llvmcompile.ml
  7. +5 −6 src/asmcomp/llvmcompile.mli
  8. +137 −238 src/asmcomp/llvmemit.ml
  9. +25 −69 src/asmcomp/llvmemit.mli
  10. +741 −0 src/asmrun/.depend
  11. +186 −0 src/asmrun/Makefile
  12. +81 −0 src/asmrun/Makefile.nt
  13. +440 −0 src/asmrun/alpha.S
  14. +519 −0 src/asmrun/amd64.S
  15. +466 −0 src/asmrun/amd64nt.asm
  16. +318 −0 src/asmrun/arm.S
  17. +224 −0 src/asmrun/backtrace.c
  18. +207 −0 src/asmrun/fail.c
  19. +534 −0 src/asmrun/hppa.S
  20. +431 −0 src/asmrun/i386.S
  21. +322 −0 src/asmrun/i386nt.asm
  22. +523 −0 src/asmrun/ia64.S
  23. +244 −0 src/asmrun/m68k.S
  24. +386 −0 src/asmrun/mips.s
  25. +126 −0 src/asmrun/natdynlink.c
  26. 0 src/asmrun/natdynlink.h
  27. +513 −0 src/asmrun/power-aix.S
  28. +420 −0 src/asmrun/power-elf.S
  29. +474 −0 src/asmrun/power-rhapsody.S
  30. +373 −0 src/asmrun/roots.c
  31. +257 −0 src/asmrun/signals_asm.c
  32. +305 −0 src/asmrun/signals_osdep.h
  33. +407 −0 src/asmrun/sparc.S
  34. +133 −0 src/asmrun/stack.h
  35. +185 −0 src/asmrun/startup.c
  36. +20 −0 src/byterun/.cvsignore
  37. +410 −0 src/byterun/.depend
  38. +71 −0 src/byterun/Makefile
  39. +93 −0 src/byterun/Makefile.common
  40. +53 −0 src/byterun/Makefile.nt
  41. +186 −0 src/byterun/alloc.c
  42. +47 −0 src/byterun/alloc.h
  43. +193 −0 src/byterun/array.c
  44. +310 −0 src/byterun/backtrace.c
  45. +33 −0 src/byterun/backtrace.h
  46. +248 −0 src/byterun/callback.c
  47. +49 −0 src/byterun/callback.h
  48. +441 −0 src/byterun/compact.c
  49. +27 −0 src/byterun/compact.h
  50. +322 −0 src/byterun/compare.c
  51. +21 −0 src/byterun/compare.h
  52. +372 −0 src/byterun/compatibility.h
  53. +168 −0 src/byterun/config.h
  54. +102 −0 src/byterun/custom.c
  55. +64 −0 src/byterun/custom.h
  56. +436 −0 src/byterun/debugger.c
  57. +113 −0 src/byterun/debugger.h
  58. +267 −0 src/byterun/dynlink.c
  59. +38 −0 src/byterun/dynlink.h
  60. +62 −0 src/byterun/exec.h
  61. +726 −0 src/byterun/extern.c
  62. +170 −0 src/byterun/fail.c
  63. +77 −0 src/byterun/fail.h
  64. +251 −0 src/byterun/finalise.c
  65. +29 −0 src/byterun/finalise.h
  66. +162 −0 src/byterun/fix_code.c
  67. +42 −0 src/byterun/fix_code.h
  68. +478 −0 src/byterun/floats.c
  69. +545 −0 src/byterun/freelist.c
  70. +36 −0 src/byterun/freelist.h
  71. +58 −0 src/byterun/gc.h
  72. +505 −0 src/byterun/gc_ctrl.c
  73. +42 −0 src/byterun/gc_ctrl.h
  74. +283 −0 src/byterun/globroots.c
  75. +27 −0 src/byterun/globroots.h
  76. +157 −0 src/byterun/hash.c
  77. +265 −0 src/byterun/instrtrace.c
  78. +31 −0 src/byterun/instrtrace.h
  79. +61 −0 src/byterun/instruct.h
  80. +273 −0 src/byterun/int64_emul.h
  81. +107 −0 src/byterun/int64_format.h
  82. +53 −0 src/byterun/int64_native.h
  83. +715 −0 src/byterun/intern.c
  84. +1,148 −0 src/byterun/interp.c
  85. +33 −0 src/byterun/interp.h
  86. +162 −0 src/byterun/intext.h
  87. +774 −0 src/byterun/ints.c
  88. +799 −0 src/byterun/io.c
  89. +126 −0 src/byterun/io.h
  90. +230 −0 src/byterun/lexing.c
  91. +59 −0 src/byterun/main.c
  92. +509 −0 src/byterun/major_gc.c
  93. +62 −0 src/byterun/major_gc.h
  94. +310 −0 src/byterun/md5.c
  95. +41 −0 src/byterun/md5.h
  96. +548 −0 src/byterun/memory.c
  97. +459 −0 src/byterun/memory.h
  98. +174 −0 src/byterun/meta.c
  99. +321 −0 src/byterun/minor_gc.c
  100. +58 −0 src/byterun/minor_gc.h
  101. +125 −0 src/byterun/misc.c
  102. +136 −0 src/byterun/misc.h
  103. +295 −0 src/byterun/mlvalues.h
  104. +251 −0 src/byterun/obj.c
  105. +71 −0 src/byterun/osdeps.h
  106. +302 −0 src/byterun/parsing.c
  107. +36 −0 src/byterun/prims.h
  108. +126 −0 src/byterun/printexc.c
  109. +27 −0 src/byterun/printexc.h
  110. +88 −0 src/byterun/reverse.h
  111. +103 −0 src/byterun/roots.c
  112. +38 −0 src/byterun/roots.h
  113. +307 −0 src/byterun/signals.c
  114. +51 −0 src/byterun/signals.h
  115. +95 −0 src/byterun/signals_byt.c
  116. +62 −0 src/byterun/signals_machdep.h
  117. +115 −0 src/byterun/stacks.c
  118. +43 −0 src/byterun/stacks.h
  119. +505 −0 src/byterun/startup.c
  120. +40 −0 src/byterun/startup.h
  121. +155 −0 src/byterun/str.c
  122. +348 −0 src/byterun/sys.c
  123. +30 −0 src/byterun/sys.h
  124. +132 −0 src/byterun/terminfo.c
  125. +28 −0 src/byterun/ui.h
  126. +325 −0 src/byterun/unix.c
  127. +193 −0 src/byterun/weak.c
  128. +26 −0 src/byterun/weak.h
  129. +545 −0 src/byterun/win32.c
  130. +73 −0 src/config/Makefile
  131. +289 −0 src/config/Makefile-templ
  132. +158 −0 src/config/Makefile.mingw
  133. +164 −0 src/config/Makefile.msvc
  134. +160 −0 src/config/Makefile.msvc64
  135. +15 −0 src/config/m.h
  136. +50 −0 src/config/s.h
  137. +3 −1 src/utils/ccomp.ml
  138. +2 −2 src/utils/config.ml.ab
View
@@ -0,0 +1,6 @@
+3.12.1
+
+# The version string is the first line of this file.
+# It must be in the format described in stdlib/sys.mli
+
+# $Id$
View
@@ -82,7 +82,7 @@ let compile_phrase ppf p =
if !use_llvm then
match p with
| Cfunction fd -> Llvmcompile.compile_fundecl fd
- | Cdata dl -> Llvmcompile.data dl
+ | Cdata dl -> Llvmemit.data dl
else
match p with
| Cfunction fd -> compile_fundecl ppf fd
@@ -100,10 +100,11 @@ let compile_genfuns ppf f =
(Cmmgen.generic_functions true [Compilenv.current_unit_infos ()])
let compile_implementation ?toplevel prefixname ppf (size, lam) =
+ let suffix = if !use_llvm then ext_llvm else ext_asm in
let asmfile =
if !keep_asm_file
- then prefixname ^ ext_asm
- else Filename.temp_file "camlasm" ext_asm in
+ then prefixname ^ suffix
+ else Filename.temp_file "camlasm" suffix in
let oc = open_out asmfile in
begin try
Emitaux.output_channel := oc;
View
@@ -286,7 +286,7 @@ let call_linker file_list startup_file output_name =
let files = startup_file :: (List.rev file_list) in
let files, c_lib =
if (not !Clflags.output_c_object) || main_dll then
- files @ (List.rev !Clflags.ccobjs) @ runtime_lib (),
+ (List.rev !Clflags.ccobjs) @ runtime_lib () @ files,
(if !Clflags.nopervasives then "" else Config.native_c_libraries)
else
files, ""
@@ -328,14 +328,15 @@ let link ppf objfiles output_name =
make_startup_file ppf startup units_tolink;
let startup_obj = Filename.temp_file "camlstartup" ext_obj in
let temp1 =
- if !Clflags.keep_startup_file then output_name ^ ".startup.opt" ^ ext_llvm
- else Filename.temp_file "camlstartup.opt" suffix
+ if !Clflags.keep_startup_file then output_name ^ ".startup.bc"
+ else Filename.temp_file "camlstartup" ".bc"
in
let temp2 =
if !Clflags.keep_startup_file then output_name ^ ".startup" ^ ext_asm
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
View
@@ -0,0 +1,141 @@
+exception Llvm_error of string
+
+type 'a error = Just of 'a | Error of string
+
+type llvm_type =
+ Integer of int (* bitwidth *)
+ | Double
+ | Address of llvm_type
+ | Void
+ | Any
+ | Function of llvm_type * llvm_type list (* return type, argument types *)
+
+type cast = Zext | Trunc | Bitcast | Inttoptr | Ptrtoint | Sitofp | Fptosi
+
+type binop =
+ Op_addi | Op_subi | Op_muli | Op_divi | Op_modi
+ | Op_and | Op_or | Op_xor | Op_lsl | Op_lsr | Op_asr
+ | Op_addf | Op_subf | Op_mulf | Op_divf
+
+type llvm_instr =
+ | Lvar of string * llvm_type (* name, type *)
+ | Lbinop of binop * llvm_type * llvm_instr * llvm_instr (* op, typ, left, right *)
+ | Lcomp of string * llvm_type * llvm_instr * llvm_instr (* op, typ, left, right *)
+ | Lalloca of string * llvm_type (*name, typ*)
+ | Lload of llvm_instr (* address *)
+ | Lstore of llvm_instr * llvm_instr (* value, address *)
+ | Lcast of cast * llvm_instr * llvm_type * llvm_type
+ | Lgetelementptr of llvm_instr * llvm_instr (* address, offset *)
+ | Lcall of llvm_type * llvm_instr * llvm_instr list (* return type, name, arguments *)
+ | Lccall of llvm_type * llvm_instr * llvm_instr list (* return type, name, arguments; using c calling convention *)
+ | Lconst of string * llvm_type (* literal, type *)
+ | Llabel of string (* name *)
+ | Lbr of string (* label *)
+ | Lbr_cond of llvm_instr * string * string (* condition, then label, else label *)
+ | Lswitch of string * llvm_instr * int array * llvm_instr * llvm_instr array * llvm_type (* indexes, blocks *)
+ | Lreturn of llvm_instr * llvm_type (* value, type *)
+ | Lseq of llvm_instr * llvm_instr (* value, type *)
+ | Lcaml_raise_exn of llvm_instr (* argument *)
+ | Lcaml_catch_exn of string * llvm_instr * llvm_instr (* ident, what to do, where to store result *)
+ | Lcaml_alloc of int (* length *)
+ | Ldefine of string * (string * llvm_type) list * llvm_instr (* name, arguments, body *)
+ | Lnothing
+ | Lunreachable
+ | Lcomment of string
+
+
+
+
+let error s = raise (Llvm_error s)
+
+let size_int = 8 * Arch.size_int
+let size_float = 8 * Arch.size_float
+
+let int_type = Integer size_int
+let addr_type = Address int_type
+let float_sized_int = Integer size_float
+
+let rec string_of_type = function
+ | Integer i -> "i" ^ string_of_int i
+ | Double -> "double"
+ | Address typ -> string_of_type typ ^ "*"
+ | Void -> "void"
+ | Any -> error "unable to infer type"
+ | Function(ret, args) -> string_of_type ret ^ " (" ^ String.concat ", " (List.map string_of_type args) ^ ")"
+
+let deref typ = match typ with
+ | Address typ -> typ
+ | _ -> error ("trying to dereference non-pointer type " ^ string_of_type typ)
+
+let string_of_binop = function
+ | Op_addi -> "add"
+ | Op_subi -> "sub"
+ | Op_muli -> "mul"
+ | Op_divi -> "sdiv"
+ | Op_modi -> "srem"
+ | Op_and -> "and"
+ | Op_or -> "or"
+ | Op_xor -> "xor"
+ | Op_lsl -> "shl"
+ | Op_lsr -> "lshr"
+ | Op_asr -> "ashr"
+ | Op_addf -> "fadd"
+ | Op_subf -> "fsub"
+ | Op_mulf -> "fmul"
+ | Op_divf -> "fdiv"
+
+let string_of_cast = function
+ | Zext -> "zext"
+ | Trunc -> "trunc"
+ | Bitcast -> "bitcast"
+ | Inttoptr -> "inttoptr"
+ | Ptrtoint -> "ptrtoint"
+ | Sitofp -> "sitofp"
+ | Fptosi -> "fptosi"
+
+let rec has_type = function
+ | Llabel _ | Ldefine(_,_,_) | Lunreachable | Lcomment _ | Lbr _ | Lbr_cond(_,_,_)
+ | Lstore(_,_) | Lcaml_raise_exn _ -> false
+ | Lseq(instr1, instr2) -> has_type instr2 || has_type instr1
+ | _ -> true
+
+let rec typeof = function
+ | Lvar(_, typ) -> typ
+ | Lbinop(_,typ,_,_) -> typ
+ | Lcomp(_,_,_,_) -> Integer 1
+ | Lalloca(_, typ) -> Address typ
+ | Lload addr -> deref (typeof addr)
+ | Lstore(_,_) -> Void
+ | Lcast(op,_,_,typ) -> typ
+ | Lgetelementptr(ptr,_) -> typeof ptr
+ | Lcall(typ,_,_) -> typ
+ | Lccall(typ,_,_) -> typ
+ | Lconst(_,typ) -> typ
+ | Llabel _ -> error "Label does not have a type"
+ | Lbr _ -> error "branch does not return anything"
+ | Lbr_cond(_,_,_) -> error "conditional branch does not return anything"
+ | Lswitch(_,_,_,_,_,typ) -> typ
+ | Lreturn(_, typ) -> typ
+ | Lseq(_, instr) when has_type instr -> typeof instr
+ | Lseq(instr,_) -> typeof instr
+ | Lcaml_raise_exn _ -> Void
+ | Lcaml_catch_exn(_,_,res) -> typeof res
+ | Lcaml_alloc _ -> addr_type
+ | Ldefine(_,_,_) -> error "Function..."
+ | Lnothing -> Void
+ | Lunreachable -> error "Lunreachable does not have a type"
+ | Lcomment _ -> error "Lcomment does not have a type"
+
+let (@@) a b = Lseq(a, b)
+
+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
View
@@ -0,0 +1,83 @@
+exception Llvm_error of string
+
+type 'a error = Just of 'a | Error of string
+
+type llvm_type =
+ Integer of int (* bitwidth *)
+ | Double
+ | Address of llvm_type
+ | Void
+ | Any
+ | Function of llvm_type * llvm_type list (* return type, argument types *)
+
+type cast = Zext | Trunc | Bitcast | Inttoptr | Ptrtoint | Sitofp | Fptosi
+
+type binop =
+ Op_addi | Op_subi | Op_muli | Op_divi | Op_modi
+ | Op_and | Op_or | Op_xor | Op_lsl | Op_lsr | Op_asr
+ | Op_addf | Op_subf | Op_mulf | Op_divf
+
+type llvm_instr =
+ Lvar of string * llvm_type (* name, type *)
+ | Lbinop of binop * llvm_type * llvm_instr * llvm_instr (* op, typ, left, right *)
+ | Lcomp of string * llvm_type * llvm_instr * llvm_instr (* op, typ, left, right *)
+ | Lalloca of string * llvm_type (*name, typ*)
+ | Lload of llvm_instr (* address *)
+ | Lstore of llvm_instr * llvm_instr (* value, address *)
+ | Lcast of cast * llvm_instr * llvm_type * llvm_type
+ | Lgetelementptr of llvm_instr * llvm_instr (* address, offset *)
+ | Lcall of llvm_type * llvm_instr * llvm_instr list (* return type, name, arguments *)
+ | Lccall of llvm_type * llvm_instr * llvm_instr list (* return type, name, arguments; using c calling convention *)
+ | Lconst of string * llvm_type (* literal, type *)
+ | Llabel of string (* name *)
+ | Lbr of string (* label *)
+ | Lbr_cond of llvm_instr * string * string (* condition, then label, else label *)
+ | Lswitch of string * llvm_instr * int array * llvm_instr * llvm_instr array * llvm_type (* indexes, blocks *)
+ | Lreturn of llvm_instr * llvm_type (* value, type *)
+ | Lseq of llvm_instr * llvm_instr (* value, type *)
+ | Lcaml_raise_exn of llvm_instr (* argument *)
+ | Lcaml_catch_exn of string * llvm_instr * llvm_instr (* ident, what to do, where to store result *)
+ | Lcaml_alloc of int (* length *)
+ | Ldefine of string * (string * llvm_type) list * llvm_instr (* name, arguments, body *)
+ | Lnothing
+ | Lunreachable
+ | Lcomment of string
+
+
+(* 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 *)
+val size_int : int
+(* The length of a floating point number *)
+val size_float : int
+
+(* integer type with [size_int] bits *)
+val int_type : llvm_type
+(* pointer to [int_type] *)
+val addr_type : llvm_type
+(* an integer with [size_float] bits *)
+val float_sized_int : llvm_type
+
+val string_of_binop : binop -> string
+val string_of_cast : cast -> string
+
+(* Turn an llvm_type into the string used by LLVM to represent that type. *)
+val string_of_type : llvm_type -> string
+(* For a pointer return what type its target has. *)
+val deref : llvm_type -> llvm_type
+
+(* Indicates whether the given [llvm_instr] returns a value in an SSA-register. *)
+val has_type : llvm_instr -> bool
+(* Returns the type of result of the given instruction. *)
+val typeof : llvm_instr -> llvm_type
+
+(* Turn two [llvm_instr] into a single one which does the first and then the
+ * second *)
+val (@@) : llvm_instr -> llvm_instr -> llvm_instr
+
+(* 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
Oops, something went wrong.

0 comments on commit 4d7b20b

Please sign in to comment.