/* File:      subp.c
** Author(s): Warren, Swift, Xu, Sagonas, Johnson
** Contact:   xsb-contact@cs.sunysb.edu
** 
** Copyright (C) The Research Foundation of SUNY, 1986, 1993-1998
** Copyright (C) ECRC, Germany, 1990
** 
** XSB is free software; you can redistribute it and/or modify it under the
** terms of the GNU Library General Public License as published by the Free
** Software Foundation; either version 2 of the License, or (at your option)
** any later version.
** 
** XSB is distributed in the hope that it will be useful, but WITHOUT ANY
** WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
** FOR A PARTICULAR PURPOSE.  See the GNU Library General Public License for
** more details.
** 
** You should have received a copy of the GNU Library General Public License
** along with XSB; if not, write to the Free Software Foundation,
** Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
**
** $Id: subp.c,v 1.67 2002/11/04 18:09:03 dwarren Exp $
** 
*/


/* xsb_config.h must be the first #include.  Pls don't move it! */
#include "xsb_config.h"
#include "xsb_debug.h"

#include "debugs/debug_attv.h"

#include <stdio.h>
#include <signal.h>

#ifdef WIN_NT
#include <windows.h>
#include <process.h>	/* _beginthread, _endthread */
#include <stddef.h>
#include <stdlib.h>
#include <winsock.h>
#include <io.h>
#include <string.h>
#endif

#include "auxlry.h"
#include "cell_xsb.h"
#include "error_xsb.h"
#include "psc_xsb.h"
#include "memory_xsb.h"
#include "register.h"
#include "heap_xsb.h"
#include "deref.h"
#include "flags_xsb.h"
#include "binding.h"
#include "trie_internals.h"
#include "trassert.h"
#include "choice.h"
#include "token_xsb.h"
#include "sig_xsb.h"
#include "inst_xsb.h"
#include "macro_xsb.h"
#include "table_stats.h"
#include "unify_xsb.h"
#include "debug_xsb.h"
#include "hash_xsb.h"

/*======================================================================*/
/*======================================================================*/

/* attv_dbgmsg() is used in unify_xsb_i.h */

#undef IFTHEN_FAILED
#define IFTHEN_FAILED	return 0
#undef IFTHEN_SUCCEED
#define IFTHEN_SUCCEED	return 1

double realtime_count;

extern int asynint_val;	/* 0 - no interrupt (or being processed) */
extern int asynint_code;	/* 0 means keyboard interrupt */

extern void dis(xsbBool), debug_call(Psc);
extern void total_stat(double);
extern void perproc_stat(void), perproc_reset_stat(void), reset_stat_total(void); 

#ifdef LINUX
static struct sigaction act, oact;
#endif

void (*xsb_default_segfault_handler)(int); /* where the previous value of the
					     SIGSEGV/SIGBUS handler is saved */

Cell attv_interrupts[20480][2];

/*
 * Put an attv interrupt into the interrupt chain. op1 is the related
 * attv, and op2 is the value (see verify_attributes/2).
 */

void add_interrupt(Cell op1, Cell op2) {
  int num;

#ifndef PRE_IMAGE_TRAIL
#error "PRE_IMAGE_TRAIL has to be defined for add_interrupt() !"
#else
  num = int_val(cell(interrupt_reg));
  /**printf("interrupt count = %d\n",num);**/
  push_pre_image_trail(&(attv_interrupts[num][0]), op1);
  attv_interrupts[num][0] = op1;
  push_pre_image_trail(&(attv_interrupts[num][1]), op2);
  attv_interrupts[num][1] = op2;
  num++;
  push_pre_image_trail(interrupt_reg, makeint(num));
  bld_int(interrupt_reg, num);

#endif
}


Cell build_interrupt_chain(void) {
  Cell head;
  CPtr tmp = &head;
  int num, i;

  num = int_val(cell(interrupt_reg));
  for (i = 0; i < num; i++) {
    bld_list(tmp, hreg);
    sreg = hreg + 2;
    bld_list(hreg, sreg); hreg++;
    if (i == (num - 1)) {
      bind_nil(hreg);
    }
    else
      tmp = hreg;
    bld_copy(sreg, attv_interrupts[i][0]); sreg++;
    bld_copy(sreg, attv_interrupts[i][1]); sreg++;
    hreg = sreg;
  }

#ifndef PRE_IMAGE_TRAIL
#error "PRE_IMAGE_TRAIL has to be defined for synint_proc() !"
#else
  /* Reset the interrupt counter to 0 for further attv interrupts. */
  push_pre_image_trail(interrupt_reg, makeint(0));
#endif

  bld_int(interrupt_reg, 0);

  return head;
}

/*======================================================================*/
/*  Unification routines.						*/
/*======================================================================*/

xsbBool unify(Cell rop1, Cell rop2)
{ /* begin unify */
  register Cell op1, op2;

  op1 = rop1; op2 = rop2;

/*----------------------------------------*/
  unify_xsb(unify);
  /* unify_xsb_i already ends with this statement
     IFTHEN_SUCCEED;
  */
/*----------------------------------------*/

}  /* end of unify */

/*======================================================================*/
/*  Determining whether two terms are identical.			*/
/*======================================================================*/

xsbBool are_identical_terms(Cell term1, Cell term2) {

  XSB_Deref(term1);
  XSB_Deref(term2);
  
  if ( term1 == term2 )
    return TRUE;

  if ( cell_tag(term1) != cell_tag(term2) )
    return FALSE;

  if ( cell_tag(term1) == XSB_STRUCT ) {
    CPtr cptr1 = clref_val(term1);
    CPtr cptr2 = clref_val(term2);
    Psc psc1 = (Psc)*cptr1;
    int i;

    if ( psc1 != (Psc)*cptr2 )
      return FALSE;

    for ( cptr1++, cptr2++, i = 0;  i < (int)get_arity(psc1);  i++ )
      if ( ! are_identical_terms(*cptr1,*cptr2) ) 
	return FALSE;

    return TRUE;
  }
  else if ( cell_tag(term1) == XSB_LIST ) {
    CPtr cptr1 = clref_val(term1);
    CPtr cptr2 = clref_val(term2);

    if ( are_identical_terms(*cptr1, *cptr2) &&
	 are_identical_terms(*(cptr1 + 1), *(cptr2 + 1)) )
      return TRUE;
    else
      return FALSE;
  }
  else
    return FALSE;
}

/*======================================================================*/
/*  Print statistics and measurements.					*/
/*======================================================================*/

/*
 * Called through builtins statistics/1 and statistics/0.
 * ( statistics :- statistics(1). )
 */
void print_statistics(int amount) {

  switch (amount) {
  case 0:		    /* Reset Statistical Parameters */
    realtime_count = real_time();
    perproc_reset_stat();	/* reset op-counts, starting time, and 'tds'
				   struct variable (all 0's) */
    reset_stat_total(); 	/* reset 'ttt' struct variable (all 0's) */
    xsb_mesg("Statistics is reset.");
    break;
  case 1:		    /* Print Stack Usage and CPUtime: */
    perproc_stat();		/* move max usage into 'ttt' struct variable */
    total_stat(real_time()-realtime_count);   /* print */
    reset_stat_total(); 	/* reset 'ttt' struct variable (all 0's) */
    break;
  case 2:		    /* Print Detailed Table Usage */
    print_detailed_tablespace_stats();
    break;
  case 3:		    /* Print Detailed Table, Stack, and CPUtime */
    perproc_stat();
    total_stat(real_time()-realtime_count);
    reset_stat_total();
    print_detailed_tablespace_stats();
    print_detailed_subsumption_stats();
    break;
  case 5:
    dis(0); 
    break;		/* output memory image; for debugging */
  case 6:
    dis(1); 
    break;		/* output memory image; for debugging */
#ifdef CP_DEBUG
  case 7:
    print_cp_backtrace();
    break;
#endif
  case 8:
    symbol_table_stats();
    string_table_stats();
    break;
  }
}

/*======================================================================*/
/*======================================================================*/

static void default_inthandler(int intcode)
{
  char message[80];

  switch (intcode) {
  case MYSIG_UNDEF:
    xsb_exit("Undefined predicate; exiting by the default handler.");
    break;
  case MYSIG_KEYB:
    xsb_exit("Keyboard interrupt; exiting by the default handler.");
    break;
  case MYSIG_PSC:
    break;
  default:
    sprintf(message,
	    "Unknown interrupt (%d) occured; exiting by the default handler", 
	    intcode);
    xsb_exit(message);
    break;
  }
}

/*======================================================================*/
/* builds the current call onto the heap and returns a pointer to it.	*/
/*======================================================================*/

Pair build_call(Psc psc)
{
  register Cell arg;
  register Pair callstr;
  register int i;

  callstr = (Pair)hreg; /* save addr of new structure rec */
  new_heap_functor(hreg, psc); /* set str psc ptr */
  for (i=1; i <= (int)get_arity(psc); i++) {
    arg = cell(reg+i);
    nbldval(arg);
  }
  return callstr;
}

/*======================================================================*/
/* set interrupt code in reg 2 and return ep of interrupt handler.	*/
/* the returned value is normally assigned to pcreg, so this is like	*/
/* raising a trap.							*/
/* Note that the interrupt handlers referred to by flags array values   */
/* are set up on the Prolog side via set_inthandler/2                   */
/*======================================================================*/

Psc synint_proc(Psc psc, int intcode)
{
  if (flags[intcode+INT_HANDLERS_FLAGS_START]==(Cell)0) {
    /* default hard handler */
    default_inthandler(intcode);
    psc = 0;
  } else {				/* call Prolog handler */
    switch (intcode) {
    case MYSIG_UNDEF:		/*  0 */
    case MYSIG_KEYB:		/*  1 */
    case MYSIG_SPY:		/*  3 */
    case MYSIG_TRACE:		/*  4 */
    case MYSIG_CLAUSE:		/* 16 */
      if (psc) bld_cs(reg+1, build_call(psc));
      psc = (Psc)flags[intcode+INT_HANDLERS_FLAGS_START];
      bld_int(reg+2, asynint_code);
      pcreg = get_ep(psc);
      break;
    case MYSIG_ATTV:		/*  8 */
      /* the old call must be built first */
      if (psc)
	bld_cs(reg+2, build_call(psc));
      psc = (Psc)flags[intcode+INT_HANDLERS_FLAGS_START];
      /*
       * Pass the interrupt chain to reg 1.  The counter of attv
       * interrupts (stored in *interrupt_reg) will be reset to 0 in
       * build_interrupt_chain()).
       */
      bld_copy(reg + 1, build_interrupt_chain());
      /* bld_int(reg + 3, intcode); */	/* Not really needed */
      pcreg = get_ep(psc);
      break;
    default:
      xsb_abort("Unknown intcode in synint_proc()");
    } /* switch */
  }
  return psc;
}

void init_interrupt(void);

/* TLS: 2/02 removed "inline static" modifiers so that this function
   can be called from interprolog_callback.c */
void keyint_proc(int sig)
{
#ifndef LINUX
  init_interrupt();  /* reset interrupt, if using signal */
#endif
  if (asynint_val & KEYINT_MARK) {
    xsb_abort("unhandled keyboard interrupt");
  } else {
    asynint_val |= KEYINT_MARK;
    asynint_code = 0;
  }
}

void init_interrupt(void)
{
#if (defined(LINUX))
  act.sa_handler = keyint_proc;
  sigemptyset(&act.sa_mask); 
  act.sa_flags = 0;
  sigaction(SIGINT, &act, &oact);
#else
  signal(SIGINT, keyint_proc); 
#endif

#if (defined(DEBUG_VERBOSE) || defined(DEBUG_VM) || defined(DEBUG_ASSERTIONS))
  /* Don't handle SIGSEGV/SIGBUS if configured with DEBUG */
  xsb_default_segfault_handler = SIG_DFL;
#else 
  xsb_default_segfault_handler = xsb_segfault_quitter;
#endif

#ifdef SIGBUS
  signal(SIGBUS, xsb_default_segfault_handler);
#endif
  signal(SIGSEGV, xsb_default_segfault_handler);
}


/*
 * Maintains max stack usage when "-s" option is given at startup.
 */
void intercept(Psc psc) {

  if (flags[CLAUSE_INT])
    synint_proc(psc, MYSIG_CLAUSE);
  else if (flags[DEBUG_ON] && !flags[HIDE_STATE]) {
    if (get_spy(psc)) { /* spy'ed pred, interrupted */
      synint_proc(psc, MYSIG_SPY);
      flags[HIDE_STATE]++; /* hide interrupt handler */
    }
    else if (flags[TRACE]) {
      synint_proc(psc, MYSIG_TRACE);
      flags[HIDE_STATE]++; /* hide interrupt handler */
    }
  }
  if (flags[HITRACE])
    debug_call(psc);

  if (flags[TRACE_STA]) {
    unsigned long  byte_size;

    byte_size = (top_of_heap - (CPtr)(glstack.low) + 1) * sizeof(Cell);
    if ( byte_size > tds.maxgstack_count )
      tds.maxgstack_count = byte_size;

    byte_size = ((CPtr)glstack.high - top_of_localstk) * sizeof(Cell);
    if ( byte_size > tds.maxlstack_count )
      tds.maxlstack_count = byte_size;

    byte_size = (top_of_trail - (CPtr *)tcpstack.low + 1) * sizeof(CPtr);
    if ( byte_size > tds.maxtrail_count )
      tds.maxtrail_count = byte_size;

    byte_size = ((CPtr)tcpstack.high - top_of_cpstack) * sizeof(Cell);
    if ( byte_size > tds.maxcpstack_count )
      tds.maxcpstack_count = byte_size;

    byte_size = ((CPtr)complstack.high - top_of_complstk) * sizeof(Cell);
    if ( byte_size > tds.maxopenstack_count )
      tds.maxopenstack_count = byte_size;

    if ((unsigned long)level_num > tds.maxlevel_num)
      tds.maxlevel_num = level_num;
  }
}

/*======================================================================*/
/* floating point conversions						*/
/*======================================================================*/

/* lose some precision in conversions from 32 bit formats */
#ifdef BITS64
#define FLOAT_MASK 0xfffffffffffffff8
#else
#define FLOAT_MASK 0xfffffff8
#endif

static union float_conv {
  Float f;
  Cell i;
} float_conv;

Float getfloatval(Cell w)
{
  float_conv.i = w & FLOAT_MASK;
  return float_conv.f;
}

Cell makefloat(Float f)
{
  float_conv.f = f;
  return ( float_conv.i & FLOAT_MASK ) | XSB_FLOAT;
}

Float asfloat(Cell w)
{
  float_conv.i = w;
  return float_conv.f;
}

static inline int sign(Float num)
{
  if (num==0.0) return 0;
  else if (num>0.0) return 1;
  else return -1;
}

/*======================================================================*/
/* compare(V1, V2)							*/
/*	compares two terms; returns zero if V1=V2, a positive value	*/
/*	if V1>V2 and a negative value if V1<V2.  Term comparison is	*/
/*	done according to the ISO standard total order of Prolog	*/
/*	terms which is as follows:					*/
/*									*/
/*	    variables < floats < integers < atoms < compound terms	*/
/*									*/
/*	A list is compared as an ordinary compound term with arity	*/
/*	2 and functor '.'.						*/
/*									*/
/*	This function was rewritten from scratch by Kostis so that	*/
/*	it is independent of the relative order of tag encoding.	*/
/*	However, it should ONLY be used to compare terms that appear	*/
/*	in the above ordering list.					*/
/*======================================================================*/

int compare(const void * v1, const void * v2)
{
  int comp;
  CPtr cptr1, cptr2;
  Cell val1 = (Cell) v1 ;
  Cell val2 = (Cell) v2 ;

  XSB_Deref(val2);		/* val2 is not in register! */
  XSB_Deref(val1);		/* val1 is not in register! */
  if (val1 == val2) return 0;
  switch(cell_tag(val1)) {
  case XSB_FREE:
  case XSB_REF1:
    if (isattv(val2))
      return vptr(val1) - (CPtr)dec_addr(val2);
    else if (isnonvar(val2)) return -1;
    else { /* in case there exist local stack variables in the	  */
	   /* comparison, globalize them to guarantee that their  */
	   /* order is retained as long as nobody "touches" them  */
	   /* in the future -- without copying garbage collection */
      if ((top_of_localstk <= vptr(val1)) &&
	  (vptr(val1) <= (CPtr)glstack.high-1)) {
	bld_free(hreg);
	bind_ref(vptr(val1), hreg);
	hreg++;
	val1 = follow(val1);	/* deref again */
      }
      if ((top_of_localstk <= vptr(val2)) &&
	  (vptr(val2) <= (CPtr)glstack.high-1)) {
	bld_free(hreg);
	bind_ref(vptr(val2), hreg);
	hreg++;
	val2 = follow(val2);	/* deref again */
      }
      return vptr(val1) - vptr(val2);
    }
  case XSB_FLOAT:
    if (isref(val2) || isattv(val2)) return 1;
    else if (isfloat(val2)) 
      return sign(float_val(val1) - float_val(val2));
    else return -1;
  case XSB_INT:
    if (isref(val2) || isfloat(val2) || isattv(val2)) return 1;
    else if (isinteger(val2)) 
      return int_val(val1) - int_val(val2);
    else if (isboxedinteger(val2))
      return int_val(val1) - boxedint_val(val2);
    else return -1;
  case XSB_STRING:
    if (isref(val2) || isfloat(val2) || isinteger(val2) || isattv(val2)) 
      return 1;
    else if (isstring(val2)) {
      return strcmp(string_val(val1), string_val(val2));
    }
    else return -1;
  case XSB_STRUCT:
    if (isboxedinteger(val1)) {
      if (isref(val2) || isfloat(val2) || isattv(val2)) return 1;
      else if (isinteger(val2)) 
	return boxedint_val(val1) - int_val(val2);
      else if (isboxedinteger(val2))
	return boxedint_val(val1) - boxedint_val(val2);
      else return -1;
    } else if (cell_tag(val2) != XSB_STRUCT && cell_tag(val2) != XSB_LIST) return 1;
    else {
      int arity1, arity2;
      Psc ptr1 = get_str_psc(val1);
      Psc ptr2 = get_str_psc(val2);

      arity1 = get_arity(ptr1);
      if (islist(val2)) arity2 = 2; 
      else arity2 = get_arity(ptr2);
      if (arity1 != arity2) return arity1-arity2;
      if (islist(val2)) comp = strcmp(get_name(ptr1), ".");
      else comp = strcmp(get_name(ptr1), get_name(ptr2));
      if (comp || (arity1 == 0)) return comp;
      cptr1 = clref_val(val1);
      cptr2 = clref_val(val2);
      for (arity2 = 1; arity2 <= arity1; arity2++) {
	if (islist(val2))
	  comp = compare((void*)cell(cptr1+arity2), (void*)cell(cptr2+arity2-1));  
	else
	  comp = compare((void*)cell(cptr1+arity2), (void*)cell(cptr2+arity2));
	if (comp) break;
      }
      return comp;
    }
    break;
  case XSB_LIST:
    if (cell_tag(val2) != XSB_STRUCT && cell_tag(val2) != XSB_LIST) return 1;
    else if (isconstr(val2)) return -(compare((void*)val2, (void*)val1));
    else {	/* Here we are comparing two list structures. */
      cptr1 = clref_val(val1);
      cptr2 = clref_val(val2);
      comp = compare((void*)cell(cptr1), (void*)cell(cptr2));
      if (comp) return comp;
      return compare((void*)cell(cptr1+1), (void*)cell(cptr2+1));
    }
    break;
  case XSB_ATTV:
    if (isattv(val2))
      return (CPtr)dec_addr(val1) - (CPtr)dec_addr(val2);
    else if (isref(val2))
      return (CPtr)dec_addr(val1) - vptr(val2);
    else
      return -1;
  default:
    xsb_abort("Compare (unknown tag %ld); returning 0", cell_tag(val1));
    return 0;
  }
}

/*======================================================================*/
/* key_compare(V1, V2)							*/
/*	compares the keys of two terms of the form Key-Value; returns	*/
/*	zero if Key1=Key2, a positive value if Key1>Key2 and a negative */
/*	value if Key1<Key2.  Term comparison is done according to the	*/
/*	standard total order of Prolog terms (see compare()).		*/
/*======================================================================*/

int key_compare(const void * t1, const void * t2)
{
  Cell term1 = (Cell) t1 ;
  Cell term2 = (Cell) t2 ;

  XSB_Deref(term1);		/* term1 is not in register! */
  XSB_Deref(term2);		/* term2 is not in register! */
  return compare((void*)cell(clref_val(term1)+1), (void*)cell(clref_val(term2)+1));
}

/*======================================================================*/
/* print an atom, quote it if necessary.				*/
/*======================================================================*/

void print_qatom(FILE *file, char *string)
{
  char *s;
  int need_quote = 0, type;

  if (intype(*string) != LOWER) need_quote = 1;
  else {
    s = string;    
    while (*s) {
      type = intype(*s);
      if (type != LOWER && type != UPPER && type != DIGIT && type != BREAK) {
	need_quote = 1; break; 
      }
      s++;
    }
  }
  if (need_quote) fprintf(file, "'%s'", string);
  else fprintf(file, "%s", string);
}

/*======================================================================*/
/* print an operator.							*/
/*======================================================================*/

void print_op(FILE *file, char *string, int pos)
{
  char *s;
  int need_blank = 0;

  s = string;
  while (*s) { 
    if (intype(*s) != SIGN) { need_blank = 1; break;} 
    s++;
  }
  if (need_blank) {
    switch (pos) {
      case 1: print_qatom(file, string); putc(' ', file); break;
      case 2: putc(' ', file);
	      print_qatom(file, string); putc(' ', file); break;
      case 3: putc(' ', file); print_qatom(file, string); break;
    }
  } else fprintf(file, "%s", string);
}

/* ----- The following is also called from the Prolog level ----------- */

void remove_open_tables_reset_freezes(void)
{
  if (xwammode) {
    remove_open_tables();
    reset_freeze_registers;
  }
}

/* ----- C level exception handlers ----------------------------------- */

/* SIGSEGV/SIGBUS handler that catches segfaults; used unless 
   configured with DEBUG */ 
void xsb_segfault_catcher(int err)
{
  char *tmp_message = xsb_segfault_message;
  xsb_segfault_message = xsb_default_segfault_msg; /* restore default */
  printf("segfault!!\n");
  xsb_basic_abort(tmp_message);
}

void xsb_segfault_quitter(int err)
{
  xsb_exit(xsb_segfault_message);
}

#ifdef WIN_NT
/* Our separate thread */
void checkJavaInterrupt(void *info)
{
  char ch;
  SOCKET intSocket = (SOCKET)info;
  xsb_dbgmsg((LOG_DEBUG, "Thread started on socket %ld",(int)intSocket));
  while(1){
    if (1!=recv(intSocket,&ch,1,0)) {
      xsb_warn("Problem handling interrupt from Java");
    }
    else 
      xsb_mesg("--- Java interrupt detected");
    /* Avoid those annoying lags? */
    fflush(stdout);
    fflush(stderr);
    fflush(stdmsg);
    fflush(stdwarn);
    fflush(stddbg);
    keyint_proc(SIGINT); /* Do XSB's "interrupt" thing */
  }
}

xsbBool startInterruptThread(SOCKET intSocket)
{
  xsb_mesg("Beginning interrupt thread on socket %ld",(int)intSocket);
#ifdef _MT
  _beginthread( checkJavaInterrupt, 0, (void*)intSocket );
#endif
  return 1;
}
#endif