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

        File:                   GhcInternalsC.c  

        Description:            Code for inspecting values on the GHC heap

        Primary Authors:        Bernie Pope

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

#include <stdio.h>
#include "Internals.h"
#include "Hash.h"

StgClosure* removeIndirections (StgClosure* p);
Bool isPrim (char *descr);
Bool isTerminal (StgClosure* obj, Bool isCycle);
GraphNode *makeHeapGraph_ (HashTable *htable, StgClosure *obj);

static int bogusData = 1;

GraphNode *makeHeapGraph (StgStablePtr objPtr)
{
   HaskellObj obj;
   GraphNode *graph;
   HashTable *htable;

   htable = (HashTable *) allocHashTable ();
   obj = (HaskellObj) deRefStablePtr (objPtr);
   graph = makeHeapGraph_ (htable, obj);
   freeHashTable (htable, NULL);
   return graph;
}

GraphNode *makeHeapGraph_ (HashTable *htable, StgClosure *obj)
{
    StgInfoTable *info;
    StgClosure   *realObj;
    Bool         isHashed;
    GraphNode    *node;

    isHashed = False;

    /* collapse any indirections */
    realObj = removeIndirections (obj);

    info = get_itbl (realObj);

    /* determine what kind of thing we have */
    switch ( info->type )
    {
       case INVALID_OBJECT:
       {
          fprintf(stderr, "\n\nmakeHeapGraph (): encountered an invalid object");
          exit (-1);
       }

       /* can't possibly be an indirection, since we have collapsed them */
       case IND:
       case IND_STATIC:
       case IND_OLDGEN:
       case IND_PERM:
       case IND_OLDGEN_PERM:
       {
            /* report an error, just in case something went horribly wrong */
            fprintf(stderr, "\n\nmakeHeapGraph (): encountered an unexpected indirection node: %d\n\n", info->type);
            exit (-1);
       }

       /* thunks */
       case THUNK:
       case THUNK_1_0:
       case THUNK_0_1:
       case THUNK_2_0:
       case THUNK_1_1:
       case THUNK_0_2:
       case THUNK_STATIC:
       case THUNK_SELECTOR:
       {

          /* look for an exception */
          if (GET_INFO(realObj) == &stg_raise_info)
          {
             node = makeGraphNode ((int) realObj, Exception, NULL, 1);
             node->children[0] = makeHeapGraph_ (htable, (StgClosure *)realObj->payload[0]);
          }
          else
          {  
             node = makeGraphNode ((int) realObj, Thunk, NULL, 0);
          }
          
          break;
       }

       /* Functions -- note we should never really see a function,
          so we throw an error if it ever happens
       */
       case FUN:
       case FUN_1_0:
       case FUN_0_1:
       case FUN_2_0:
       case FUN_1_1:
       case FUN_0_2:
       {
          node = makeGraphNode ((int) realObj, Fun, NULL, 0);
          break;
       }

       /* I think we only get these when an asynchronous exception occurs, and this closure
        * was still being evaluated */
       #if __GLASGOW_HASKELL__ < 600
       case AP_UPD:
       {
          node = makeGraphNode ((int) realObj, Ap_Upd, NULL, 0);
          break;
       }
       #endif 

       case MUT_VAR:
       {
          StgMutVar* mv = (StgMutVar*)realObj;
          node = makeHeapGraph_ (htable, (StgClosure *)(mv->var));
          break;
       }

       /* constructors */
       case CONSTR:
       case CONSTR_1_0:
       case CONSTR_0_1:
       case CONSTR_1_1:
       case CONSTR_0_2:
       case CONSTR_2_0:
       case CONSTR_INTLIKE:
       case CONSTR_CHARLIKE:
       case CONSTR_STATIC:
       case CONSTR_NOCAF_STATIC:
       {
           int i;
           char *descriptor;
           GraphNode *next;
           GraphNode **prev;
           StgClosure *currClosure; 
           StgInfoTable *currInfo;
           int numArgs = 0;
           Bool isCycle = False;
           List *addressList = NULL;

           /* obtain the name of the constructor */
           #ifdef PROFILING
              descriptor = info->prof.closure_desc;
           #else
              descriptor = "?";
           #endif

           /* check for a Character */
           if (strcmp("C#", descriptor) == 0)
           {
              node = makeGraphNode (0, Char, NULL, 0);
              node->val.character = rts_getChar(realObj);
              break;
           }

           /* check for an Int*/
           else if (strcmp("I#", descriptor) == 0)
           {
              node = makeGraphNode (0, Int, NULL, 0);
              node->val.machineInt = rts_getInt(realObj);
              break;
           }

           /* from the file: fptools/libraries/base/GHC/Num.lhs
            *
            * data Integer    
            *    = S# Int#                            -- small integers
            * #ifndef ILX
            *    | J# Int# ByteArray#                 -- large integers
            *  #else
            *    | J# Void BigInteger                 -- .NET big ints
            */

           /* check for a small Integer */
           else if (strcmp("S#", descriptor) == 0)
           {
              node = makeGraphNode (0, SmallInteger, NULL, 0);
              node->val.machineInt = (HsInt)(realObj->payload[0]);
              break;
           }

           /* check for a large Integer */
           else if (strcmp("J#", descriptor) == 0)
           {
              node = makeGraphNode (0, LargeInteger, NULL, 0);
              node->val.largeIntegerSPtr = (StgStablePtr)(getStablePtr((StgPtr)realObj));
              break;
           }

           /* check for a Float */
           else if (strcmp("F#", descriptor) == 0)
           {
              node = makeGraphNode (0, Float, NULL, 0);
              node->val.machineFloat = rts_getFloat(realObj);
              break;

           }

           /* check for a Double */
           else if (strcmp("D#", descriptor) == 0)
           {
              node = makeGraphNode (0, Double, NULL, 0);
              node->val.machineDouble = rts_getDouble(realObj);
              break;
           }
           
           /* nullary constructors */

           else if (info->layout.payload.ptrs == 0)
           {
              node = makeGraphNode ((int) realObj, Node, descriptor, 0);
              break;
           }

           /* non nullary constructor applications */
           /* tail call optimisation, where recursion over the last argument
            * to a constructor is converted into a while loop */

           else 
           {
              currClosure = realObj;
              currInfo = get_itbl (currClosure);
              numArgs  = currInfo->layout.payload.ptrs;
              prev = &node;
              
              if (lookupHashTable(htable, (StgWord) currClosure) != NULL)
              {
                 isCycle = True; 
              }

              /* non-nullary constructors */

              while (! isTerminal(currClosure, isCycle))
              {
                 insertHashTable (htable, (StgWord) currClosure, &bogusData);
                 addressList = cons ((StgWord) currClosure, addressList);
                 next = makeGraphNode ((int) currClosure, Node, currInfo->prof.closure_desc, numArgs);
                 (*prev) = next;
                 prev = &(next->children[numArgs-1]);
              
                 /* recursively build all left children */
                 for (i = 0; i < numArgs - 1; i++)
                 {
                    next->children[i] = makeHeapGraph_ (htable, (StgClosure *)currClosure->payload[i]);
                 }

                 /* loop on the right child */
                 currClosure = removeIndirections((StgClosure *)currClosure->payload[numArgs-1]);
                 currInfo = get_itbl (currClosure);
                 numArgs = currInfo->layout.payload.ptrs; 

                 if (lookupHashTable(htable, (StgWord) currClosure) != NULL)
                 {
                    isCycle = True;
                 }
              }

              if (isCycle)
              {
                 (*prev) = (makeGraphNode ((int) currClosure, Cycle, NULL, 0)); 
              }
              /* nullary constructors and non constructors that were children 
               * of a constructor (ie [], thunk, Int)*/
              else
              {
                 (*prev) = makeHeapGraph_ (htable, (StgClosure *)currClosure);
              }

              /* remove all the hashed addresses so that we don't confuse
               *  later shared nodes with cycles */
              while (addressList)
              {
                 removeHashTable (htable, (StgWord) addressList->val, NULL);
                 addressList = freeListNode (addressList);
              }

              break;
           }
       }

       /* build a default terminal node for all other types of values */
       default:
       {
          node = makeGraphNode ((int) realObj, Unknown, NULL, 0);
          break;
       }
    }
 
    return node;
}

/* True if the argument is the tag of a constructor
 * and False otherwise
 * 
 */
Bool isAConstructor (int type)
{
   switch (type)
   {
       case CONSTR:
       case CONSTR_1_0:
       case CONSTR_0_1:
       case CONSTR_1_1:
       case CONSTR_0_2:
       case CONSTR_2_0:
       case CONSTR_INTLIKE:
       case CONSTR_CHARLIKE:
       case CONSTR_STATIC:
       case CONSTR_NOCAF_STATIC:
       {
          return True;
       }

       default:
       {
          return False;
       }
   }
   return;
}

/* true if its argument is a terminal in the heap:
 *
 *     1. It is not a constructor
 *     2. It is a constructor, but:
 *        2.1 It is a cycle
 *        2.2 It is a nullary constructor
 *        2.3 It is C# I# S# J# F# D#  (a prim type)
 */
Bool isTerminal (StgClosure *obj, Bool isCycle)
{
    char *descriptor;
    StgInfoTable *currInfo;
    int numArgs;

    currInfo = get_itbl (obj);
    numArgs  = currInfo->layout.payload.ptrs;

    if (! isAConstructor(currInfo->type))
    {
       return True;
    }
    else if (isCycle)
    {
       return True;
    }
    else if (numArgs == 0)
    {
       return True;
    }
    else if (isPrim (currInfo->prof.closure_desc))
    {
       return True;
    }
    else
    {
       return False;
    }
} 

/* true if the descriptor names a prim type:
 * Char, Int, (small, large) Integer, Float, Double
 */

Bool isPrim (char *descr)
{
   return (!(
             strcmp ("C#", descr) &&     /* is a Char */
             strcmp ("I#", descr) &&     /* Int */
             strcmp ("S#", descr) &&     /* small Integer */
             strcmp ("J#", descr) &&     /* large Integer */
             strcmp ("F#", descr) &&     /* Float */
             strcmp ("D#", descr)        /* Double */
            )
          );
}

/* follow indirections until the underlying closure is found */
StgClosure *removeIndirections (StgClosure* p)
{
    StgClosure* q = p;
    unsigned int type;

    type = get_itbl(q)->type;
           
    while (type == IND ||
           type == IND_STATIC ||
           type == IND_OLDGEN ||
           type == IND_PERM ||
           type == IND_OLDGEN_PERM) 
    {
      q = ((StgInd *)q)->indirectee;
      type = get_itbl(q)->type;
    }

   return q;
}