/*
** core.ops
*/

#include "parrot/dynext.h"
#include "parrot/embed.h"
#include "parrot/interp_guts.h"

VERSION = PARROT_VERSION;

=head1 NAME

core.ops - Parrot Core Ops

=cut

=head1 DESCRIPTION

Parrot's core library of ops.

Core operations are primarily flow control and interpreter
introspection.

=cut

# ' for emacs

###############################################################################

=head2 Basic ops

These are the fundamental operations.
Please note: These opcodes must not be moved; they must have
exactly these opcode numbers. Opcodes ending with underscores are for
internal use only, don't emit these opcodes.

=over 4

=cut

########################################

=item B<end>()

Halts the interpreter. (Must be op #0, CORE_OPS_end). See also B<exit>.

=cut

inline op end() {
  HALT();
}


########################################

=item B<noop>()

Does nothing other than waste an iota of time and 32 bits of bytecode space.
(Must be op #1, CORE_OPS_noop)

=item B<cpu_ret>()

Emit a cpu return instruction. This is used to return from CGP core
to JIT code. Note: Do B<not> use this opcode. It is for internal use only.
(Must be op #2, CORE_OPS_cpu_ret)

=item B<check_events>()

Check the event queue and run event handlers if there are unhandled events.
Note: This opcode is mainly for testing. It should not be necessary to ever
use it explicitly.
(Must be op #3, CORE_OPS_check_events).

=item B<check_events__>()

Check the event queue and run event handlers if there are unhandled events.
Note: Do B<not> use this opcode. It is for internal use only.
(Must be op #4, CORE_OPS_check_events__).

=item B<wrapper__>()

Internal opcode to wrap unknown ops from loaded opcode libs.
Don't use.
(Must be op #5, CORE_OPS_wrapper__).

=item B<prederef__>()

Internal opcode to prederef opcodes on the fly.
Don't use.
(Must be op #6, CORE_OPS_prederef__ ).

=item B<reserved>(in INT)

Reserve 2 more fixed entries.

=item B<load_bytecode>(in STR)

Load Parrot bytecode from file $1, and (TODO) search the library path,
to locate the file.

=cut

inline op noop() {
  goto NEXT();
}

inline op cpu_ret() {
#ifdef __GNUC__
# ifdef I386
   asm("ret");
# endif
#endif
  goto NEXT();
}

inline op check_events() {
  opcode_t *next = expr NEXT();
  CHECK_EVENTS(interpreter);
  goto ADDRESS(next);	/* force this being a branch op */
}

inline op check_events__() {
  opcode_t *this = CUR_OPCODE;
  HANDLE_EVENTS(interpreter);
  goto ADDRESS(this);	/* force this being a branch op */
}

inline op wrapper__() {
    opcode_t *pc = CUR_OPCODE;
    DO_OP(pc, interpreter);
    goto ADDRESS(pc);
}

inline op prederef__() {
    do_prederef((void**)cur_opcode, interpreter, op_lib.core_type);
    goto OFFSET(0);
}

inline op reserved(in INT) {
  goto NEXT();  /* reserve 2 entries */
}

inline op load_bytecode(in STR) {
  char * file = string_to_cstring(interpreter, $1);
  Parrot_load_bytecode(interpreter, file);
  string_cstring_free(file);
  goto NEXT();
}

=back

=cut

###############################################################################

=head2 Control flow

The control flow opcodes check conditions and manage program flow.

=over 4

=cut

########################################

=item B<branch>(in INT)

Branch forward or backward by the amount in $1.

=cut

inline op branch (in INT) {
  goto OFFSET($1);
}


=item B<branch_cs>(in STR)

Intersegment branch to location in fixup table named $1.

=cut

inline op branch_cs (in STR) {
    char * label = string_to_cstring(interpreter, $1);
    struct PackFile_FixupEntry *fe = PackFile_find_fixup_entry(interpreter,
	    enum_fixup_label, label);
    string_cstring_free(label);
    if (!fe)
	interpreter->resume_offset = -1;
    else {
	interpreter->resume_offset = fe->offset;
        Parrot_switch_to_cs(interpreter, fe->seg);
    }
    interpreter->resume_flag = 2;
    goto ADDRESS(0);
}

########################################

=item B<bsr>(in INT)

Branch to the location specified by $1. Push the current location onto the call
stack for later returning.

=cut

inline op bsr (in INT) {
  stack_push(interpreter, &interpreter->ctx.control_stack, expr NEXT(),  STACK_ENTRY_DESTINATION, STACK_CLEANUP_NULL);
  goto OFFSET($1);
}

=item B<ret>()

Pop the location off the top of the call stack and go there.

=cut

inline op ret() {
  goto POP();
}


########################################

=item B<jsr>(in INT)

Jump to the location specified by register $1. Push the current
location onto the call stack for later returning.

=cut

inline op jsr(in INT) {
  opcode_t * loc;
  stack_push(interpreter, &interpreter->ctx.control_stack, expr NEXT(),  STACK_ENTRY_DESTINATION, STACK_CLEANUP_NULL);
  loc = INTVAL2PTR(opcode_t *, $1);
  goto ADDRESS(loc);
}


########################################

=item B<jump>(in INT)

Jump to the address held in register $1.

=cut

inline op jump(in INT) {
  opcode_t * loc;
  loc = INTVAL2PTR(opcode_t *, $1);
  goto ADDRESS(loc);
}

########################################

=item B<enternative>()

Internal opcode used to jump from normal bytecode into a JITted version.

=cut

op enternative() {
  goto ADDRESS(( run_native(interpreter, CUR_OPCODE, interpreter->code->byte_code) ));
}

=back

=cut

###############################################################################

=head2 Conditional branch operations

These operations perform a conditional relative branch. If the condition is
met, the branch happens, otherwise control falls to the next operation.

=over 4

=cut

########################################

=item B<if>(in INT, inconst INT)

=item B<if>(in NUM, inconst INT)

=item B<if>(in PMC, inconst INT)

=item B<if>(in STR, inconst INT)

Check register $1. If true, branch by $2.

=cut

inline op if(in INT, inconst INT) {
  if ($1 != 0) {
    goto OFFSET($2);
  }
  goto NEXT();
}

inline op if(in NUM, inconst INT) {
  if ($1 != 0.0) {
    goto OFFSET($2);
  }
  goto NEXT();
}

op if (in STR, inconst INT) {
  if (string_bool($1)) {
    goto OFFSET($2);
  }
  goto NEXT();
}

op if(in PMC, inconst INT) {
  if ($1->vtable->get_bool(interpreter, $1)) {
    goto OFFSET($2);
  }
  goto NEXT();
}

########################################

=item B<unless>(in INT, inconst INT)

=item B<unless>(in NUM, inconst INT)

=item B<unless>(in PMC, inconst INT)

=item B<unless>(in STR, inconst INT)

Check register $1. If false, branch by $2.

=cut

inline op unless(in INT, inconst INT) {
  if ($1 == 0) {
    goto OFFSET($2);
  }
  goto NEXT();
}

inline op unless(in NUM, inconst INT) {
  if ($1 == 0.0) {
    goto OFFSET($2);
  }
  goto NEXT();
}

op unless (in STR, inconst INT) {
  if (!string_bool($1)) {
    goto OFFSET($2);
  }
  goto NEXT();
}

op unless(in PMC, inconst INT) {
  if (!$1->vtable->get_bool(interpreter, $1)) {
    goto OFFSET($2);
  }
  goto NEXT();
}

=back

=cut

###############################################################################

=head2 Subroutine  operations

These operations are used to generate and call subroutines and
continuations.

=over 4

=cut

########################################

=item B<invoke>()

Call the subroutine in P0, with parrot calling convention as
described in PDD03.

=item B<invoke>(in PMC)

Call the subroutine in $1 with no defined calling convention or invoke
a continuation for returning from a subroutine.

=item B<invokecc>()

Call the subroutine in P0 and generate a new return continuation in P1.

=item B<invokecc>(in PMC)

Call the subroutine in $1 and generate a new return continuation in P1.

=item B<updatecc>()

Update the state of the return continuation in P1. This is necessary,
when any context stuff was changed between creating the return continuation
and invoke'ing it.

=cut

inline op invoke() {
  opcode_t *dest;
  PMC * p = interpreter->pmc_reg.registers[0];

  dest = (opcode_t *)p->vtable->invoke(interpreter, p, expr NEXT());

  goto ADDRESS(dest);
}

inline op invoke(in PMC) {
  opcode_t *dest;
  PMC * p = $1;

  dest = (opcode_t *)p->vtable->invoke(interpreter, p, expr NEXT());

  goto ADDRESS(dest);
}

inline op invokecc() {
  opcode_t *dest;
  PMC * p = interpreter->pmc_reg.registers[0];
  dest = expr NEXT();
  REG_PMC(1) = new_ret_continuation_pmc(interpreter, dest);
  dest = (opcode_t *)p->vtable->invoke(interpreter, p, dest);

  goto ADDRESS(dest);
}

inline op invokecc(in PMC) {
  opcode_t *dest;
  PMC * p = $1;
  dest = expr NEXT();
  REG_PMC(1) = new_ret_continuation_pmc(interpreter, dest);
  dest = (opcode_t *)p->vtable->invoke(interpreter, p, dest);
  goto ADDRESS(dest);
}

inline op updatecc() {
  struct Parrot_Sub *sub = (struct Parrot_Sub*) PMC_sub(REG_PMC(1));
  /* update context */
  save_context(interpreter, &sub->ctx);
  goto NEXT();
}

########################################

=item B<set_addr>(out INT, in INT)

Sets register $1 to the current address plus the offset $2.

=item B<set_addr>(in PMC, in INT)

Sets PMC in register $1 to the current address plus the offset $2.

=cut

inline op set_addr(out INT, inconst INT) {
  $1 = PTR2OPCODE_T(CUR_OPCODE + $2);
  goto NEXT();
}

inline op set_addr(in PMC, inconst INT) {
  $1->vtable->set_integer_native(interpreter, $1, PTR2OPCODE_T(CUR_OPCODE + $2));
  goto NEXT();
}

=item B<newsub>(out PMC, in INT, inconst INT)

Generate a new subroutine object in $1 of class $2 and label $3.

=item B<newsub>(in INT, in INT, inconst INT, inconst INT)

Generate a new subroutine object in P0 of class $1 subroutine label $3 and
a return continuation in P1 of class $2 and return address $4.

=cut

inline op newsub(out PMC, in INT, inconst INT) {
  if ($2 <= 0 || $2 >= enum_class_max) {
    internal_exception(1, "Illegal PMC enum (%d) in newsub\n", (int)$2);
    abort(); /* Deserve to lose */
  }
  $1 = pmc_new_noinit(interpreter, $2);
  $1->vtable->init(interpreter, $1);
  VTABLE_set_integer_native(interpreter, $1,
  	PTR2OPCODE_T(CUR_OPCODE + $3));
  goto NEXT();
}

inline op newsub(in INT, in INT, inconst INT, inconst INT) {
  if ($1 <= 0 || $1 >= enum_class_max) {
    internal_exception(1, "Illegal PMC enum (%d) in newsub\n", (int)$1);
    abort(); /* Deserve to lose */
  }
  if ($2 <= 0 || $2 >= enum_class_max) {
    internal_exception(1, "Illegal PMC enum (%d) in newsub\n", (int)$2);
    abort(); /* Deserve to lose */
  }
  interpreter->pmc_reg.registers[0] = pmc_new_noinit(interpreter, $1);
  VTABLE_init(interpreter, interpreter->pmc_reg.registers[0]);
  VTABLE_set_integer_native(interpreter, interpreter->pmc_reg.registers[0],
      PTR2OPCODE_T(CUR_OPCODE + $3));
  interpreter->pmc_reg.registers[1] = pmc_new_noinit(interpreter, $2);
  VTABLE_init(interpreter, interpreter->pmc_reg.registers[1]);
  VTABLE_set_integer_native(interpreter, interpreter->pmc_reg.registers[1],
      PTR2OPCODE_T(CUR_OPCODE + $4));
  goto NEXT();
}

=back

=cut

########################################

=head2 Exception handling

=over 4

=item B<set_eh>(in PMC)

Push the exception handler in $1 on the control stack.

=item B<clear_eh>()

Clear out the most recently placed exception.

=item B<throw>(in PMC)

Throw the exception in $1.

=item B<rethrow>(in PMC)

Only valid inside an exception handler. Rethrow the exception $1.

=item B<die_hard>(in INT, in INT)

Die with severity $1 and error $2.

=item B<exit>(in INT)

Exit the interpreter with exit_status $1. If you want to communicate an
extended exit status, create an exception with severity B<EXCEPT_exit>
and throw it.

=cut

inline op set_eh(in PMC) {
  push_exception(interpreter, $1);
  goto NEXT();
}

inline op clear_eh() {
  pop_exception(interpreter);
  goto NEXT();
}

inline op throw(in PMC) {
  opcode_t *ret = expr NEXT();
  opcode_t *dest = (opcode_t *)throw_exception(interpreter, $1, ret);
  goto ADDRESS(dest);
}

inline op rethrow(in PMC) {
  opcode_t *dest = (opcode_t *)rethrow_exception(interpreter, $1);
  goto ADDRESS(dest);
}

inline op die_hard(in INT, in INT) {
  do_exception($1, $2);
  restart NEXT();
}

inline op exit(in INT) {
  do_exception(EXCEPT_exit, $1);
  restart NEXT();
}
=back

=cut

###############################################################################

=head2 Interpreter operations

These operations inspect or modify the interpreter itself, possibly
affecting its subsequent operation.

=over 4

=cut

########################################

=item B<debug>(in INT)

If $1 is zero, turn off debugging. Otherwise turn it on.

=cut

inline op debug(in INT) {
  if ($1 != 0) { Interp_flags_SET(interpreter,   PARROT_DEBUG_FLAG); }
  else         { Interp_flags_CLEAR(interpreter, PARROT_DEBUG_FLAG); }
  restart NEXT();
}


########################################

=item B<bounds>(in INT)

If $1 is zero, turn off byte code bounds checking. Otherwise turn it on.

=cut

inline op bounds(in INT) {
  if ($1 != 0) { Parrot_set_flag(interpreter,   PARROT_BOUNDS_FLAG); }
  else         { Interp_flags_CLEAR(interpreter, PARROT_BOUNDS_FLAG); }
  restart NEXT();
}


########################################

=item B<profile>(in INT)

If $1 is zero, turn off profiling. Otherwise turn it on.

=cut

inline op profile(in INT) {
  if ($1 != 0) { Parrot_set_flag(interpreter,   PARROT_PROFILE_FLAG); }
  else         { Interp_flags_CLEAR(interpreter, PARROT_PROFILE_FLAG); }
  restart NEXT();
}


########################################

=item B<trace>(in INT)

If $1 is zero, turn off tracing. Otherwise turn it on.

=cut

inline op trace(in INT) {
  if ($1 != 0) { Parrot_set_flag(interpreter,   PARROT_TRACE_FLAG); }
  else         { Interp_flags_CLEAR(interpreter, PARROT_TRACE_FLAG); }
  restart NEXT();
}

########################################

=item B<gc_debug>(in INT)

If $1 is zero, turn off GC_DEBUG. Otherwise turn it on.

=cut

inline op gc_debug(in INT) {
  if ($1 != 0) { Interp_flags_SET(interpreter,   PARROT_GC_DEBUG_FLAG); }
  else         { Interp_flags_CLEAR(interpreter, PARROT_GC_DEBUG_FLAG); }
  goto NEXT();
}

=cut

########################################

=item B<interpinfo>(out INT, in INT)

Fetch some piece of information about the interpreter and put it in $1.
Possible values for $2 are:

=over 4

=item 1 The total amount of allocatable memory allocated. This figure
does not include memory used for headers or for the interpreter's internal
structures.

=item 2 The number of dead object detection runs performed.

=item 3 The number of garbage collection runs performed.

=item 4 The number of active PMCs.

=item 5 The number of active buffers.

=item 6 The total number of PMCs allocated.

=item 7 The total number of buffers allocated.

=item 8 The number of headers (PMC or buffer) that have been allocated
since the last DOD run.

=item 9 The number of new blocks of memory allocated since the last GC run.

=item 10 The total amount of memory copied during garbage collections.

=back

=cut

op interpinfo(out INT, in INT) {
  $1 = interpinfo(interpreter, $2);
  goto NEXT();
}

=item B<warningson>(in INT)

Turns on warnings categories.  Categories already turned on will
stay on.  Current categories and the numbers they map to are:

=over 4

=item 1: undef

=item 2: IO

=item -1: all

=back

To turn on multiple categories, OR the category numbers together.

=cut

inline op warningson(in INT) {
  PARROT_WARNINGS_on(interpreter, $1);
  goto NEXT();
}

=item B<warningsoff>(in INT)

Turns off warnings categories.  Categories already turned off will
stay off.  See the documentation for B<warningson> for category
numbers.

=cut

inline op warningsoff(in INT) {
  PARROT_WARNINGS_off(interpreter, $1);
  goto NEXT();
}

########################################

=item B<runinterp>(in PMC, in INT)

Run the code starting at offset $2 within interpreter $1.

=item B<getinterp>(out PMC)

Get the current ParrotInterpreter.

=cut

op runinterp(in PMC, in INT) {
  struct Parrot_Interp * new_interp =
      (struct Parrot_Interp *)PMC_data($1);
  Interp_flags_SET(new_interp, PARROT_EXTERN_CODE_FLAG);
  new_interp->code = interpreter->code;
  runops(new_interp, REL_PC + $2);
  goto NEXT();
}

op getinterp(out PMC) {
  $1 = VTABLE_get_pmc_keyed_int(interpreter, interpreter->iglobals,
         IGLOBALS_INTERPRETER);
  goto NEXT();
}

#######################################

=item B<setline>(in INT)

Set the line number for which we're currently executing code.

=cut

inline op setline(in INT) {
  interpreter->current_line = $1;
  goto NEXT();
}

=item B<getline>(out INT)

Get the current line number.

=cut

inline op getline(out INT) {
  $1 = interpreter->current_line;
  goto NEXT();
}

=item B<setfile>(in STR)

Set the name of the file for which we're currently executing code.

=cut

inline op setfile(in STR) {
  interpreter->current_file = $1;
  goto NEXT();
}

=item B<getfile>(out STR)

Get the name of the current file.

=cut

inline op getfile(out STR) {
  $1 = interpreter->current_file;
  goto NEXT();
}

=item B<setpackage>(in STR)

Set the name of the package for which we're currently executing code.

=cut

inline op setpackage(in STR) {
  interpreter->current_package = $1;
  goto NEXT();
}

=item B<getpackage>(out STR)

Get the name of the current package.

=cut

inline op getpackage(out STR) {
  $1 = interpreter->current_package;
  goto NEXT();
}

=back

=cut

###############################################################################

=head2 Dead Object Detection/Garbage Collection

Opcodes that interact with the DOD and GC subsystems.

=over 4

=cut

########################################

=item B<sweep>(inconst INT)

0 ...  Trigger a DOD run only if there are things that have flagged
       themselves as really needing to be collected.
1 ...  Trigger a dead object detection (DOD) sweep unconditionally.

=cut

op sweep(inconst INT) {
  if ($1 || interpreter->has_early_DOD_PMCs)
    Parrot_do_dod_run(interpreter, 0);
  goto NEXT();
}

=item B<collect>()

Trigger a garbage collection.

=cut

op collect() {
  Parrot_go_collect(interpreter);
  goto NEXT();
}

=item B<sweepoff>()

Disable DOD sweeps. (Nestable)

=cut

op sweepoff() {
  Parrot_block_DOD(interpreter);
  goto NEXT();
}

=item B<sweepon>()

Re-enable DOD sweeps.

=cut

op sweepon() {
  Parrot_unblock_DOD(interpreter);
  goto NEXT();
}

=item B<collectoff>()

Disable GC runs (nestable).

=cut

op collectoff() {
  Parrot_block_GC(interpreter);
  goto NEXT();
}

=item B<collecton>()

Re-enable GC.

=cut

op collecton() {
  Parrot_unblock_GC(interpreter);
  goto NEXT();
}

=item B<needs_destroy>(in PMC)

Mark the PMC wanting destruction as soon as possible, i.e.
when unused during the lazy sweep, triggered by "sweep 0".

=cut

op needs_destroy(in PMC) {
   PObj_needs_early_DOD_SET($1);
   interpreter->has_early_DOD_PMCs = 1;
  goto NEXT();
}

=back

=cut

###############################################################################

=head2 Native Call Interface

Opcodes for interfacing with C functions in shared libraries.

=over 4

=cut

########################################

=item B<loadlib>(out PMC, in STR)

Load a dynamic link library named $2 and store it in $1.

=item B<dlfunc>(out PMC, in PMC, in STR, in STR)

Look up symbol $3 in library $2 with signature $4, and put the
corresponding sub object in $1. Note that you need the signature so we
can build or find an appropriate thunking function.

=item B<dlvar>(out PMC, in PMC, in STR)

Look up symbol $3 in library $2. We assume that this is actually a
variable address rather than a function address, and build an
unmanagedstruct PMC and stick the address into its data pointer.

=item B<compile>(out PMC, in PMC, in STR)

Compile source code $3 with compiler $2 into PMC $1.

=item B<compreg>(out PMC, in STR)

Get a compiler for source type $2.

=item B<compreg>(in STR, in PMC)

Register the sub $2 as a compiler for source type $1.
XXX: leo: N/Y how would we get the C-subroutine?

=item B<compreg>(in STR, in INT)

Register the PASM sub at address $2 as a compiler for source type $1.
XXX: leo N/Y

=cut

inline op loadlib(out PMC, in STR) {

  $1 = Parrot_load_lib(interpreter, $2, NULL);
  goto NEXT();
}

op dlfunc (out PMC, in PMC, in STR, in STR) {
  char * name = string_to_cstring(interpreter, ($3));
  PMC *nci;

  Parrot_csub_t p = (Parrot_csub_t)D2FPTR(
	  Parrot_dlsym(PMC_IS_NULL($2) ? NULL : PMC_data($2), name));
  if (p == NULL) {
      const char * err = Parrot_dlerror();
      Parrot_warn(interpreter, PARROT_WARNINGS_UNDEF_FLAG,
	 "Symbol '%s' not found: %s\n", name, err ? err : "unkown reason");
      $1 = pmc_new(interpreter, enum_class_PerlUndef);
  }
  else {
      $1 = nci = pmc_new(interpreter, enum_class_NCI);
      nci->vtable->set_string_keyed(interpreter, nci, (PMC*)F2DPTR(p), $4);
  }
  string_cstring_free(name);
  goto NEXT();
}

op dlvar (out PMC, in PMC, in STR) {
  char * name = string_to_cstring(interpreter, ($3));

  PMC *final_destination = pmc_new(interpreter, enum_class_UnManagedStruct);

  void *p = Parrot_dlsym(PMC_IS_NULL($2) ? NULL : PMC_data($2), name);
  string_cstring_free(name);
  if(p == NULL) {
    const char * err = Parrot_dlerror();
    if(err != NULL) {
      fprintf(stderr, "%s\n", err);
    }
    PANIC("Failed to link native method");
  }

  /* At this point we have the symbol's address. We just need to build
     a PMC with it so we can get and set the value */

  PMC_data(final_destination) = p;
  $1 = final_destination;
  goto NEXT();
}

inline op compile(OUT PMC, in PMC, in STR) {
  $1 = $2->vtable->invoke(interpreter, $2, $3);
  goto NEXT();
}

inline op compreg(OUT PMC, in STR) {
  PMC *key = key_new_string(interpreter, $2);
  PMC *compreg_hash = VTABLE_get_pmc_keyed_int(interpreter,
      interpreter->iglobals, IGLOBALS_COMPREG_HASH);
  $1 = VTABLE_get_pmc_keyed(interpreter, compreg_hash, key);
  goto NEXT();
}

inline op bogus() {
  goto NEXT();
}

=back

=cut

###############################################################################

=head1 COPYRIGHT

Copyright (C) 2001-2003 The Perl Foundation.  All rights reserved.

=head1 LICENSE

This program is free software. It is subject to the same license
as the Parrot interpreter itself.

=cut
