Permalink
Browse files

Exception handling based on libc setjmp/longjmp mostly works.

  • Loading branch information...
1 parent 8f7b982 commit 00cc6207678dd661e93956e0cd93cd268046d5e6 @colinbenner committed Feb 8, 2012
Showing with 122 additions and 30 deletions.
  1. +45 −21 src/asmcomp/llvm_linearize.ml
  2. +1 −2 src/asmcomp/llvm_selectgen.ml
  3. +11 −2 src/asmcomp/llvmemit.ml
  4. +62 −4 src/asmrun/amd64.S
  5. +3 −1 src/asmrun/startup.c
@@ -120,6 +120,9 @@ let rec last_instr instr =
Iend -> instr
| _ -> last_instr instr.Llvm_mach.next
+let caml_young_ptr = Const("@caml_young_ptr", Address addr_type)
+let caml_young_limit = Const("@caml_young_limit", Address addr_type)
+
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
@@ -135,12 +138,12 @@ let rec linear i =
| Ialloca, [||] ->
print_debug "Ialloca";
ignore (alloca res)
- (*
- let arg = cast (Iconst("%" ^ name, Address typ)) (Address byte_ptr) in
- if is_addr typ then
- ignore (call "ccc" Void (Ivar("@llvm.gcroot", Function(Void, [Address byte_ptr; byte_ptr])))
- [arg; Iconst("null", byte_ptr)]);
- *)
+ (*
+ let a = alloca res in
+ if is_addr (deref (typeof a)) then
+ insert (Lextcall (Const("@llvm.gcroot", Function(Void, [Address (Address byte); Address byte]))))
+ [|cast a (Address (Address byte)); Const("inttoptr(i64 0 to i8* )", Address byte)|] Nothing;
+ *)
| Iload, [|addr|] ->
print_debug "Iload";
ignore (load (cast addr (Address typ)) res)
@@ -197,13 +200,16 @@ let rec linear i =
| Iswitch(indexes, blocks), [|value|] ->
print_debug "Iswitch";
let c = c () in
- let labels = Array.map (fun i -> "case" ^ string_of_int i ^ c) indexes in (* TODO create the correct labels *)
+ let labels = Array.map (fun i -> "case" ^ string_of_int i ^ c) indexes in
let switch_res = alloca (register "" (assert (typ <> Address Void); if typ <> Void then Address typ else addr_type)) in
insert (Lswitch("default" ^ c, labels)) [|cast value int_type|] Nothing;
label ("default" ^ c);
- 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 Lstore [|Const("@caml_exn_Match_failure", addr_type); Const("@caml_exn", Address addr_type)|] Nothing;
+(* insert (Lextcall (Const("@llvm.eh.sjlj.longjmp", Function(Void, [Address byte]))))
+ [|cast (Const("@caml_jump_buffer", Address Jump_buffer)) (Address byte)|] Nothing;
+ *)
+ insert (Lextcall (Const("@longjmp", Function(Void, [Address byte; Integer 32]))))
+ [|cast (Const("@caml_jump_buffer", Address Jump_buffer)) (Address byte); Const("1", Integer 32)|] Nothing;
insert_simple Lunreachable;
Array.iteri
(fun i block ->
@@ -229,19 +235,29 @@ let rec linear i =
insert_simple (Lcomment s)
| 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 Lstore [|cast exn addr_type; Const("@caml_exn", Address addr_type)|] Nothing;
+ (*
+ insert (Lextcall (Const("@llvm.eh.sjlj.longjmp", Function(Void, [Address byte]))))
+ [|cast (Const("@caml_jump_buffer", Address Jump_buffer)) (Address byte)|] Nothing;
+ *)
+ insert (Lextcall (Const("@longjmp", Function(Void, [Address byte; Integer 32]))))
+ [|cast (Const("@caml_jump_buffer", Address Jump_buffer)) (Address byte); Const("1", Integer 32)|] Nothing;
+ insert_simple Lunreachable
| 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 *)
let old_jmp_buf = alloca (register "old_jmp_buf" (Address Jump_buffer)) in
- let temp_buf = load (Const("@jmp_buf", Address Jump_buffer)) (register "" Jump_buffer) in
+ let temp_buf = load (Const("@caml_jump_buffer", Address Jump_buffer)) (register "" Jump_buffer) in
insert Lstore [|temp_buf; old_jmp_buf|] Nothing;
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;
+ [|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 (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;
@@ -260,7 +276,9 @@ let rec linear i =
branch cont_lbl;
label cont_lbl;
- if typ <> Void then insert Lload [|tmp|] res
+ if typ <> Void then insert Lload [|tmp|] res;
+ let temp_buf = load old_jmp_buf (register "" Jump_buffer) in
+ insert Lstore [|temp_buf; Const("@caml_jump_buffer", Address Jump_buffer)|] Nothing
| Icatch(i, body, handler), [||] ->
let c = c () in
Hashtbl.add exits i c;
@@ -288,18 +306,25 @@ let rec linear i =
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)*) res in
+ let young_limit = load caml_young_limit (register "young_limit" addr_type) in
+ let young_ptr = load caml_young_ptr (register "young_ptr" addr_type) in
+ let nyp = getelemptr young_ptr (Const(string_of_int (-len), int_type)) (register "" (typeof young_ptr)) in
+ insert Lstore [|nyp; caml_young_ptr|] Nothing;
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;
+
label collect_lbl;
insert_simple (Lextcall (Const("@caml_call_gc", Function(Void, []))));
- branch begin_lbl;
+ let young_ptr = load caml_young_ptr (register "young_ptr" addr_type) in
+ let nyp = getelemptr young_ptr (Const(string_of_int (-len), int_type)) (register "" (typeof young_ptr)) in
+ insert Lstore [|nyp; caml_young_ptr|] Nothing;
+ branch continue_lbl;
+
label continue_lbl;
- insert Lstore [|nyp; Const("@caml_young_ptr", Address addr_type)|] Nothing
+ insert Lload [|caml_young_ptr|] res
(*
let alloc, args =
match len with
@@ -312,7 +337,6 @@ let rec linear i =
(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
@@ -364,9 +364,8 @@ let rec compile_instr seq instr =
print_debug "Ctrywith";
let try_seq = ref [] in
let with_seq = ref [] in
- (* TODO figure out what to do with id *)
ignore (compile_instr try_seq try_expr);
- ignore (insert with_seq Iload [|Const("@exn", Address addr_type)|] (Const("%" ^ translate_id id, addr_type)) addr_type);
+ ignore (insert with_seq Igetelementptr [|Const("@caml_exn", Address addr_type); Const("0", int_type)|] (Reg(translate_id id, addr_type)) addr_type);
ignore (compile_instr with_seq with_expr);
let try_instrs = reverse_instrs try_seq in
let with_instrs = reverse_instrs with_seq in
View
@@ -189,12 +189,18 @@ let fundecl = function { fun_name = name; fun_args = args; fun_body = body } ->
*)
let header =
let addr_type = string_of_type addr_type in
+ let undef = addr_type ^ " undef" in
[ "; vim: set ft=llvm:"
+ (*
; "%jump_buf_t = type [5 x " ^ addr_type ^ "]"
+ *)
+ ; "%jump_buf_t = type [25 x " ^ addr_type ^ "]"
; "declare double @fabs(double) nounwind"
; "declare void @llvm.gcroot(i8**, i8*) nounwind"
; "declare i32 @llvm.eh.sjlj.setjmp(i8*) nounwind"
; "declare void @llvm.eh.sjlj.longjmp(i8*) nounwind"
+ ; "declare void @longjmp(i8*, i32) nounwind noreturn"
+ ; "declare i32 @setjmp(i8*) nounwind returns_twice"
; "declare " ^ calling_conv ^ " " ^ addr_type ^ " @caml_alloc1() nounwind"
; "declare " ^ calling_conv ^ " " ^ addr_type ^ " @caml_alloc2() nounwind"
; "declare " ^ calling_conv ^ " " ^ addr_type ^ " @caml_alloc3() nounwind"
@@ -206,8 +212,11 @@ let header =
; "@caml_young_limit = external global " ^ addr_type
; "@caml_bottom_of_stack = external global " ^ addr_type
; "@caml_last_return_address = external global " ^ addr_type
- ; "@exn = external global " ^ addr_type
- ; "@jmp_buf = external global %jump_buf_t"
+ ; "@caml_exn = external global " ^ addr_type
+(*
+ ; "@caml_jump_buffer = external global %jump_buf_t"
+ *)
+ ; "@caml_jump_buffer = external global %jump_buf_t"
]
let constants : string list ref = ref []
View
@@ -350,23 +350,31 @@ FUNCTION(G(caml_start_program))
/* Setup alloc ptr and exception ptr */
LOAD_VAR(caml_young_ptr, %r15)
LOAD_VAR(caml_exception_pointer, %r14)
-#endif
- /* TODO figure out what to do when using LLVM */
/* Build an exception handler */
lea .L108(%rip), %r13
pushq %r13
pushq %r14
movq %rsp, %r14
+#else
+ movq caml_jump_buffer@GOTPCREL(%rip), %rdi
+ callq setjmp@plt
+ testq %rax, %rax
+ jnz .Lfoobar /* if rax = 0 this is the first return */
+#endif
/* Call the Caml code */
call *%r12
.L107:
+#ifndef LLVM
/* Pop the exception handler */
popq %r14
popq %r12 /* dummy register */
+#endif
.L109:
+#ifndef LLVM
/* Update alloc ptr and exception ptr */
STORE_VAR(%r15,caml_young_ptr)
STORE_VAR(%r14,caml_exception_pointer)
+#endif
/* Pop the callback link, restoring the global variables */
POP_VAR(caml_bottom_of_stack)
POP_VAR(caml_last_return_address)
@@ -382,14 +390,18 @@ FUNCTION(G(caml_start_program))
popq %rbx
/* Return to caller. */
ret
+.Lfoobar:
+ /* move the pointer to the exception into the first argument register */
+ movq caml_exn@GOTPCREL(%rip), %rax
.L108:
/* Exception handler*/
/* Mark the bucket as an exception result and return it */
orq $2, %rax
- jmp .L109
+ jmp .L109
-/* Raise an exception from Caml */
+/* Raise an exception from Caml */
+#ifndef LLVM
FUNCTION(G(caml_raise_exn))
TESTL_VAR($1, caml_backtrace_active)
jne .L110
@@ -407,9 +419,31 @@ FUNCTION(G(caml_raise_exn))
movq %r14, %rsp
popq %r14
ret
+#else
+FUNCTION(G(caml_raise_exn))
+ TESTL_VAR($1, caml_backtrace_active)
+ jne .L110
+ movq caml_jump_buffer@GOTPCREL(%rip), %rdi
+ movq $1, %rsi
+ callq longjmp@plt
+.L110:
+ jmp .L110
+ /* TODO figure out how to allow backtraces */
+ movq %rax, %r12 /* Save exception bucket */
+ movq %rax, %rdi /* arg 1: exception bucket */
+ movq 0(%rsp), %rsi /* arg 2: pc of raise */
+ leaq 8(%rsp), %rdx /* arg 3: sp of raise */
+ movq %r14, %rcx /* arg 4: sp of handler */
+ call GCALL(caml_stash_backtrace)
+ movq %r12, %rax /* Recover exception bucket */
+ movq %r14, %rsp
+ popq %r14
+ ret
+#endif
/* Raise an exception from C */
+#ifndef LLVM
FUNCTION(G(caml_raise_exception))
TESTL_VAR($1, caml_backtrace_active)
jne .L111
@@ -430,6 +464,30 @@ FUNCTION(G(caml_raise_exception))
popq %r14 /* Recover previous exception handler */
LOAD_VAR(caml_young_ptr,%r15) /* Reload alloc ptr */
ret
+#else
+FUNCTION(G(caml_raise_exception))
+ TESTL_VAR($1, caml_backtrace_active)
+ jne .L111
+ movq caml_exn@GOTPCREL(%rip), %rsi
+ movq %rdi, (%rsi)
+ movq caml_jump_buffer@GOTPCREL(%rip), %rdi
+ movq $1, %rsi
+ callq longjmp@plt
+.L111:
+ jmp .L111
+ /* TODO figure out how to allow backtraces */
+ movq %rdi, %r12 /* Save exception bucket */
+ /* arg 1: exception bucket */
+ LOAD_VAR(caml_last_return_address,%rsi) /* arg 2: pc of raise */
+ LOAD_VAR(caml_bottom_of_stack,%rdx) /* arg 3: sp of raise */
+ LOAD_VAR(caml_exception_pointer,%rcx) /* arg 4: sp of handler */
+ call GCALL(caml_stash_backtrace)
+ movq %r12, %rax /* Recover exception bucket */
+ LOAD_VAR(caml_exception_pointer,%rsp)
+ popq %r14 /* Recover previous exception handler */
+ LOAD_VAR(caml_young_ptr,%r15) /* Reload alloc ptr */
+ ret
+#endif
/* Callback from C to Caml */
View
@@ -17,6 +17,7 @@
#include <stdio.h>
#include <stdlib.h>
+#include <setjmp.h>
#include "callback.h"
#include "backtrace.h"
#include "custom.h"
@@ -36,7 +37,8 @@
#include "ui.h"
#endif
-uintnat exn;
+uintnat caml_exn;
+jmp_buf caml_jump_buffer;
extern int caml_parser_trace;
CAMLexport header_t caml_atom_table[256];
char * caml_code_area_start, * caml_code_area_end;

0 comments on commit 00cc620

Please sign in to comment.