static void push_stack_piece_bottom_frame(runtime_t *runtime, value_t stack_piece,
value_t arg_map) {
frame_t bottom = frame_empty();
value_t code_block = ROOT(runtime, stack_piece_bottom_code_block);
// The transferred arguments are going to appear as if they were arguments
// passed from this frame so we have to "allocate" enough room for them on
// the stack.
open_stack_piece(stack_piece, &bottom);
size_t arg_count = get_array_length(arg_map);
bool pushed = try_push_new_frame(&bottom,
get_code_block_high_water_mark(code_block) + arg_count,
ffSynthetic | ffStackPieceBottom, false);
CHECK_TRUE("pushing bottom frame", pushed);
frame_set_code_block(&bottom, code_block);
frame_set_argument_map(&bottom, arg_map);
close_frame(&bottom);
}
/************************************************************************
Return the left most node in the tree. */
UNIV_INTERN
const ib_rbt_node_t*
rbt_first(
/*======*/
/* out leftmost node or NULL */
const ib_rbt_t* tree) /* in: rb tree */
{
ib_rbt_node_t* first = NULL;
ib_rbt_node_t* current = ROOT(tree);
while (current != tree->nil) {
first = current;
current = current->left;
}
return(first);
}
static value_t create_methodspace_selector_slice(runtime_t *runtime, value_t self,
value_t selector) {
TRY_DEF(result, new_heap_signature_map(runtime));
value_t current = self;
while (!is_nothing(current)) {
value_t methods = get_methodspace_methods(current);
value_t entries = get_signature_map_entries(methods);
for (int64_t i = 0; i < get_pair_array_buffer_length(entries); i++) {
value_t signature = get_pair_array_buffer_first_at(entries, i);
if (can_match_eq(signature, ROOT(runtime, selector_key), selector)) {
value_t method = get_pair_array_buffer_second_at(entries, i);
TRY(add_to_signature_map(runtime, result, signature, method));
}
}
current = get_methodspace_parent(current);
}
return result;
}
static Boolean avl_init(SshADTContainer c, void *container_specific)
{
#ifdef _KERNEL
SSH_ASSERT((c->flags & SSH_ADT_FLAG_CONTAINED_HEADER));
#endif
/* For some reason, Irix CC doesn't like casts on the left side, so don't
use the CROOT() macro here. Please, don't. //sjl */
if (!(c->container_specific = container_specific))
return FALSE;
ROOT(c) = NULL;
if (c->f.app_methods.hash != ssh_adt_default_hash)
{
SSH_DEBUG(0, ("*** You have provided a hash callback for an avltree."));
SSH_DEBUG(0, ("*** Please report to maintainer."));
}
return TRUE;
}
value_t run_code_block(safe_value_t s_ambience, safe_value_t code) {
runtime_t *runtime = get_ambience_runtime(deref(s_ambience));
CREATE_SAFE_VALUE_POOL(runtime, 4, pool);
E_BEGIN_TRY_FINALLY();
// Build a stack to run the code on.
E_S_TRY_DEF(s_stack, protect(pool, new_heap_stack(runtime, 1024)));
{
frame_t frame = open_stack(deref(s_stack));
// Set up the initial frame.
size_t frame_size = get_code_block_high_water_mark(deref(code));
E_TRY(push_stack_frame(runtime, deref(s_stack), &frame, frame_size,
ROOT(runtime, empty_array)));
frame_set_code_block(&frame, deref(code));
close_frame(&frame);
}
// Run until completion.
E_RETURN(run_stack_until_signal(s_ambience, s_stack));
E_FINALLY();
DISPOSE_SAFE_VALUE_POOL(pool);
E_END_TRY_FINALLY();
}
value_t run_code_block_until_condition(value_t ambience, value_t code) {
// Create the stack to run the code on.
runtime_t *runtime = get_ambience_runtime(ambience);
TRY_DEF(stack, new_heap_stack(runtime, 1024));
// Push an activation onto the empty stack to get execution going.
size_t frame_size = get_code_block_high_water_mark(code);
frame_t frame = open_stack(stack);
TRY(push_stack_frame(runtime, stack, &frame, frame_size, ROOT(runtime, empty_array)));
frame_set_code_block(&frame, code);
close_frame(&frame);
// Run the stack.
loop:
do {
value_t result = run_stack_until_condition(ambience, stack);
if (in_condition_cause(ccForceValidate, result)) {
runtime_t *runtime = get_ambience_runtime(ambience);
runtime_validate(runtime, result);
goto loop;
}
return result;
} while (false);
}
/************************************************************************
Find a matching node in the rb tree.
@return NULL if not found else the node where key was found */
UNIV_INTERN
const ib_rbt_node_t*
rbt_lookup(
/*=======*/
const ib_rbt_t* tree, /*!< in: rb tree */
const void* key) /*!< in: key to use for search */
{
const ib_rbt_node_t* current = ROOT(tree);
/* Regular binary search. */
while (current != tree->nil) {
int result = tree->compare(key, current->value);
if (result < 0) {
current = current->left;
} else if (result > 0) {
current = current->right;
} else {
break;
}
}
return(current != tree->nil ? current : NULL);
}
/* accessor */
Node *core_ref(ScmTreeCore *tc, intptr_t key, enum TreeOp op,
Node **lo, Node **hi)
{
Node *e = ROOT(tc), *n = NULL;
if (e == NULL) {
/* Tree is empty */
if (op == TREE_CREATE) {
n = new_node(NULL, key);
PAINT(n, BLACK);
SET_ROOT(tc, n);
tc->num_entries++;
}
if (op == TREE_NEAR) {
*lo = *hi = NULL;
}
return n;
}
for (;;) {
int r = 0;
if (tc->cmp) r = tc->cmp(tc, e->key, key);
if (tc->cmp? (r == 0) : (e->key == key)) {
/* Exact match */
if (op == TREE_DELETE) {
n = delete_node(tc, e);
tc->num_entries--;
return n;
}
if (op == TREE_NEAR) {
*lo = prev_node(e);
*hi = next_node(e);
}
return e;
}
if (tc->cmp? (r < 0) : (e->key < key)) {
/* Key is larger than E */
if (e->right) {
e = e->right;
} else {
if (op == TREE_CREATE) {
n = new_node(e, key);
e->right = n;
balance_tree(tc, n);
tc->num_entries++;
return n;
}
if (op == TREE_NEAR) {
*lo = e;
*hi = next_node(e);
}
return NULL;
}
} else {
/* Key is smaller than E */
if (e->left) {
e = e->left;
} else {
if (op == TREE_CREATE) {
n = new_node(e, key);
e->left = n;
balance_tree(tc, n);
tc->num_entries++;
return n;
}
if (op == TREE_NEAR) {
*hi = e;
*lo = prev_node(e);
}
return NULL;
}
}
}
}
/************************************************************************
Balance a tree after inserting a node. */
static
void
rbt_balance_tree(
/*=============*/
const ib_rbt_t* tree, /*!< in: tree to balance */
ib_rbt_node_t* node) /*!< in: node that was inserted */
{
const ib_rbt_node_t* nil = tree->nil;
ib_rbt_node_t* parent = node->parent;
/* Restore the red-black property. */
node->color = IB_RBT_RED;
while (node != ROOT(tree) && parent->color == IB_RBT_RED) {
ib_rbt_node_t* grand_parent = parent->parent;
if (parent == grand_parent->left) {
ib_rbt_node_t* uncle = grand_parent->right;
if (uncle->color == IB_RBT_RED) {
/* Case 1 - change the colors. */
uncle->color = IB_RBT_BLACK;
parent->color = IB_RBT_BLACK;
grand_parent->color = IB_RBT_RED;
/* Move node up the tree. */
node = grand_parent;
} else {
if (node == parent->right) {
/* Right is a black node and node is
to the right, case 2 - move node
up and rotate. */
node = parent;
rbt_rotate_left(nil, node);
}
grand_parent = node->parent->parent;
/* Case 3. */
node->parent->color = IB_RBT_BLACK;
grand_parent->color = IB_RBT_RED;
rbt_rotate_right(nil, grand_parent);
}
} else {
ib_rbt_node_t* uncle = grand_parent->left;
if (uncle->color == IB_RBT_RED) {
/* Case 1 - change the colors. */
uncle->color = IB_RBT_BLACK;
parent->color = IB_RBT_BLACK;
grand_parent->color = IB_RBT_RED;
/* Move node up the tree. */
node = grand_parent;
} else {
if (node == parent->left) {
/* Left is a black node and node is to
the right, case 2 - move node up and
rotate. */
node = parent;
rbt_rotate_right(nil, node);
}
grand_parent = node->parent->parent;
/* Case 3. */
node->parent->color = IB_RBT_BLACK;
grand_parent->color = IB_RBT_RED;
rbt_rotate_left(nil, grand_parent);
}
}
parent = node->parent;
}
/* Color the root black. */
ROOT(tree)->color = IB_RBT_BLACK;
}
Tree *tree_get_root(Tree *t)
{
ROOT(t);
return t;
}
// Runs the given stack within the given ambience until a condition is
// encountered or evaluation completes. This function also bails on and leaves
// it to the surrounding code to report error messages.
static value_t run_stack_pushing_signals(value_t ambience, value_t stack) {
CHECK_FAMILY(ofAmbience, ambience);
CHECK_FAMILY(ofStack, stack);
runtime_t *runtime = get_ambience_runtime(ambience);
frame_t frame = open_stack(stack);
code_cache_t cache;
code_cache_refresh(&cache, &frame);
E_BEGIN_TRY_FINALLY();
while (true) {
opcode_t opcode = (opcode_t) read_short(&cache, &frame, 0);
TOPIC_INFO(Interpreter, "Opcode: %s (%i)", get_opcode_name(opcode),
opcode_counter++);
IF_EXPENSIVE_CHECKS_ENABLED(MAYBE_INTERRUPT());
switch (opcode) {
case ocPush: {
value_t value = read_value(&cache, &frame, 1);
frame_push_value(&frame, value);
frame.pc += kPushOperationSize;
break;
}
case ocPop: {
size_t count = read_short(&cache, &frame, 1);
for (size_t i = 0; i < count; i++)
frame_pop_value(&frame);
frame.pc += kPopOperationSize;
break;
}
case ocCheckStackHeight: {
size_t expected = read_short(&cache, &frame, 1);
size_t height = frame.stack_pointer - frame.frame_pointer;
CHECK_EQ("stack height", expected, height);
frame.pc += kCheckStackHeightOperationSize;
break;
}
case ocNewArray: {
size_t length = read_short(&cache, &frame, 1);
E_TRY_DEF(array, new_heap_array(runtime, length));
for (size_t i = 0; i < length; i++) {
value_t element = frame_pop_value(&frame);
set_array_at(array, length - i - 1, element);
}
frame_push_value(&frame, array);
frame.pc += kNewArrayOperationSize;
break;
}
case ocInvoke: {
// Look up the method in the method space.
value_t tags = read_value(&cache, &frame, 1);
CHECK_FAMILY(ofCallTags, tags);
value_t fragment = read_value(&cache, &frame, 2);
CHECK_FAMILY(ofModuleFragment, fragment);
value_t helper = read_value(&cache, &frame, 3);
CHECK_FAMILY(ofSignatureMap, helper);
value_t arg_map;
value_t method = lookup_method_full(ambience, fragment, tags, &frame,
helper, &arg_map);
if (in_condition_cause(ccLookupError, method)) {
log_lookup_error(method, tags, &frame);
E_RETURN(method);
}
// The lookup may have failed with a different condition. Check for that.
E_TRY(method);
E_TRY_DEF(code_block, ensure_method_code(runtime, method));
// We should now have done everything that can fail so we advance the
// pc over this instruction. In reality we haven't, the frame push op
// below can fail so we should really push the next frame before
// storing the pc for this one. Laters.
frame.pc += kInvokeOperationSize;
// Push a new activation.
E_TRY(push_stack_frame(runtime, stack, &frame,
get_code_block_high_water_mark(code_block), arg_map));
frame_set_code_block(&frame, code_block);
code_cache_refresh(&cache, &frame);
break;
}
case ocSignalContinue:
case ocSignalEscape: {
// Look up the method in the method space.
value_t tags = read_value(&cache, &frame, 1);
CHECK_FAMILY(ofCallTags, tags);
frame.pc += kSignalEscapeOperationSize;
value_t arg_map = whatever();
value_t handler = whatever();
value_t method = lookup_signal_handler_method(ambience, tags, &frame,
&handler, &arg_map);
bool is_escape = (opcode == ocSignalEscape);
if (in_condition_cause(ccLookupError, method)) {
if (is_escape) {
// There was no handler for this so we have to escape out of the
// interpreter altogether. Push the signal frame onto the stack to
// record the state of it for the enclosing code.
E_TRY(push_stack_frame(runtime, stack, &frame, 1, nothing()));
// The stack tracing code expects all frames to have a valid code block
// object. The rest makes less of a difference.
frame_set_code_block(&frame, ROOT(runtime, empty_code_block));
E_RETURN(new_signal_condition(is_escape));
} else {
// There was no handler but this is not an escape so we skip over
// the post-handler goto to the default block.
CHECK_EQ("signal not followed by goto", ocGoto,
read_short(&cache, &frame, 0));
frame.pc += kGotoOperationSize;
}
} else {
// We found a method. Invoke it.
E_TRY(method);
E_TRY_DEF(code_block, ensure_method_code(runtime, method));
E_TRY(push_stack_frame(runtime, stack, &frame,
get_code_block_high_water_mark(code_block), arg_map));
frame_set_code_block(&frame, code_block);
CHECK_TRUE("subject not null", is_null(frame_get_argument(&frame, 0)));
frame_set_argument(&frame, 0, handler);
code_cache_refresh(&cache, &frame);
}
break;
}
case ocGoto: {
size_t delta = read_short(&cache, &frame, 1);
frame.pc += delta;
break;
}
case ocDelegateToLambda:
case ocDelegateToBlock: {
// This op only appears in the lambda and block delegator methods.
// They should never be executed because the delegation happens during
// method lookup. If we hit here something's likely wrong with the
// lookup process.
UNREACHABLE("delegate to lambda");
return new_condition(ccWat);
}
case ocBuiltin: {
value_t wrapper = read_value(&cache, &frame, 1);
builtin_method_t impl = (builtin_method_t) get_void_p_value(wrapper);
builtin_arguments_t args;
builtin_arguments_init(&args, runtime, &frame);
E_TRY_DEF(result, impl(&args));
frame_push_value(&frame, result);
frame.pc += kBuiltinOperationSize;
break;
}
case ocBuiltinMaybeEscape: {
value_t wrapper = read_value(&cache, &frame, 1);
builtin_method_t impl = (builtin_method_t) get_void_p_value(wrapper);
builtin_arguments_t args;
builtin_arguments_init(&args, runtime, &frame);
value_t result = impl(&args);
if (in_condition_cause(ccSignal, result)) {
// The builtin failed. Find the appropriate signal handler and call
// it. The invocation record is at the top of the stack.
value_t tags = frame_pop_value(&frame);
CHECK_FAMILY(ofCallTags, tags);
value_t arg_map = whatever();
value_t handler = whatever();
value_t method = lookup_signal_handler_method(ambience, tags, &frame,
&handler, &arg_map);
if (in_condition_cause(ccLookupError, method)) {
// Push the record back onto the stack to it's available to back
// tracing.
frame_push_value(&frame, tags);
frame.pc += kBuiltinMaybeEscapeOperationSize;
// There was no handler for this so we have to escape out of the
// interpreter altogether. Push the signal frame onto the stack to
// record the state of it for the enclosing code.
E_TRY(push_stack_frame(runtime, stack, &frame, 1, nothing()));
// The stack tracing code expects all frames to have a valid code block
// object. The rest makes less of a difference.
frame_set_code_block(&frame, ROOT(runtime, empty_code_block));
E_RETURN(new_signal_condition(true));
}
// Either found a signal or encountered a different condition.
E_TRY(method);
// Skip forward to the point we want the signal to return to, the
// leave-or-fire-barrier op that will do the leaving.
size_t dest_offset = read_short(&cache, &frame, 2);
frame.pc += dest_offset;
// Run the handler.
E_TRY_DEF(code_block, ensure_method_code(runtime, method));
E_TRY(push_stack_frame(runtime, stack, &frame,
get_code_block_high_water_mark(code_block), arg_map));
frame_set_code_block(&frame, code_block);
CHECK_TRUE("subject not null", is_null(frame_get_argument(&frame, 0)));
frame_set_argument(&frame, 0, handler);
code_cache_refresh(&cache, &frame);
} else {
// The builtin didn't cause a condition so we can just keep going.
E_TRY(result);
frame_push_value(&frame, result);
frame.pc += kBuiltinMaybeEscapeOperationSize;
}
break;
}
case ocReturn: {
value_t result = frame_pop_value(&frame);
frame_pop_within_stack_piece(&frame);
code_cache_refresh(&cache, &frame);
frame_push_value(&frame, result);
break;
}
case ocStackBottom: {
value_t result = frame_pop_value(&frame);
validate_stack_on_normal_exit(&frame);
E_RETURN(result);
}
case ocStackPieceBottom: {
value_t top_piece = frame.stack_piece;
value_t result = frame_pop_value(&frame);
value_t next_piece = get_stack_piece_previous(top_piece);
set_stack_top_piece(stack, next_piece);
frame = open_stack(stack);
code_cache_refresh(&cache, &frame);
frame_push_value(&frame, result);
break;
}
case ocSlap: {
value_t value = frame_pop_value(&frame);
size_t argc = read_short(&cache, &frame, 1);
for (size_t i = 0; i < argc; i++)
frame_pop_value(&frame);
frame_push_value(&frame, value);
frame.pc += kSlapOperationSize;
break;
}
case ocNewReference: {
// Create the reference first so that if it fails we haven't clobbered
// the stack yet.
E_TRY_DEF(ref, new_heap_reference(runtime, nothing()));
value_t value = frame_pop_value(&frame);
set_reference_value(ref, value);
frame_push_value(&frame, ref);
frame.pc += kNewReferenceOperationSize;
break;
}
case ocSetReference: {
value_t ref = frame_pop_value(&frame);
CHECK_FAMILY(ofReference, ref);
value_t value = frame_peek_value(&frame, 0);
set_reference_value(ref, value);
frame.pc += kSetReferenceOperationSize;
break;
}
case ocGetReference: {
value_t ref = frame_pop_value(&frame);
CHECK_FAMILY(ofReference, ref);
value_t value = get_reference_value(ref);
frame_push_value(&frame, value);
frame.pc += kGetReferenceOperationSize;
break;
}
case ocLoadLocal: {
size_t index = read_short(&cache, &frame, 1);
value_t value = frame_get_local(&frame, index);
frame_push_value(&frame, value);
frame.pc += kLoadLocalOperationSize;
break;
}
case ocLoadGlobal: {
value_t ident = read_value(&cache, &frame, 1);
CHECK_FAMILY(ofIdentifier, ident);
value_t fragment = read_value(&cache, &frame, 2);
CHECK_FAMILY(ofModuleFragment, fragment);
value_t module = get_module_fragment_module(fragment);
E_TRY_DEF(value, module_lookup_identifier(runtime, module,
get_identifier_stage(ident), get_identifier_path(ident)));
frame_push_value(&frame, value);
frame.pc += kLoadGlobalOperationSize;
break;
}
case ocLoadArgument: {
size_t param_index = read_short(&cache, &frame, 1);
value_t value = frame_get_argument(&frame, param_index);
frame_push_value(&frame, value);
frame.pc += kLoadArgumentOperationSize;
break;
}
case ocLoadRefractedArgument: {
size_t param_index = read_short(&cache, &frame, 1);
size_t block_depth = read_short(&cache, &frame, 2);
value_t subject = frame_get_argument(&frame, 0);
frame_t home = frame_empty();
get_refractor_refracted_frame(subject, block_depth, &home);
value_t value = frame_get_argument(&home, param_index);
frame_push_value(&frame, value);
frame.pc += kLoadRefractedArgumentOperationSize;
break;
}
case ocLoadRefractedLocal: {
size_t index = read_short(&cache, &frame, 1);
size_t block_depth = read_short(&cache, &frame, 2);
value_t subject = frame_get_argument(&frame, 0);
frame_t home = frame_empty();
get_refractor_refracted_frame(subject, block_depth, &home);
value_t value = frame_get_local(&home, index);
frame_push_value(&frame, value);
frame.pc += kLoadRefractedLocalOperationSize;
break;
}
case ocLoadLambdaCapture: {
size_t index = read_short(&cache, &frame, 1);
value_t subject = frame_get_argument(&frame, 0);
CHECK_FAMILY(ofLambda, subject);
value_t value = get_lambda_capture(subject, index);
frame_push_value(&frame, value);
frame.pc += kLoadLambdaCaptureOperationSize;
break;
}
case ocLoadRefractedCapture: {
size_t index = read_short(&cache, &frame, 1);
size_t block_depth = read_short(&cache, &frame, 2);
value_t subject = frame_get_argument(&frame, 0);
frame_t home = frame_empty();
get_refractor_refracted_frame(subject, block_depth, &home);
value_t lambda = frame_get_argument(&home, 0);
CHECK_FAMILY(ofLambda, lambda);
value_t value = get_lambda_capture(lambda, index);
frame_push_value(&frame, value);
frame.pc += kLoadRefractedLocalOperationSize;
break;
}
case ocLambda: {
value_t space = read_value(&cache, &frame, 1);
CHECK_FAMILY(ofMethodspace, space);
size_t capture_count = read_short(&cache, &frame, 2);
value_t captures;
E_TRY_DEF(lambda, new_heap_lambda(runtime, space, nothing()));
if (capture_count == 0) {
captures = ROOT(runtime, empty_array);
frame.pc += kLambdaOperationSize;
} else {
E_TRY_SET(captures, new_heap_array(runtime, capture_count));
// The pc gets incremented here because it is after we've done all
// the allocation but before anything has been popped off the stack.
// This way all the above is idempotent, and the below is guaranteed
// to succeed.
frame.pc += kLambdaOperationSize;
for (size_t i = 0; i < capture_count; i++)
set_array_at(captures, i, frame_pop_value(&frame));
}
set_lambda_captures(lambda, captures);
frame_push_value(&frame, lambda);
break;
}
case ocCreateBlock: {
value_t space = read_value(&cache, &frame, 1);
CHECK_FAMILY(ofMethodspace, space);
// Create the block object.
E_TRY_DEF(block, new_heap_block(runtime, nothing()));
// Create the stack section that describes the block.
value_t section = frame_alloc_derived_object(&frame, get_genus_descriptor(dgBlockSection));
set_barrier_state_payload(section, block);
refraction_point_init(section, &frame);
set_block_section_methodspace(section, space);
set_block_section(block, section);
value_validate(block);
value_validate(section);
// Push the block object.
frame_push_value(&frame, block);
frame.pc += kCreateBlockOperationSize;
break;
}
case ocCreateEnsurer: {
value_t code_block = read_value(&cache, &frame, 1);
value_t section = frame_alloc_derived_object(&frame,
get_genus_descriptor(dgEnsureSection));
set_barrier_state_payload(section, code_block);
refraction_point_init(section, &frame);
value_validate(section);
frame_push_value(&frame, section);
frame.pc += kCreateEnsurerOperationSize;
break;
}
case ocCallEnsurer: {
value_t value = frame_pop_value(&frame);
value_t shard = frame_pop_value(&frame);
frame_push_value(&frame, value);
frame_push_value(&frame, shard);
CHECK_GENUS(dgEnsureSection, shard);
value_t code_block = get_barrier_state_payload(shard);
CHECK_FAMILY(ofCodeBlock, code_block);
// Unregister the barrier before calling it, otherwise if we leave
// by escaping we'll end up calling it over again.
barrier_state_unregister(shard, stack);
frame.pc += kCallEnsurerOperationSize;
value_t argmap = ROOT(runtime, array_of_zero);
push_stack_frame(runtime, stack, &frame,
get_code_block_high_water_mark(code_block), argmap);
frame_set_code_block(&frame, code_block);
code_cache_refresh(&cache, &frame);
break;
}
case ocDisposeEnsurer: {
// Discard the result of the ensure block. If an ensure blocks needs
// to return a useful value it can do it via an escape.
frame_pop_value(&frame);
value_t shard = frame_pop_value(&frame);
CHECK_GENUS(dgEnsureSection, shard);
value_t value = frame_pop_value(&frame);
frame_destroy_derived_object(&frame, get_genus_descriptor(dgEnsureSection));
frame_push_value(&frame, value);
frame.pc += kDisposeEnsurerOperationSize;
break;
}
case ocInstallSignalHandler: {
value_t space = read_value(&cache, &frame, 1);
CHECK_FAMILY(ofMethodspace, space);
size_t dest_offset = read_short(&cache, &frame, 2);
// Allocate the derived object that's going to hold the signal handler
// state.
value_t section = frame_alloc_derived_object(&frame,
get_genus_descriptor(dgSignalHandlerSection));
// Initialize the handler.
set_barrier_state_payload(section, space);
refraction_point_init(section, &frame);
// Bring the frame state to the point we'll want to escape to (modulo
// the destination offset).
frame_push_value(&frame, section);
frame.pc += kInstallSignalHandlerOperationSize;
// Finally capture the escape state.
capture_escape_state(section, &frame, dest_offset);
value_validate(section);
break;
}
case ocUninstallSignalHandler: {
// The result has been left at the top of the stack.
value_t value = frame_pop_value(&frame);
value_t section = frame_pop_value(&frame);
CHECK_GENUS(dgSignalHandlerSection, section);
barrier_state_unregister(section, stack);
frame_destroy_derived_object(&frame, get_genus_descriptor(dgSignalHandlerSection));
frame_push_value(&frame, value);
frame.pc += kUninstallSignalHandlerOperationSize;
break;
}
case ocCreateEscape: {
size_t dest_offset = read_short(&cache, &frame, 1);
// Create an initially empty escape object.
E_TRY_DEF(escape, new_heap_escape(runtime, nothing()));
// Allocate the escape section on the stack, hooking the barrier into
// the barrier chain.
value_t section = frame_alloc_derived_object(&frame, get_genus_descriptor(dgEscapeSection));
// Point the state and object to each other.
set_barrier_state_payload(section, escape);
set_escape_section(escape, section);
// Get execution ready for the next operation.
frame_push_value(&frame, escape);
frame.pc += kCreateEscapeOperationSize;
// This is the execution state the escape will escape to (modulo the
// destination offset) so this is what we want to capture.
capture_escape_state(section, &frame,
dest_offset);
break;
}
case ocLeaveOrFireBarrier: {
size_t argc = read_short(&cache, &frame, 1);
// At this point the handler has been set as the subject of the call
// to the handler method. Above the arguments are also two scratch
// stack entries.
value_t handler = frame_peek_value(&frame, argc + 2);
CHECK_GENUS(dgSignalHandlerSection, handler);
if (maybe_fire_next_barrier(&cache, &frame, runtime, stack, handler)) {
// Pop the scratch entries off.
frame_pop_value(&frame);
frame_pop_value(&frame);
// Pop the value off.
value_t value = frame_pop_value(&frame);
// Escape to the handler's home.
restore_escape_state(&frame, stack, handler);
code_cache_refresh(&cache, &frame);
// Push the value back on, now in the handler's home frame.
frame_push_value(&frame, value);
} else {
// If a barrier was fired we'll want to let the interpreter loop
// around again so just break without touching .pc.
}
break;
}
case ocFireEscapeOrBarrier: {
value_t escape = frame_get_argument(&frame, 0);
CHECK_FAMILY(ofEscape, escape);
value_t section = get_escape_section(escape);
// Fire the next barrier or, if there are no more barriers, apply the
// escape.
if (maybe_fire_next_barrier(&cache, &frame, runtime, stack, section)) {
value_t value = frame_get_argument(&frame, 2);
restore_escape_state(&frame, stack, section);
code_cache_refresh(&cache, &frame);
frame_push_value(&frame, value);
} else {
// If a barrier was fired we'll want to let the interpreter loop
// around again so just break without touching .pc.
}
break;
}
case ocDisposeEscape: {
value_t value = frame_pop_value(&frame);
value_t escape = frame_pop_value(&frame);
CHECK_FAMILY(ofEscape, escape);
value_t section = get_escape_section(escape);
value_validate(section);
barrier_state_unregister(section, stack);
on_escape_section_exit(section);
frame_destroy_derived_object(&frame, get_genus_descriptor(dgEscapeSection));
frame_push_value(&frame, value);
frame.pc += kDisposeEscapeOperationSize;
break;
}
case ocDisposeBlock: {
value_t value = frame_pop_value(&frame);
value_t block = frame_pop_value(&frame);
CHECK_FAMILY(ofBlock, block);
value_t section = get_block_section(block);
barrier_state_unregister(section, stack);
on_block_section_exit(section);
frame_destroy_derived_object(&frame, get_genus_descriptor(dgBlockSection));
frame_push_value(&frame, value);
frame.pc += kDisposeBlockOperationSize;
break;
}
default:
ERROR("Unexpected opcode %i", opcode);
UNREACHABLE("unexpected opcode");
break;
}
}
E_FINALLY();
close_frame(&frame);
E_END_TRY_FINALLY();
}
double ps_rec_write_tree_owner(PASTIX_INT nodenum, PASTIX_INT *ownertab, const CostMatrix *costmtx, const EliminTree *etree, FILE *out,
void (*ps_draw_node)(FILE *out, PASTIX_INT nodenum, PASTIX_INT procnum, const CostMatrix *costmtx,
const EliminTree *etree, double s,
double x, double y))
{
static PASTIX_INT cx;
PASTIX_INT nodelevel;
double pos=0, lpos=0, rpos=0;
double s, sy;
nodelevel = nodeTreeLevel(nodenum, etree);
sy= 1.4*500.0/treeLevel(etree);
s= 500.0/treeLeaveNbr(etree);
if (nodenum == ROOT(etree))
{
cx= 0;
}
pos= 0;
/* draw sons */
switch (etree->nodetab[nodenum].sonsnbr)
{
case 2:
{
rpos= ps_rec_write_tree_owner(TSON(etree, nodenum, 1), ownertab, costmtx, etree, out, ps_draw_node);
pos+= rpos;
}
case 1:
{
lpos= ps_rec_write_tree_owner(TSON(etree, nodenum, 0), ownertab, costmtx, etree, out, ps_draw_node);
pos+= lpos;
pos/= etree->nodetab[nodenum].sonsnbr;
break;
}
case 0:
{
pos= (double)cx;
cx++;
break;
}
default:
{
errorPrint("Erreur dans l'arbre d'elimination \n\tCblk %ld sonsnbr %ld \n\tAttention on ne peut imprimer l'arbre d'elimination que pour les grilles !!", (long)nodenum, (long)(etree->nodetab[nodenum].sonsnbr));
EXIT(MOD_BLEND,INTERNAL_ERR);
}
}
/* draw links to sons */
switch (etree->nodetab[nodenum].sonsnbr)
{
case 2:
{
fprintf(out, "np %f %f m %f %f l %f %f l sk\n",
lpos*s, (nodelevel+1)*sy,
pos*s, nodelevel*sy,
rpos*s, (nodelevel+1)*sy);
break;
}
case 1:
{
fprintf(out, "np %f %f m %f %f l sk\n",
lpos*s, (nodelevel+1)*sy,
pos*s, (nodelevel)*sy);
break;
}
}
ps_draw_node_owner(out, nodenum, ownertab[nodenum], costmtx, etree, sy, pos*s,
sy*nodelevel);
return pos;
}
void
XDrawString_90(XWindow *xw, Drawable d,
int x, int y, char *string, int length) {
int i, j;
XCharStruct size;
unsigned int width, height;
unsigned int x0, y0;
XImage *in, *out;
Pixmap pix;
XGCValues val;
XGetGCValues(DISPLAY(xw), xw->gc, GCForeground | GCBackground, &val);
XTextSize(xw->font->font_core, string, length, &size);
width = -size.lbearing + size.rbearing;
height = size.ascent + size.descent;
x0 = -size.lbearing;
y0 = size.ascent;
pix = XCreatePixmap(DISPLAY(xw),
ROOT(xw),
width, height,
DEPTH(xw));
/* Background Fill */
XSetForeground(DISPLAY(xw), xw->gc, val.background);
XFillRectangle(DISPLAY(xw), pix, xw->gc, 0, 0, width, height);
XSetForeground(DISPLAY(xw), xw->gc, val.foreground);
XDrawString(DISPLAY(xw), pix, xw->gc, x0, y0, string, length);
/* Convert from pixmap to image */
in = XGetImage(DISPLAY(xw), pix, 0,0, width, height, AllPlanes, ZPixmap);
XFreePixmap(DISPLAY(xw), pix);
/* Create Image with Width and Height exchanged */
out = XCreateImage(DISPLAY(xw),
VISUAL(xw),
DEPTH(xw),
ZPixmap, 0, NULL, height, width, 32, 0);
out->data = (char *) malloc(sizeof(char) * width * out->bytes_per_line);
/* "Rotate" Image */
for(j = 0; j < (int)height; j++) {
for(i = 0; i < (int)width; i++) {
/* width - i - 1 : Flip the Image Vertically */
XPutPixel(out, j, width - i - 1, XGetPixel(in, i, j));
}
}
pix = XCreatePixmap(DISPLAY(xw),
ROOT(xw),
height, width,
DEPTH(xw));
XPutImage(DISPLAY(xw), pix, xw->gc, out, 0, 0, 0, 0, height, width);
XCopyArea(DISPLAY(xw), pix, d, xw->gc, 0, 0, height, width, x, y);
XFreePixmap(DISPLAY(xw), pix);
XDestroyImage(out);
XDestroyImage(in);
}
tort_v tort_runtime_create_ (int *argcp, char ***argvp, char ***envp)
{
tort_mtable *obj_mt, *cls_mt;
tort_v init_backlog[10]; int init_backlog_n = 0;
{
char *s;
if ( (s = getenv("TORT_INIT_DEBUG")) && *s )
_tort_init_debug = atoi(s);
}
assert(sizeof(tort_header) % sizeof(tort_v) == 0);
INIT(malloc);
/* Create runtime object. */
#if TORT_MULTIPLICITY
_tort = tort_ref(tort_runtime, tort_allocate(0, sizeof(tort_runtime)));
#endif
tort_(_initialized) = 0;
INIT(error);
/* Setup environment from main. */
tort_(_argc) = *argcp;
tort_(_argv) = *argvp;
tort_(_env) = *envp;
tort_(stack_bottom) = envp;
/* Allocate and initialize mtables */
INIT(mtable);
tort_h(_tort)->mtable = tort__mt(runtime);
tort_h(_tort)->applyf = _tort_m_object___cannot_apply;
#if ! TORT_NIL_IS_ZERO
/* Create the nil object. */
tort_nil = tort_allocate(tort__mt(nil), sizeof(tort_object));
#endif
/* Create the boolean objects. */
tort_true = tort_allocate(tort__mt(boolean), sizeof(tort_object));
#if ! TORT_FALSE_IS_NIL
tort_false = tort_allocate(tort__mt(boolean), sizeof(tort_object));
#endif
/* Backpatch object delegate as nil. */
tort_ref(tort_mtable, tort__mt(object))->delegate = tort_nil;
/* Initialize the message reference. */
_tort_message = tort_nil;
tort_(message) = tort_nil;
/* Initialize lookup(). */
INIT(lookup);
/*******************************************************/
/* Messaging Boot strap. */
/* Create the symbol table. */
tort_(symbols) = tort_map_new();
obj_mt = tort__mt(mtable);
cls_mt = tort_h_mtable(obj_mt);
tort__s(lookup) = tort_symbol_new("lookup");
tort_add_method(cls_mt, "lookup", _tort_m_mtable__lookup);
tort__s(add_method) = tort_symbol_new("add_method");
tort_add_method(cls_mt, "add_method", _tort_m_mtable__add_method);
tort__s(allocate) = tort_symbol_new("allocate");
tort_send(tort__s(add_method), cls_mt, tort__s(allocate), tort_method_new(_tort_M_object__allocate, 0));
/******************************************************/
/* Create the core symbols. */
INIT(symbol);
/* Create the mtable map. */
tort_(m_mtable) = tort_map_new();
#define tort_d_mt(X) \
if ( tort__mt(X) ) _tort_m_map__set(tort_ta tort_(m_mtable), tort_symbol_new(#X), tort__mt(X));
#include "tort/d_mt.h"
/* Install core methods. */
INIT(method);
/* Start initializer. */
tort_(initializer) = tort_send(tort__s(new), tort__mt(initializer));
while ( init_backlog_n > 0 )
tort_send(tort__s(set), tort_(initializer), init_backlog[-- init_backlog_n], tort__s(initialized));
INIT(eq);
INIT(cmp);
/* Add core slots. */
INIT(slot);
/* Create the root table. */
tort_(root) = tort_map_new();
/* Symbol Encoder. */
INIT(symbol_encoder);
/* Uncloneable objects. */
tort_add_method(tort__mt(symbol), "clone", _tort_m_object__identity);
tort_add_method(tort__mt(nil), "clone", _tort_m_object__identity);
tort_add_method(tort__mt(ptr), "clone", _tort_m_object__identity);
tort_add_method(tort__mt(tagged), "clone", _tort_m_object__identity);
tort_add_method(tort__mt(boolean), "clone", _tort_m_object__identity);
/* Initialize system method table. */
tort_h(_tort)->mtable = tort_mtable_new_class(tort__mt(object));
/* Subsystem initialization. */
INIT(gc);
/* unknown caller_info */
tort_(unknown_caller_info) = tort_send(tort__s(_allocate), tort__mt(caller_info), tort_i(sizeof(tort_caller_info)));
tort_(unknown_caller_info)->file = "<unknown>";
/* Setup the root namespace. */
#define ROOT(N,V) tort_send(tort__s(set), tort_(root), tort_symbol_new(#N), (V))
ROOT(runtime, tort_ref_box(_tort));
ROOT(initializer, tort_(initializer));
ROOT(nil, tort_nil);
ROOT(true, tort_true);
ROOT(false, tort_false);
ROOT(symbols, tort_(symbols));
ROOT(mtable, tort_(m_mtable));
ROOT(unknown_caller_info, tort_(unknown_caller_info));
ROOT(tag_bits, tort_i(TORT_TAG_BITS));
ROOT(word_size, tort_i(sizeof(tort_v)));
ROOT(object_header_size, tort_i(sizeof(tort_header)));
INIT(io);
INIT(printf);
INIT(debug);
INIT(dynlib);
{
int i; tort_v m = tort_map_new();
for ( i = 0; i < 1 << TORT_TAG_BITS; ++ i ) {
tort_v k = tort_i(i), v = tort_(tagged_header)[i].mtable;
if ( ! v ) v = tort_nil;
tort_send(tort__s(set), m, k, v);
tort_send(tort__s(set), m, v, k);
}
ROOT(tagged_mtables, m);
}
{
int i; tort_v v = tort_vector_new(0, 0);
for ( i = 0; i < tort_(_argc) && tort_(_argv)[i]; ++ i ) {
tort_send(tort__s(add), v, tort_string_new_cstr(tort_(_argv)[i]));
}
ROOT(argv, v);
}
INIT(gc_ready);
tort_(_initialized) = tort_true;
// fprintf(stderr, "\ntort: initialized\n");
#undef ROOT
#undef INIT
return tort_ref_box(_tort);
}
extern "C" int EV_5();
extern "C" void EV_4();
extern "C" int EV_3();
extern "C" int EV_2();
extern "C" void EV_1();
fun_ac RES_7();
Stmt_id RES_6();
If_red RES_5();
Stmt_id RES_4();
Stmt_ev RES_3();
Stmt_ev RES_2();
Exp_reb RES_1();
ML_ctx global_ctx = "(* TEMPO Version, Build: Feb 11 2003 : 12:15:35, Copyright (c) IRISA/INRIA-Universite de Rennes *)\
ABSYN(ENTRY_POINT_SPEC(ROOT(G(\"dotproduct\")),CALL_SIG([VAR(tINDR(NON_CST,NON_VOL,tINT(NON_CST,NON_VOL,SIGNED,STD)),ROOT(L(G(\"dotproduct\"),0, \"v\")))],[],ALIAS_CALL_SIG(STORE([])),BTA_CALL_SIG([D],[]),ETA_RETURN_SIG(D,[],[]))),0,[],[],[],[],[%s])";
fun_ac RES_7() {
return fun_ac("_Gdotproduct_1",Block_reb(cons<stmt_ac *>(
RES_3()
*= RES_4()
*= RES_5()
*= RES_6()
),"BLOCK([VAR_DEF(DYNAMIC,tINT(NON_CST,NON_VOL,SIGNED,STD),ROOT(L(G(\"dotproduct\"),1, \"sum\")),NON_INIT)],[%s],A(U))"),"FUNC_DEF(EXTERN,tINT(NON_CST,NON_VOL,SIGNED,STD),G(\"%s\"),INTERNAL(UNINIT),[FUNC_DEF_PARAM(tINDR(NON_CST,NON_VOL,tINT(NON_CST,NON_VOL,SIGNED,STD)),ROOT(L(G(\"dotproduct\"),0, \"v\")))],[(FUNC_SIG(CALL_SIG([VAR(tINDR(NON_CST,NON_VOL,tINT(NON_CST,NON_VOL,SIGNED,STD)),ROOT(L(G(\"dotproduct\"),0, \"v\")))],[],ALIAS_CALL_SIG(STORE([])),BTA_CALL_SIG([D],[S, D]),ETA_RETURN_SIG(D,[],[])),RETURN_SIG([],ALIAS_RETURN_SIG([],STORE([])),BTA_RETURN_SIG(F([D],D,D),[]),ETA_CALL_SIG([S, S, D],F([D],D,D),[INDR(VAR(tARRAY(\"1\",tINT(NON_CST,NON_VOL,SIGNED,STD)),ROOT(E(\"some_array\"))))],[INDR(VAR(tARRAY(\"1\",tINT(NON_CST,NON_VOL,SIGNED,STD)),ROOT(E(\"static_array\"))))]))), %s)])");
}
Stmt_id RES_6() {
return Stmt_id("RETURN(VAR(ROOT(L(G(\"dotproduct\"),1, \"sum\")),tINT(NON_CST,NON_VOL,SIGNED,STD),A(D)),A(D))");
}
If_red RES_5() {
TEST(misc, testMenuTree) {
print("******************************************* testMenuTree\r\n");
MenuItem ROOT(NULL, NULL);
MenuTree tree(&ROOT);
MenuItem miTopLevel1(tree.root, "top level 1");
MenuItem miTopLevel2(tree.root, "top level 2");
MenuItem miTopLevel3(tree.root, LL_RPM);
MenuItem miTopLevel4(tree.root, "top level 4");
MenuItem miTopLevel5(tree.root, "top level 5");
MenuItem miSubMenu1_1(&miTopLevel1, "sub menu 1 1");
MenuItem miSubMenu1_2(&miTopLevel1, "sub menu 1 2");
MenuItem miSubMenu5_1(&miTopLevel5, "sub menu 5 1");
MenuItem miSubMenu5_2(&miTopLevel5, "sub menu 5 2");
ASSERT_EQ(0, miTopLevel1.index);
ASSERT_EQ(1, miTopLevel2.index);
ASSERT_EQ(4, miTopLevel5.index);
tree.init(&miTopLevel1, 3);
tree.nextItem();
ASSERT_TRUE(tree.topVisible == &miTopLevel1);
ASSERT_TRUE(tree.current == &miTopLevel2);
tree.back();
ASSERT_TRUE(tree.current == &miTopLevel2); // no 'back' since we are on the top level already
tree.nextItem();
ASSERT_TRUE(tree.topVisible == &miTopLevel1);
ASSERT_TRUE(tree.current == &miTopLevel3);
tree.nextItem();
ASSERT_TRUE(tree.topVisible == &miTopLevel2);
ASSERT_TRUE(tree.current == &miTopLevel4);
tree.enterSubMenu();
ASSERT_TRUE(tree.current == &miTopLevel4) << "still same"; // no children in this one
tree.nextItem();
ASSERT_TRUE(tree.topVisible == &miTopLevel3);
ASSERT_TRUE(tree.current == &miTopLevel5) << "tl5";
tree.nextItem();
ASSERT_TRUE(tree.topVisible == &miTopLevel1) << "tl1 t";
ASSERT_TRUE(tree.current == &miTopLevel1) << "tl1 c";
tree.nextItem();
tree.nextItem();
tree.nextItem();
tree.nextItem();
tree.enterSubMenu();
ASSERT_TRUE(tree.current == &miSubMenu5_1);
tree.back();
ASSERT_TRUE(tree.current == &miTopLevel1);
}
