/* --------------------------------------------------------------------------
 * Implementation of primitives which provide access to internal Hugs
 * data structures and representations from within Haskell.
 *
 * Despite appearances, the only primitives which break referential
 * transparency are the pointer equality primitives.
 *
 * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
 * Yale Haskell Group, and the OGI School of Science & Engineering at OHSU,
 * 1994-2003, All rights reserved.  It is distributed as free software under
 * the license in the file "License", which is included in the distribution.
 *
 * $RCSfile: interns.c,v $
 * $Revision: 1.12 $
 * $Date: 2003/10/14 13:56:23 $
 * ------------------------------------------------------------------------*/
 
/* --------------------------------------------------------------------------
 * internalPrims control
 * ------------------------------------------------------------------------*/

static Void linkInternals Args((Void));

static Name nameLeft;			/* standard data constructors      */
static Name nameRight;			

static Void local internalControl Args((Int));
static Void local internalControl(what)
Int what; {
    switch (what) {
	case INSTALL : 
#define predef(nm,str) nm=newName(findText(str),NIL); name(nm).defn=PREDEFINED
		       setCurrModule(modulePrelude);
		       predef(nameLeft,       "Left");
		       predef(nameRight,      "Right");
#undef predef
		       break;

	case RESET :   linkInternals();
		       break;
    }
}

PROTO_PRIM(primGetCell);
PROTO_PRIM(primCellPtrEq);
PROTO_PRIM(primCatchError2);
PROTO_PRIM(primClassifyCell);
PROTO_PRIM(primNameInfo);
PROTO_PRIM(primNameEq);
PROTO_PRIM(primNameString);

#if BYTECODE_PRIMS
PROTO_PRIM(primNameCode);
PROTO_PRIM(primIntAt);
PROTO_PRIM(primFloatAt);
PROTO_PRIM(primDoubleAt);
PROTO_PRIM(primCellAt);
PROTO_PRIM(primNameAt);
PROTO_PRIM(primBytecodeAt);
PROTO_PRIM(primTextAt);
PROTO_PRIM(primAddrAt);
#endif /* BYTECODE_PRIMS */

static struct primitive internalPrimTable[] = {
  {"getCell",       1, primGetCell},
  {"cellPtrEq",     2, primCellPtrEq},
  {"catchError2",   1, primCatchError2},
  {"classifyCell",  2+IOArity, primClassifyCell},
  {"nameString",    1, primNameString},
  {"nameInfo",      1, primNameInfo},
  {"nameEq",        2, primNameEq},

#if BYTECODE_PRIMS
  {"nameCode",      1, primNameCode},
  {"intAt",         1, primIntAt},
  {"floatAt",       1, primFloatAt},
  {"doubleAt",      1, primDoubleAt},
  {"cellAt",        1, primCellAt},
  {"nameAt",        1, primNameAt},
  {"bytecodeAt",    1, primBytecodeAt},
  {"textAt",        1, primTextAt},
  {"addrAt",        1, primAddrAt},
#endif /* BYTECODE_PRIMS */

  {0,		    0, 0}
};

static struct primInfo internalPrims = {internalControl, internalPrimTable, 0};

/* --------------------------------------------------------------------------
 * linkInternals
 * ------------------------------------------------------------------------*/

static Module moduleInternals;

static Name nameHugsApply;            /* data CellKind = Apply Cell [Cell] */
static Name nameHugsFun;              /*    	       | Fun   Name        */
static Name nameHugsCon;              /*    	       | Con   Name        */
static Name nameHugsTuple;            /*    	       | Tuple Int         */
static Name nameHugsInt;              /*    	       | Int   Int         */
static Name nameHugsInteger;          /*    	       | Integer Integer   */
static Name nameHugsFloat;            /*    	       | Float Float       */
static Name nameHugsDouble;           /*    	       | Double Double     */
static Name nameHugsChar;             /*    	       | Char  Char        */
static Name nameHugsPrim;             /*    	       | Prim  String      */
static Name nameHugsError;            /*    	       | Error Cell        */

static Void linkInternals() {
    String internLib = "Hugs.Internals";
    moduleInternals = findModule(findText(internLib));
    if (nonNull(moduleInternals)) {
	setCurrModule(moduleInternals);
	nameHugsApply   = findName(findText("Apply"));
	nameHugsFun     = findName(findText("Fun"));
	nameHugsCon     = findName(findText("Con"));
	nameHugsTuple   = findName(findText("Tuple"));
	nameHugsInt     = findName(findText("Int"));
	nameHugsInteger = findName(findText("Integer"));
	nameHugsFloat   = findName(findText("Float"));
	nameHugsDouble  = findName(findText("Double"));
	nameHugsChar    = findName(findText("Char"));
	nameHugsPrim    = findName(findText("Prim"));
	nameHugsError   = findName(findText("Error"));
     
	if (isNull(nameHugsApply)   
	    || isNull(nameHugsFun)     
	    || isNull(nameHugsCon)     
	    || isNull(nameHugsTuple)   
	    || isNull(nameHugsInt)     
	    || isNull(nameHugsInteger) 
	    || isNull(nameHugsFloat)   
	    || isNull(nameHugsDouble)   
	    || isNull(nameHugsChar)    
	    || isNull(nameHugsPrim)    
	    || isNull(nameHugsError)
	    ) {
		fatal("module HugsInternals doesn't define CellKind correctly");
	}
    }
}

/* --------------------------------------------------------------------------
 * Operations on Cells
 * ------------------------------------------------------------------------*/

/* Cells have to be boxed (using the HUGSOBJECT tag) so that we can        */
/* evaluate a Cell expression such as "fst (cell1, cell2)" without         */
/* evaluating the thunk inside the Cell.                                   */

#define isHugsObject(a)     (isPair(a) && fst(a)==HUGSOBJECT)
#define checkHugsObject(x)  \
  if (!isHugsObject(x)) internal("HugsObject expected")

#define HugsObjectArg(nm, offset)                  \
   eval(primArg(offset));                          \
   checkHugsObject(whnfHead);                      \
   nm = snd(whnfHead);

primFun(primGetCell) {                 /* Trivial coercion                 */
    updapRoot(HUGSOBJECT,primArg(1));  /*  :: a -> Cell                    */
}


/* --------------------------------------------------------------------------
 * Pointer equality on Cells
 * ------------------------------------------------------------------------*/

primFun(primCellPtrEq) {	       /* Unsafe pointer equality test     */
    Cell x = 0;
    Cell y = 0;
    HugsObjectArg(x,1);
    push(x);
    HugsObjectArg(y,2);
    x = pop();

    /* We chase indirection chains since that's easy and gives more
     * accurate results.  
     * Don't do this if we use this function during error recovery -
     * it might be possible for an infinite loop to occur.
     */
    while (isPair(x) && INDIRECT == fst(x))
	x = snd(x);
    while (isPair(y) && INDIRECT == fst(y))
	y = snd(y);
    updateRoot( (x==y) ? nameTrue : nameFalse );
}

/* --------------------------------------------------------------------------
 * Error catching - evaluate a Cell and return an error redex or its value
 * ------------------------------------------------------------------------*/

primFun(primCatchError2) {	       /* Error catching  primitive        */
				       /*  :: a -> Either Cell a           */
    Cell err = NIL;
    err = evalWithNoError(primArg(1)); 
    if (isNull(err)) {
	updapRoot(nameRight, primArg(1));
    } else {
	updapRoot(nameLeft, ap(HUGSOBJECT, err));
    }
}

/* --------------------------------------------------------------------------
 * Examine an object either with or without evaluation.
 *
 * This primitive lets Haskell programs examine values of any datatype
 * (probably to print them).  It is wired into the IO monad to (narrowly)
 * avoid breaking referential transparency.
 * ------------------------------------------------------------------------*/

/* --------------------------------------------------------------------------
 * Note: we can't force the object _outside_ classify for two reasons: 
 *									     
 * 1) Writing "strict classifyCell x" only causes x to be evaluated to 
 *    WHNF.  Since x is a Cell, this doesn't achieve very much.	     
 *									     
 * 2) We can overcome this by adding an operation 			     
 *									     
 *      "forceCell :: Cell -> Cell" 			     
 *									     
 *    and writing "classifyObject (forceObject x)" but, if "x" is a CAF, 
 *    then "x" will be updated but the indirection via "x" will remain  
 *    in place.								     
 * ------------------------------------------------------------------------*/

primFun(primClassifyCell) {          /* classifyCell                       */
    Bool gc = consGC;                /*  :: Bool -> Cell -> IO CellKind    */
    Bool strict;
    Cell result = NIL;
    BoolArg(strict,2+IOArity);
    if (strict) {
	Cell temp;
	eval(IOArg(1)); /* object */
	checkHugsObject(whnfHead);
	whnfHead = snd(whnfHead);
	if (nonNull(temp = evalWithNoError(whnfHead))) {
	    IOReturn(ap(nameHugsError,ap(HUGSOBJECT,temp)));
	}
    } else {
	eval(IOArg(1)); /* object */
	checkHugsObject(whnfHead);
	whnfHead = snd(whnfHead);
	unwind(whnfHead);
    }
    consGC = TRUE;
    if (whnfArgs > 0) {
	Cell args = nameNil;
	while (whnfArgs-- > 0) 
	    args = ap(ap(nameCons,
			 ap(HUGSOBJECT, pushed(whnfArgs))),
			 args);
	result = ap(ap(nameHugsApply, 
		       ap(HUGSOBJECT,whnfHead)), 
		       args);
    } else {
	switch (whatIs(whnfHead)) {

	    case NAME     : result = ap((isCfun(whnfHead) ? nameHugsCon 
							  : nameHugsFun), 
					mkInt(whnfHead));
			    break;

	    case TUPLE    : result = ap(nameHugsTuple,mkInt(tupleOf(whnfHead)));
			    break;

#if BIGNUMS
	    case ZERONUM  : 
	    case POSNUM   : 
	    case NEGNUM   : 
			    result = ap(nameHugsInteger, whnfHead);
			    break;
#endif

	    case INTCELL  : result = ap(nameHugsInt, whnfHead);
			    break;

	    case CHARCELL : result = ap(nameHugsChar, whnfHead);
			    break;

	    case FLOATCELL: result = ap(nameHugsFloat, whnfHead);
			    break;

	    case DOUBLECELL: result = ap(nameHugsDouble, whnfHead);
			    break;

#if IO_HANDLES
	    case HANDCELL : result = ap(nameHugsPrim, mkStr(findText("{handle}")));
			    break;
#endif

#if IO_REFS
	    case MUTVAR   : result = ap(nameHugsPrim, mkStr(findText("{ref}")));
			    break;
#endif

#if HASKELL_ARRAYS
	    case ARRAY    : result = ap(nameHugsPrim, mkStr(findText("{primitive array}")));
			    break;
#endif

	    case HUGSOBJECT : 
			    /* ToDo: fix so that debugger can examine itself */
			    result = ap(nameHugsPrim, mkStr(findText("{Cell ...}")));
			    break;

	    case INSTANCE : result = ap(nameHugsPrim, mkStr(findText("{instance}")));
			    break;
#if OBSERVATIONS
            case OBSERVE  : result = ap(nameHugsPrim, mkStr(findText("{observe marker}")));
                            break;
#endif
	    default       : internal("Error in graph2");
			    break;
	}
    }
    consGC = gc;
    IOReturn(result);
}

/* --------------------------------------------------------------------------
 * Operations on Names
 * ------------------------------------------------------------------------*/

primFun(primNameString) {              /* Get string of a name             */
  Text t;                              /*  :: Name -> String              */
  Name nm;
  IntArg(nm,1);
  t = name(nm).text;
  if (0 <= t && t < NUM_TEXT) {
      /* ToDo: replace updateRoot(mkStr(..)) with updapRoot(STRCELL,..) */
      updateRoot(mkStr(t));
  } else { 
      /* If textToStr generates result on the fly, we build the entire
       * string now.
       */
      String s = textToStr(t);
      Int    l = strlen(s);
      push(nameNil);
      while (--l >= 0) {
	  Cell r = pop();  /* we take care to pop _before_ we push */
	  push(ap(consChar(s[l]),r));
      }
      updateRoot(pop());
  }      
}

primFun(primNameInfo) {                /* Get arity and fixity of a Name   */
  Name nm;                             /*  :: Name -> (Int,Int,Char)       */
  Syntax syn = 0;
  Char assoc = 0;  
  IntArg(nm,1);
  syn = syntaxOf(nm);
  switch (assocOf(syn)) {
  case APPLIC    : assoc = 'A'; break;
  case LEFT_ASS  : assoc = 'L'; break;
  case RIGHT_ASS : assoc = 'R'; break;
  case NON_ASS   : assoc = 'N'; break;
  }
  updapRoot(ap(ap(mkTuple(3),
	    mkInt(name(nm).arity)),
	    mkInt(precOf(syn))),
	    mkChar(assoc));
}

primFun(primNameEq) {                  /* Compare names                    */
  Name nm1;                            /*  :: Name -> Name -> Bool         */
  Name nm2;                    
  IntArg(nm1,2);
  IntArg(nm2,1);
  BoolResult(nm1==nm2);
}

#if BYTECODE_PRIMS

primFun(primNameCode) {                /* Obtain address of first bytecode */
  Name nm;                             /*  :: Name -> Addr                 */
  IntArg(nm,1);
  IntResult(name(nm).code);
}

#endif /* BYTECODE_PRIMS */

/* --------------------------------------------------------------------------
 * Operations on Addresses/Bytecodes
 * ------------------------------------------------------------------------*/

#if BYTECODE_PRIMS

primFun(primIntAt) {                  /* Obtain Int at address             */
  Addr m;                             /*  :: Addr -> Int                   */
  IntArg(m,1);
  IntResult(IntAt(m));
}

primFun(primFloatAt) {                /* Obtain float at address           */
  Addr m;                             /*  :: Addr -> Cell                  */
  IntArg(m,1);
  FloatResult(FloatAt(m));
}

primFun(primDoubleAt) {               /* Obtain float at address           */
  Addr m;                             /*  :: Addr -> Cell                  */
  IntArg(m,1);
  DoubleResult(DoubleAt(m));
}

primFun(primCellAt) {                 /* Obtain cell at address            */
  Addr m;                             /*  :: Addr -> Cell                  */
  IntArg(m,1);
  updapRoot(HUGSOBJECT,CellAt(m));
}

primFun(primNameAt) {                 /* Obtain Name at address            */
  Addr m;                             /*  :: Addr -> Name                  */
  IntArg(m,1);
  IntResult(CellAt(m));
}

primFun(primBytecodeAt) {             /* Obtain bytecode at address        */
  Addr m;                             /*  :: Addr -> Bytecode              */
  IntArg(m,1);
  IntResult(InstrAt(m));
}

primFun(primTextAt) {                 /* Obtain string at address          */
  Addr m;                             /*  :: Addr -> String                */
  IntArg(m,1);
  updapRoot(STRCELL,TextAt(m));
}

primFun(primAddrAt) {                 /* Obtain address at address         */
  Addr m;                             /*  :: Addr -> Addr                  */
  IntArg(m,1);
  IntResult(AddrAt(m));
}

#endif /* BYTECODE_PRIMS */

/*-------------------------------------------------------------------------*/
