Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Introduce domain state and steal exception pointer

master
KC Sivaramakrishnan 2019-06-03 17:26:45 +05:30
parent f69e08ec75
commit fc6f028492
20 changed files with 307 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
Makefile
View File

@ -77,14 +77,12 @@ DEPINCLUDES=$(INCLUDES)
OCAMLDOC_OPT=$(WITH_OCAMLDOC:=.opt)
UTILS=utils/config.cmo utils/build_path_prefix_map.cmo utils/misc.cmo \
utils/identifiable.cmo utils/numbers.cmo utils/arg_helper.cmo \
utils/clflags.cmo utils/profile.cmo \
utils/load_path.cmo \
utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \
utils/consistbl.cmo \
utils/strongly_connected_components.cmo \
utils/targetint.cmo \
utils/int_replace_polymorphic_compare.cmo
utils/identifiable.cmo utils/numbers.cmo utils/arg_helper.cmo \
utils/clflags.cmo utils/profile.cmo utils/load_path.cmo \
utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \
utils/consistbl.cmo utils/strongly_connected_components.cmo \
utils/targetint.cmo utils/int_replace_polymorphic_compare.cmo \
utils/domainstate.cmo
PARSING=parsing/location.cmo parsing/longident.cmo \
parsing/docstrings.cmo parsing/syntaxerr.cmo \
@ -338,12 +336,18 @@ reconfigure:
./configure $(CONFIGURE_ARGS)
endif
utils/domainstate.ml: utils/domainstate.ml.c runtime/caml/domain_state.tbl
$(CPP) -I runtime/caml $< > $@
utils/domainstate.mli: utils/domainstate.mli.c utils/domainstate.ml runtime/caml/domain_state.tbl
$(CPP) -I runtime/caml $< > $@
.PHONY: partialclean
partialclean::
rm -f utils/config.ml
rm -f utils/config.ml utils/domainstate.ml utils/domainstate.mli
.PHONY: beforedepend
beforedepend:: utils/config.ml
beforedepend:: utils/config.ml utils/domainstate.ml utils/domainstate.mli
# Start up the system from the distribution compiler
.PHONY: coldstart

22
asmcomp/amd64/emit.mlp
View File

@ -154,6 +154,9 @@ let load_symbol_addr s arg =
else
I.mov (sym (emit_symbol s)) arg
let domain_field f =
mem64 QWORD (Domainstate.idx_of_field f * 8) R14
(* Output a label *)
let emit_label lbl =
@ -887,15 +890,15 @@ let emit_instr fallthrough i =
else
I.mov (sym (emit_label s)) arg
in
cfi_adjust_cfa_offset 16;
I.sub (int 16) rsp;
load_label_addr lbl_handler r11;
cfi_adjust_cfa_offset 8;
I.push r11;
cfi_adjust_cfa_offset 8;
I.push (domain_field Domainstate.Domain_exn_handler);
I.mov rsp (domain_field Domainstate.Domain_exn_handler);
stack_offset := !stack_offset + 16;
I.mov r14 (mem64 QWORD 0 RSP);
load_label_addr lbl_handler r14;
I.mov r14 (mem64 QWORD 8 RSP);
I.mov rsp r14
| Lpoptrap ->
I.pop r14;
I.pop (domain_field Domainstate.Domain_exn_handler);
cfi_adjust_cfa_offset (-8);
I.add (int 8) rsp;
cfi_adjust_cfa_offset (-8);
@ -909,8 +912,8 @@ let emit_instr fallthrough i =
emit_call "caml_raise_exn";
record_frame Reg.Set.empty true i.dbg
| Cmm.Raise_notrace ->
I.mov r14 rsp;
I.pop r14;
I.mov (domain_field Domainstate.Domain_exn_handler) rsp;
I.pop (domain_field Domainstate.Domain_exn_handler);
I.pop r11;
I.jmp r11
end
@ -1001,7 +1004,6 @@ let begin_assembly() =
if system = S_win64 then begin
D.extrn "caml_young_ptr" QWORD;
D.extrn "caml_young_limit" QWORD;
D.extrn "caml_exception_pointer" QWORD;
D.extrn "caml_call_gc" NEAR;
D.extrn "caml_call_gc1" NEAR;
D.extrn "caml_call_gc2" NEAR;

7
otherlibs/systhreads/st_stubs.c
View File

@ -19,6 +19,7 @@
#include "caml/backtrace.h"
#include "caml/callback.h"
#include "caml/custom.h"
#include "caml/domain.h"
#include "caml/fail.h"
#include "caml/io.h"
#include "caml/memory.h"
@ -78,7 +79,7 @@ struct caml_thread_struct {
char * bottom_of_stack; /* Saved value of caml_bottom_of_stack */
uintnat last_retaddr; /* Saved value of caml_last_return_address */
value * gc_regs; /* Saved value of caml_gc_regs */
char * exception_pointer; /* Saved value of caml_exception_pointer */
char * exception_pointer; /* Saved value of Caml_state->exn_handler */
struct caml__roots_block * local_roots; /* Saved value of local_roots */
struct longjmp_buffer * exit_buf; /* For thread exit */
#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
@ -177,7 +178,7 @@ static inline void caml_thread_save_runtime_state(void)
curr_thread->bottom_of_stack = caml_bottom_of_stack;
curr_thread->last_retaddr = caml_last_return_address;
curr_thread->gc_regs = caml_gc_regs;
curr_thread->exception_pointer = caml_exception_pointer;
curr_thread->exception_pointer = Caml_state->exn_handler;
curr_thread->local_roots = caml_local_roots;
#ifdef WITH_SPACETIME
curr_thread->spacetime_trie_node_ptr
@ -207,7 +208,7 @@ static inline void caml_thread_restore_runtime_state(void)
caml_bottom_of_stack= curr_thread->bottom_of_stack;
caml_last_return_address = curr_thread->last_retaddr;
caml_gc_regs = curr_thread->gc_regs;
caml_exception_pointer = curr_thread->exception_pointer;
Caml_state->exn_handler = curr_thread->exception_pointer;
caml_local_roots = curr_thread->local_roots;
#ifdef WITH_SPACETIME
caml_spacetime_trie_node_ptr

4
runtime/Makefile
View File

@ -26,7 +26,7 @@ BYTECODE_C_SOURCES := $(addsuffix .c, \
signals_byt printexc backtrace_byt backtrace compare ints \
floats str array io extern intern hash sys meta parsing gc_ctrl md5 obj \
lexing callback debugger weak compact finalise custom dynlink \
spacetime_byt afl $(UNIX_OR_WIN32) bigarray main memprof)
spacetime_byt afl $(UNIX_OR_WIN32) bigarray main memprof domain)
NATIVE_C_SOURCES := $(addsuffix .c, \
startup_aux startup_nat main fail_nat roots_nat signals \
@ -35,7 +35,7 @@ NATIVE_C_SOURCES := $(addsuffix .c, \
lexing $(UNIX_OR_WIN32) printexc callback weak compact finalise custom \
globroots backtrace_nat backtrace dynlink_nat debugger meta \
dynlink clambda_checks spacetime_nat spacetime_snapshot afl bigarray \
memprof)
memprof domain)
# The other_files variable stores the list of files whose dependencies
# should be computed by `make depend` although they do not need to be

97
runtime/amd64.S
View File

@ -112,6 +112,18 @@
#endif
#define CAML_CONFIG_H_NO_TYPEDEFS
#include "../runtime/caml/config.h"
.set domain_curr_field, 0
#define DOMAIN_STATE(c_type, name) \
.equ domain_field_caml_##name, domain_curr_field ; \
.set domain_curr_field, domain_curr_field + 1
#include "../runtime/caml/domain_state.tbl"
#undef DOMAIN_STATE
#define Caml_state(var) (8*domain_field_caml_##var)(%r14)
#if defined(__PIC__) && !defined(SYS_mingw64) && !defined(SYS_cygwin)
/* Position-independent operations on global variables. */
@ -345,9 +357,8 @@ LBL(caml_call_gc):
pushq %rbx; CFI_ADJUST (8);
pushq %rax; CFI_ADJUST (8);
STORE_VAR(%rsp, caml_gc_regs)
/* Save caml_young_ptr, caml_exception_pointer */
/* Save caml_young_ptr */
STORE_VAR(%r15, caml_young_ptr)
STORE_VAR(%r14, caml_exception_pointer)
#ifdef WITH_SPACETIME
STORE_VAR(%r13, caml_spacetime_trie_node_ptr)
#endif
@ -373,9 +384,8 @@ LBL(caml_call_gc):
PREPARE_FOR_C_CALL
call GCALL(caml_garbage_collection)
CLEANUP_AFTER_C_CALL
/* Restore caml_young_ptr, caml_exception_pointer */
/* Restore caml_young_ptr */
LOAD_VAR(caml_young_ptr, %r15)
LOAD_VAR(caml_exception_pointer, %r14)
/* Restore all regs used by the code generator */
movsd 0*8(%rsp), %xmm0
movsd 1*8(%rsp), %xmm1
@ -543,9 +553,8 @@ LBL(caml_c_call):
subq $(STACK_PROBE_SIZE), %rsp; CFI_ADJUST(STACK_PROBE_SIZE);
movq %rax, 0(%rsp)
addq $(STACK_PROBE_SIZE), %rsp; CFI_ADJUST(-STACK_PROBE_SIZE);
/* Make the exception handler and alloc ptr available to the C code */
/* Make the alloc ptr available to the C code */
STORE_VAR(%r15, caml_young_ptr)
STORE_VAR(%r14, caml_exception_pointer)
/* Call the function (address in %rax) */
/* No need to PREPARE_FOR_C_CALL since the caller already
reserved the stack space if needed (cf. amd64/proc.ml) */
@ -559,6 +568,8 @@ FUNCTION(G(caml_start_program))
CFI_STARTPROC
/* Save callee-save registers */
PUSH_CALLEE_SAVE_REGS
/* Load Caml_state into r14 (was passed as an argument from C) */
movq C_ARG_1, %r14
/* Initial entry point is G(caml_program) */
LEA_VAR(caml_program, %r12)
/* Common code for caml_start_program and caml_callback* */
@ -587,14 +598,13 @@ LBL(caml_start_program):
popq %rbx; CFI_ADJUST (-8)
popq %rax; CFI_ADJUST (-8)
#endif
/* Setup alloc ptr and exception ptr */
/* Setup alloc ptr */
LOAD_VAR(caml_young_ptr, %r15)
LOAD_VAR(caml_exception_pointer, %r14)
/* Build an exception handler */
lea LBL(108)(%rip), %r13
pushq %r13; CFI_ADJUST(8)
pushq %r14; CFI_ADJUST(8)
movq %rsp, %r14
pushq Caml_state(exn_handler); CFI_ADJUST(8)
movq %rsp, Caml_state(exn_handler)
#ifdef WITH_SPACETIME
LOAD_VAR(caml_spacetime_trie_node_ptr, %r13)
#endif
@ -602,12 +612,11 @@ LBL(caml_start_program):
call *%r12
LBL(107):
/* Pop the exception handler */
popq %r14; CFI_ADJUST(-8)
popq Caml_state(exn_handler); CFI_ADJUST(-8)
popq %r12; CFI_ADJUST(-8) /* dummy register */
LBL(109):
/* Update alloc ptr and exception ptr */
/* Update alloc ptr */
STORE_VAR(%r15,caml_young_ptr)
STORE_VAR(%r14,caml_exception_pointer)
/* Pop the callback link, restoring the global variables */
POP_VAR(caml_bottom_of_stack)
POP_VAR(caml_last_return_address)
@ -635,8 +644,8 @@ FUNCTION(G(caml_raise_exn))
CFI_STARTPROC
TESTL_VAR($1, caml_backtrace_active)
jne LBL(110)
movq %r14, %rsp
popq %r14
movq Caml_state(exn_handler), %rsp
popq Caml_state(exn_handler)
ret
LBL(110):
movq %rax, %r12 /* Save exception bucket */
@ -649,14 +658,14 @@ LBL(110):
popq C_ARG_2 /* arg 2: pc of raise */
movq %rsp, C_ARG_3 /* arg 3: sp at raise */
#endif
movq %r14, C_ARG_4 /* arg 4: sp of handler */
movq Caml_state(exn_handler), C_ARG_4 /* arg 4: sp of handler */
/* PR#5700: thanks to popq above, stack is now 16-aligned */
/* Thanks to ENTER_FUNCTION, stack is now 16-aligned */
PREPARE_FOR_C_CALL /* no need to cleanup after */
call GCALL(caml_stash_backtrace)
movq %r12, %rax /* Recover exception bucket */
movq %r14, %rsp
popq %r14
movq Caml_state(exn_handler), %rsp
popq Caml_state(exn_handler)
ret
CFI_ENDPROC
ENDFUNCTION(G(caml_raise_exn))
@ -665,30 +674,32 @@ ENDFUNCTION(G(caml_raise_exn))
FUNCTION(G(caml_raise_exception))
CFI_STARTPROC
movq C_ARG_1, %r14 /* Caml_state */
TESTL_VAR($1, caml_backtrace_active)
jne LBL(112)
movq C_ARG_1, %rax
LOAD_VAR(caml_exception_pointer, %rsp) /* Cut stack */
popq %r14 /* Recover previous exception handler */
movq C_ARG_2, %rax
movq Caml_state(exn_handler), %rsp /* Cut stack */
popq Caml_state(exn_handler) /* Recover previous exception handler */
LOAD_VAR(caml_young_ptr, %r15) /* Reload alloc ptr */
ret
LBL(112):
#ifdef WITH_FRAME_POINTERS
ENTER_FUNCTION ;
#endif
movq C_ARG_1, %r12 /* Save exception bucket */
/* arg 1: exception bucket */
/* Save exception bucket. Caml_state in r14 saved across C calls. */
movq C_ARG_2, %r12
movq C_ARG_2, C_ARG_1 /* arg 1: exception bucket */
LOAD_VAR(caml_last_return_address,C_ARG_2) /* arg 2: pc of raise */
LOAD_VAR(caml_bottom_of_stack,C_ARG_3) /* arg 3: sp of raise */
LOAD_VAR(caml_exception_pointer,C_ARG_4) /* arg 4: sp of handler */
movq Caml_state(exn_handler), C_ARG_4 /* arg 4: sp of handler */
#ifndef WITH_FRAME_POINTERS
subq $8, %rsp /* PR#5700: maintain stack alignment */
#endif
PREPARE_FOR_C_CALL /* no need to cleanup after */
call GCALL(caml_stash_backtrace)
movq %r12, %rax /* Recover exception bucket */
LOAD_VAR(caml_exception_pointer,%rsp)
popq %r14 /* Recover previous exception handler */
movq Caml_state(exn_handler), %rsp
popq Caml_state(exn_handler) /* Recover previous exception handler */
LOAD_VAR(caml_young_ptr,%r15) /* Reload alloc ptr */
ret
CFI_ENDPROC
@ -701,48 +712,52 @@ ENDFUNCTION(G(caml_raise_exception))
backtrace anyway. */
FUNCTION(G(caml_stack_overflow))
movq C_ARG_1, %r14 /* Caml_state */
LEA_VAR(caml_exn_Stack_overflow, %rax)
movq %r14, %rsp /* cut the stack */
popq %r14 /* recover previous exn handler */
ret /* jump to handler's code */
movq Caml_state(exn_handler), %rsp /* cut the stack */
popq Caml_state(exn_handler) /* recover previous exn handler */
ret /* jump to handler's code */
ENDFUNCTION(G(caml_stack_overflow))
/* Callback from C to OCaml */
FUNCTION(G(caml_callback_exn))
FUNCTION(G(caml_callback_asm))
CFI_STARTPROC
/* Save callee-save registers */
PUSH_CALLEE_SAVE_REGS
/* Initial loading of arguments */
movq C_ARG_1, %rbx /* closure */
movq C_ARG_2, %rax /* argument */
movq C_ARG_1, %r14 /* Caml_state */
movq C_ARG_2, %rbx /* closure */
movq 0(C_ARG_3), %rax /* argument */
movq 0(%rbx), %r12 /* code pointer */
jmp LBL(caml_start_program)
CFI_ENDPROC
ENDFUNCTION(G(caml_callback_exn))
FUNCTION(G(caml_callback2_exn))
FUNCTION(G(caml_callback2_asm))
CFI_STARTPROC
/* Save callee-save registers */
PUSH_CALLEE_SAVE_REGS
/* Initial loading of arguments */
movq C_ARG_1, %rdi /* closure -- no op with Unix conventions */
movq C_ARG_2, %rax /* first argument */
movq C_ARG_3, %rbx /* second argument */
movq C_ARG_1, %r14 /* Caml_state */
movq C_ARG_2, %rdi /* closure */
movq 0(C_ARG_3), %rax /* first argument */
movq 8(C_ARG_3), %rbx /* second argument */
LEA_VAR(caml_apply2, %r12) /* code pointer */
jmp LBL(caml_start_program)
CFI_ENDPROC
ENDFUNCTION(G(caml_callback2_exn))
FUNCTION(G(caml_callback3_exn))
FUNCTION(G(caml_callback3_asm))
CFI_STARTPROC
/* Save callee-save registers */
PUSH_CALLEE_SAVE_REGS
/* Initial loading of arguments */
movq C_ARG_2, %rax /* first argument */
movq C_ARG_3, %rbx /* second argument */
movq C_ARG_1, %rsi /* closure */
movq C_ARG_4, %rdi /* third argument */
movq C_ARG_1, %r14 /* Caml_state */
movq 0(C_ARG_3), %rax /* first argument */
movq 8(C_ARG_3), %rbx /* second argument */
movq C_ARG_2, %rsi /* closure */
movq 16(C_ARG_3), %rdi /* third argument */
LEA_VAR(caml_apply3, %r12) /* code pointer */
jmp LBL(caml_start_program)
CFI_ENDPROC

26
runtime/callback.c
View File

@ -19,6 +19,7 @@
#include <string.h>
#include "caml/callback.h"
#include "caml/domain.h"
#include "caml/fail.h"
#include "caml/memory.h"
#include "caml/mlvalues.h"
@ -131,7 +132,30 @@ CAMLexport value caml_callback3_exn(value closure,
#else
/* Native-code callbacks. caml_callback[123]_exn are implemented in asm. */
/* Native-code callbacks. */
typedef value (callback_stub)(caml_domain_state* state, value closure, value* args);
callback_stub caml_callback_asm, caml_callback2_asm, caml_callback3_asm;
CAMLexport value caml_callback_exn(value closure, value arg)
{
return caml_callback_asm(Caml_state, closure, &arg);
}
CAMLexport value caml_callback2_exn(value closure, value arg1, value arg2)
{
value args[] = {arg1, arg2};
return caml_callback2_asm(Caml_state, closure, args);
}
CAMLexport value caml_callback3_exn(value closure,
value arg1, value arg2, value arg3)
{
value args[] = {arg1, arg2, arg3};
return caml_callback3_asm(Caml_state, closure, args);
}
CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
{

4
runtime/caml/config.h
View File

@ -47,6 +47,8 @@
#include "compatibility.h"
#endif
#ifndef CAML_CONFIG_H_NO_TYPEDEFS
#include <stddef.h>
#if defined(HAS_LOCALE_H) || defined(HAS_XLOCALE_H)
@ -139,6 +141,8 @@ typedef uint64_t uintnat;
#error "No integer type available to represent pointers"
#endif
#endif /* CAML_CONFIG_H_NO_TYPEDEFS */
/* Endianness of floats */
/* ARCH_FLOAT_ENDIANNESS encodes the byte order of doubles as follows:

37
runtime/caml/domain.h Normal file
View File

@ -0,0 +1,37 @@
/**************************************************************************/
/* */
/* OCaml */
/* */
/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */
/* */
/* Copyright 1996 Institut National de Recherche en Informatique et */
/* en Automatique. */
/* */
/* All rights reserved. This file is distributed under the terms of */
/* the GNU Lesser General Public License version 2.1, with the */
/* special exception on linking described in the file LICENSE. */
/* */
/**************************************************************************/
#ifndef CAML_DOMAIN_H
#define CAML_DOMAIN_H
#ifdef __cplusplus
extern "C" {
#endif
#ifdef CAML_INTERNALS
#include "domain_state.h"
CAMLextern caml_domain_state* Caml_state;
void caml_init_domain(void);
#endif /* CAML_INTERNALS */
#ifdef __cplusplus
}
#endif
#endif /* CAML_DOMAIN_H */

44
runtime/caml/domain_state.h Normal file
View File

@ -0,0 +1,44 @@
/**************************************************************************/
/* */
/* OCaml */
/* */
/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */
/* */
/* Copyright 1996 Institut National de Recherche en Informatique et */
/* en Automatique. */
/* */
/* All rights reserved. This file is distributed under the terms of */
/* the GNU Lesser General Public License version 2.1, with the */
/* special exception on linking described in the file LICENSE. */
/* */
/**************************************************************************/
#ifndef CAML_STATE_H
#define CAML_STATE_H
#include <stddef.h>
#include "misc.h"
/* This structure sits in the TLS area and is also accessed efficiently
* via native code, which is why the indices are important */
typedef struct {
#define DOMAIN_STATE(type, name) CAMLalign(8) type name;
#include "domain_state.tbl"
#undef DOMAIN_STATE
} caml_domain_state;
enum {
Domain_state_num_fields =
#define DOMAIN_STATE(type, name) + 1
#include "domain_state.tbl"
#undef DOMAIN_STATE
};
/* Check that the structure was laid out without padding,
since the runtime assumes this in computing offsets */
CAML_STATIC_ASSERT(
sizeof(caml_domain_state) ==
(Domain_state_num_fields
) * 8);
#endif /* CAML_STATE_H */

2
runtime/caml/domain_state.tbl Normal file
View File

@ -0,0 +1,2 @@
DOMAIN_STATE(char*, exn_handler)
/* Exception pointer that points into the current stack */

34
runtime/caml/misc.h
View File

@ -83,6 +83,35 @@ typedef char * addr;
#define CAMLweakdef
#endif
/* Alignment */
#if defined(__GNUC__)
#define CAMLalign(n) __attribute__((aligned(n)))
#else
#error "How do I align values on this platform?"
#endif
/* CAMLunused is preserved for compatibility reasons.
Instead of the legacy GCC/Clang-only
CAMLunused foo;
you should prefer
CAMLunused_start foo CAMLunused_end;
which supports both GCC/Clang and MSVC.
*/
#if defined(__GNUC__) && (__GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ > 7))
#define CAMLunused_start __attribute__ ((unused))
#define CAMLunused_end
#define CAMLunused __attribute__ ((unused))
#elif _MSC_VER >= 1500
#define CAMLunused_start __pragma( warning (push) ) \
__pragma( warning (disable:4189 ) )
#define CAMLunused_end __pragma( warning (pop))
#define CAMLunused
#else
#define CAMLunused_start
#define CAMLunused_end
#define CAMLunused
#endif
#ifdef __cplusplus
extern "C" {
#endif
@ -95,6 +124,11 @@ extern caml_timing_hook caml_major_slice_begin_hook, caml_major_slice_end_hook;
extern caml_timing_hook caml_minor_gc_begin_hook, caml_minor_gc_end_hook;
extern caml_timing_hook caml_finalise_begin_hook, caml_finalise_end_hook;
#define CAML_STATIC_ASSERT_3(b, l) \
typedef CAMLunused_start char static_assertion_failure_line_##l[(b) ? 1 : -1] CAMLunused_end
#define CAML_STATIC_ASSERT_2(b, l) CAML_STATIC_ASSERT_3(b, l)
#define CAML_STATIC_ASSERT(b) CAML_STATIC_ASSERT_2(b, __LINE__)
/* Windows Unicode support (rest below - char_os is needed earlier) */
#ifdef _WIN32

1
runtime/caml/stack.h
View File

@ -111,7 +111,6 @@ extern char * caml_top_of_stack;
extern char * caml_bottom_of_stack;
extern uintnat caml_last_return_address;
extern value * caml_gc_regs;
extern char * caml_exception_pointer;
extern value * caml_globals[];
extern char caml_globals_map[];
extern intnat caml_globals_inited;

29
runtime/domain.c Normal file
View File

@ -0,0 +1,29 @@
/**************************************************************************/
/* */
/* OCaml */
/* */
/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */
/* */
/* Copyright 1996 Institut National de Recherche en Informatique et */
/* en Automatique. */
/* */
/* All rights reserved. This file is distributed under the terms of */
/* the GNU Lesser General Public License version 2.1, with the */
/* special exception on linking described in the file LICENSE. */
/* */
/**************************************************************************/
#define CAML_INTERNALS
#include "caml/domain_state.h"
#include "caml/memory.h"
CAMLexport caml_domain_state* Caml_state;
void caml_init_domain ()
{
Caml_state = (caml_domain_state*)caml_stat_alloc_noexc(sizeof(caml_domain_state));
if (Caml_state == NULL) {
caml_fatal_error ("cannot initialize domain state");
}
}

11
runtime/fail_nat.c
View File

@ -20,6 +20,7 @@
#include <stdio.h>
#include <signal.h>
#include "caml/alloc.h"
#include "caml/domain.h"
#include "caml/fail.h"
#include "caml/io.h"
#include "caml/gc.h"
@ -52,22 +53,20 @@ extern caml_generated_constant
/* Exception raising */
CAMLnoreturn_start
extern void caml_raise_exception (value bucket)
extern void caml_raise_exception (caml_domain_state* state, value bucket)
CAMLnoreturn_end;
char * caml_exception_pointer = NULL;
void caml_raise(value v)
{
Unlock_exn();
if (caml_exception_pointer == NULL) caml_fatal_uncaught_exception(v);
if (Caml_state->exn_handler == NULL) caml_fatal_uncaught_exception(v);
while (caml_local_roots != NULL &&
(char *) caml_local_roots < caml_exception_pointer) {
(char *) caml_local_roots < Caml_state->exn_handler) {
caml_local_roots = caml_local_roots->next;
}
caml_raise_exception(v);
caml_raise_exception(Caml_state, v);
}
void caml_raise_constant(value tag)

3
runtime/signals_nat.c
View File

@ -182,7 +182,6 @@ DECLARE_SIGNAL_HANDLER(trap_handler)
caml_sigmask_hook(SIG_UNBLOCK, &mask, NULL);
}
#endif
caml_exception_pointer = (char *) CONTEXT_EXCEPTION_POINTER;
caml_young_ptr = (value *) CONTEXT_YOUNG_PTR;
caml_bottom_of_stack = (char *) CONTEXT_SP;
caml_last_return_address = (uintnat) CONTEXT_PC;
@ -234,6 +233,7 @@ DECLARE_SIGNAL_HANDLER(segv_handler)
handler, we jump to the asm function [caml_stack_overflow]
(from $ARCH.S). */
#ifdef CONTEXT_PC
CONTEXT_C_ARG_1 = (context_reg) Caml_state;
CONTEXT_PC = (context_reg) &caml_stack_overflow;
#else
#error "CONTEXT_PC must be defined if RETURN_AFTER_STACK_OVERFLOW is"
@ -241,7 +241,6 @@ DECLARE_SIGNAL_HANDLER(segv_handler)
#else
/* Raise a Stack_overflow exception straight from this signal handler */
#if defined(CONTEXT_YOUNG_PTR) && defined(CONTEXT_EXCEPTION_POINTER)
caml_exception_pointer = (char *) CONTEXT_EXCEPTION_POINTER;
caml_young_ptr = (value *) CONTEXT_YOUNG_PTR;
#endif
caml_raise_stack_overflow();

14
runtime/signals_osdep.h
View File

@ -27,8 +27,8 @@
sigact.sa_flags = SA_SIGINFO
typedef greg_t context_reg;
#define CONTEXT_C_ARG_1 (context->uc_mcontext.gregs[REG_RDI])
#define CONTEXT_PC (context->uc_mcontext.gregs[REG_RIP])
#define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.gregs[REG_R14])
#define CONTEXT_YOUNG_PTR (context->uc_mcontext.gregs[REG_R15])
#define CONTEXT_FAULTING_ADDRESS ((char *)context->uc_mcontext.gregs[REG_CR2])
@ -56,7 +56,6 @@
typedef unsigned long long context_reg;
#define CONTEXT_STATE (((ucontext_t *)context)->uc_mcontext->CONTEXT_REG(ss))
#define CONTEXT_PC (CONTEXT_STATE.CONTEXT_REG(rip))
#define CONTEXT_EXCEPTION_POINTER (CONTEXT_STATE.CONTEXT_REG(r14))
#define CONTEXT_YOUNG_PTR (CONTEXT_STATE.CONTEXT_REG(r15))
#define CONTEXT_SP (CONTEXT_STATE.CONTEXT_REG(rsp))
#define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
@ -79,7 +78,6 @@
typedef unsigned long context_reg;
#define CONTEXT_PC (context->uc_mcontext.arm_pc)
#define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.arm_fp)
#define CONTEXT_YOUNG_PTR (context->uc_mcontext.arm_r8)
#define CONTEXT_FAULTING_ADDRESS ((char *) context->uc_mcontext.fault_address)
@ -98,7 +96,6 @@
typedef unsigned long context_reg;
#define CONTEXT_PC (context->uc_mcontext.pc)
#define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.regs[26])
#define CONTEXT_YOUNG_PTR (context->uc_mcontext.regs[27])
#define CONTEXT_FAULTING_ADDRESS ((char *) context->uc_mcontext.fault_address)
@ -117,7 +114,6 @@
typedef unsigned long context_reg;
#define CONTEXT_PC (context->uc_mcontext.mc_gpregs.gp_elr)
#define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.mc_gpregs.gp_x[26])
#define CONTEXT_YOUNG_PTR (context->uc_mcontext.mc_gpregs.gp_x[27])
#define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
@ -137,7 +133,6 @@
typedef greg_t context_reg;
#define CONTEXT_PC (context->uc_mcontext.gregs[REG_RIP])
#define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.gregs[REG_R14])
#define CONTEXT_YOUNG_PTR (context->uc_mcontext.gregs[REG_R15])
#define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
@ -153,7 +148,6 @@
sigact.sa_flags = SA_SIGINFO
#define CONTEXT_PC (context->sc_rip)
#define CONTEXT_EXCEPTION_POINTER (context->sc_r14)
#define CONTEXT_YOUNG_PTR (context->sc_r15)
#define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
@ -170,7 +164,6 @@
sigact.sa_flags = SA_SIGINFO
#define CONTEXT_PC (_UC_MACHINE_PC(context))
#define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.gregs[REG_R14])
#define CONTEXT_YOUNG_PTR (context->uc_mcontext.gregs[REG_R15])
#define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
@ -299,7 +292,6 @@
#define CONTEXT_STATE (CONTEXT_MCONTEXT->CONTEXT_REG(ss))
#define CONTEXT_PC (CONTEXT_STATE.CONTEXT_REG(srr0))
#define CONTEXT_EXCEPTION_POINTER (CONTEXT_STATE.CONTEXT_REG(r29))
#define CONTEXT_YOUNG_LIMIT (CONTEXT_STATE.CONTEXT_REG(r30))
#define CONTEXT_YOUNG_PTR (CONTEXT_STATE.CONTEXT_REG(r31))
#define CONTEXT_SP (CONTEXT_STATE.CONTEXT_REG(r1))
@ -318,7 +310,6 @@
typedef unsigned long context_reg;
#define CONTEXT_PC (context->regs->nip)
#define CONTEXT_EXCEPTION_POINTER (context->regs->gpr[29])
#define CONTEXT_YOUNG_LIMIT (context->regs->gpr[30])
#define CONTEXT_YOUNG_PTR (context->regs->gpr[31])
#define CONTEXT_SP (context->regs->gpr[1])
@ -337,7 +328,6 @@
typedef long context_reg;
#define CONTEXT_PC (_UC_MACHINE_PC(context))
#define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.__gregs[_REG_R29])
#define CONTEXT_YOUNG_LIMIT (context->uc_mcontext.__gregs[_REG_R30])
#define CONTEXT_YOUNG_PTR (context->uc_mcontext.__gregs[_REG_R31])
#define CONTEXT_SP (_UC_MACHINE_SP(context))
@ -358,7 +348,6 @@
typedef unsigned long context_reg;
#define CONTEXT_PC (context->sc_frame.srr0)
#define CONTEXT_EXCEPTION_POINTER (context->sc_frame.fixreg[29])
#define CONTEXT_YOUNG_LIMIT (context->sc_frame.fixreg[30])
#define CONTEXT_YOUNG_PTR (context->sc_frame.fixreg[31])
#define CONTEXT_SP (context->sc_frame.fixreg[1])
@ -375,7 +364,6 @@
typedef unsigned long context_reg;
#define CONTEXT_PC (context->sregs->regs.psw.addr)
#define CONTEXT_EXCEPTION_POINTER (context->sregs->regs.gprs[13])
#define CONTEXT_YOUNG_LIMIT (context->sregs->regs.gprs[10])
#define CONTEXT_YOUNG_PTR (context->sregs->regs.gprs[11])
#define CONTEXT_SP (context->sregs->regs.gprs[15])

5
runtime/startup_byt.c
View File

@ -33,6 +33,7 @@
#include "caml/callback.h"
#include "caml/custom.h"
#include "caml/debugger.h"
#include "caml/domain.h"
#include "caml/dynlink.h"
#include "caml/exec.h"
#include "caml/fail.h"
@ -407,6 +408,8 @@ CAMLexport void caml_main(char_os **argv)
}
/* Read the table of contents (section descriptors) */
caml_read_section_descriptors(fd, &trail);
/* Initialize the domain */
caml_init_domain();
/* Initialize the abstract machine */
caml_init_gc (caml_init_minor_heap_wsz, caml_init_heap_wsz,
caml_init_heap_chunk_sz, caml_init_percent_free,
@ -501,6 +504,8 @@ CAMLexport value caml_startup_code_exn(
exe_name = caml_executable_name();
if (exe_name == NULL) exe_name = caml_search_exe_in_path(argv[0]);
caml_external_raise = NULL;
/* Initialize the domain */
caml_init_domain();
/* Initialize the abstract machine */
caml_init_gc (caml_init_minor_heap_wsz, caml_init_heap_wsz,
caml_init_heap_chunk_sz, caml_init_percent_free,

7
runtime/startup_nat.c
View File

@ -23,6 +23,7 @@
#include "caml/backtrace.h"
#include "caml/custom.h"
#include "caml/debugger.h"
#include "caml/domain.h"
#include "caml/fail.h"
#include "caml/freelist.h"
#include "caml/gc.h"
@ -90,7 +91,7 @@ static void init_static(void)
struct longjmp_buffer caml_termination_jmpbuf;
void (*caml_termination_hook)(void *) = NULL;
extern value caml_start_program (void);
extern value caml_start_program (caml_domain_state*);
extern void caml_init_ieee_floats (void);
extern void caml_init_signals (void);
#ifdef _WIN32
@ -133,6 +134,8 @@ value caml_startup_common(char_os **argv, int pooling)
#endif
caml_init_custom_operations();
caml_top_of_stack = &tos;
/* Initialize the domain */
caml_init_domain();
caml_init_gc (caml_init_minor_heap_wsz, caml_init_heap_wsz,
caml_init_heap_chunk_sz, caml_init_percent_free,
caml_init_max_percent_free, caml_init_major_window,
@ -157,7 +160,7 @@ value caml_startup_common(char_os **argv, int pooling)
if (caml_termination_hook != NULL) caml_termination_hook(NULL);
return Val_unit;
}
return caml_start_program();
return caml_start_program(Caml_state);
}
value caml_startup_exn(char_os **argv)

21
utils/domainstate.ml.c Normal file
View File

@ -0,0 +1,21 @@
#define CAML_CONFIG_H_NO_TYPEDEFS
#include "config.h"
type t =
#define DOMAIN_STATE(type, name) | Domain_##name
#include "domain_state.tbl"
#undef DOMAIN_STATE
let idx_of_field =
let curr = 0 in
#define DOMAIN_STATE(type, name) \
let idx__##name = curr in \
let curr = curr + 1 in
#include "domain_state.tbl"
#undef DOMAIN_STATE
let _ = curr in
function
#define DOMAIN_STATE(type, name) \
| Domain_##name -> idx__##name
#include "domain_state.tbl"
#undef DOMAIN_STATE

6
utils/domainstate.mli.c Normal file
View File

@ -0,0 +1,6 @@
type t =
#define DOMAIN_STATE(type, name) | Domain_##name
#include "domain_state.tbl"
#undef DOMAIN_STATE
val idx_of_field : t -> int