backend/storage.c

/*---------------------------------------------------------------*/
/*---                                                         ---*/
/*--- This file (storage.c) is                                ---*/
/*--- Copyright (c) 2004 OpenWorks LLP.  All rights reserved. ---*/
/*---                                                         ---*/
/*---------------------------------------------------------------*/

#include <stdio.h>
#include <stdlib.h>
#include <assert.h>
#include "storage.h"
#include "storage_private.h"


static Cell heap[N_HEAP_CELLS];
static Int  heap_used = 1;  /* cell==0 is not allowed */

static Char* tag_name[N_TAGS];
static UChar tag_arity[N_TAGS]; /* 0xFF indicates unregistered. */

static Bool  init_done = False;

#define IS_VALID_CELL(cc) ((cc) < 0 && (cc) > -heap_used)
#define IS_VALID_TAG(tt)  ((tt) > 0 && (tt) < N_TAGS)


void panic ( Char* who )
{
  fprintf(stderr, "panic: %s\n", who);
  exit(1);
}


/* Initialise the storage subsystem. */
void storage_init ( void )
{
   Int i;
   assert(!init_done);
   init_done = True;
   for (i = 0; i < N_TAGS; i++) {
      tag_name[i] = NULL;
      tag_arity[i] = 0xFF; /* unregistered */
   }
   heap_used = 1;
   storage_register_tag ( TagCONS,    2, "cons" );
   storage_register_tag ( TagPAIR,    2, "pair" );
   storage_register_tag ( TagTRIPLE,  3, "triple" );
   storage_register_tag ( TagWord8,   1, "word8" );
   storage_register_tag ( TagWord16,  1, "word16" );
   storage_register_tag ( TagWord32,  1, "word32" );
   storage_register_tag ( TagWord64,  1, "word64" );
}

void storage_done ( void )
{
  printf ("storage_done: used %d cells\n", heap_used-1 );
}

void storage_register_tag ( Tag tag, Int arity, Char* name )
{
   assert(init_done);
   assert(IS_VALID_TAG(tag));
   assert(tag_arity[tag] == 0xFF);   /* check not already registered */
   assert(name != NULL);
   assert(arity >= 0 && arity <= 5);
   tag_name[tag]  = name;
   tag_arity[tag] = arity;
}


Tag getTag ( Cell c )
{
   Tag t;
   assert(IS_VALID_CELL(c));
   t = heap[-c];
   assert(IS_VALID_TAG(t));
   assert(tag_arity[t] != 0xFF);
   return t;
}

/* ------------------ Construct/query for Size = 0 --------------------- */

Cell tuple0 ( Tag t )
{
   assert(init_done);
   assert(heap_used <= N_HEAP_CELLS-1);
   assert(IS_VALID_TAG(t));
   assert(tag_arity[t] == 0);
   heap[heap_used]   = t;
   heap_used += 1;
   return -(heap_used - 1);
}


/* ------------------ Construct/query for Size = 1 --------------------- */

Cell tuple1 ( Tag t, Cell x )
{
   assert(init_done);
   assert(heap_used <= N_HEAP_CELLS-2);
   assert(IS_VALID_TAG(t));
   assert(tag_arity[t] == 1);
   heap[heap_used]   = t;
   heap[heap_used+1] = x;
   heap_used += 2;
   return -(heap_used - 2);
}

Cell sel11 ( Cell tup )
{
   Tag t;
   assert(IS_VALID_CELL(tup));
   t = heap[-tup];
   assert(IS_VALID_TAG(t));
   assert(tag_arity[t] == 1);
   return heap[-tup+1];
}

/* ------------------ Construct/query for Size = 2 --------------------- */

Cell tuple2 ( Tag t, Cell x, Cell y )
{
   assert(init_done);
   assert(heap_used <= N_HEAP_CELLS-3);
   assert(IS_VALID_TAG(t));
   assert(tag_arity[t] == 2);
   heap[heap_used]   = t;
   heap[heap_used+1] = x;
   heap[heap_used+2] = y;
   heap_used += 3;
   return -(heap_used - 3);
}

Cell sel21 ( Cell tup )
{
   Tag t;
   assert(IS_VALID_CELL(tup));
   t = heap[-tup];
   assert(IS_VALID_TAG(t));
   assert(tag_arity[t] == 2);
   return heap[-tup+1];
}

Cell sel22 ( Cell tup )
{
   Tag t;
   assert(IS_VALID_CELL(tup));
   t = heap[-tup];
   assert(IS_VALID_TAG(t));
   assert(tag_arity[t] == 2);
   return heap[-tup+2];
}


/* ------------------ Construct/query for Size = 3 --------------------- */

Cell tuple3 ( Tag t, Cell x, Cell y, Cell z )
{
   assert(init_done);
   assert(heap_used <= N_HEAP_CELLS-4);
   assert(IS_VALID_TAG(t));
   assert(tag_arity[t] == 3);
   heap[heap_used]   = t;
   heap[heap_used+1] = x;
   heap[heap_used+2] = y;
   heap[heap_used+3] = z;
   heap_used += 4;
   return -(heap_used - 4);
}

Cell sel31 ( Cell tup )
{
   Tag t;
   assert(IS_VALID_CELL(tup));
   t = heap[-tup];
   assert(IS_VALID_TAG(t));
   assert(tag_arity[t] == 3);
   return heap[-tup+1];
}

Cell sel32 ( Cell tup )
{
   Tag t;
   assert(IS_VALID_CELL(tup));
   t = heap[-tup];
   assert(IS_VALID_TAG(t));
   assert(tag_arity[t] == 3);
   return heap[-tup+2];
}

Cell sel33 ( Cell tup )
{
   Tag t;
   assert(IS_VALID_CELL(tup));
   t = heap[-tup];
   assert(IS_VALID_TAG(t));
   assert(tag_arity[t] == 3);
   return heap[-tup+3];
}


/* ------------------ Helpers for lists --------------------- */

Cell cons ( Cell hd, Cell tl ) 
{ 
  return tuple2(TagCONS, hd, tl); 
}

Cell head ( Cell list ) 
{
  if (isNil(list))             panic("head(NIL)");
  if (getTag(list) != TagCONS) panic("head(not-a-list)");
  return sel21(list);
}

Cell tail ( Cell list ) 
{
  if (isNil(list))             panic("tail(NIL)");
  if (getTag(list) != TagCONS) panic("tail(not-a-list)");
  return sel22(list);
}


/* ------------------ Helpers for Word* --------------------- */

Cell mkWord8 ( UInt w8 )
{
  return tuple1 ( TagWord8, w8 & 0xFF );
}

Cell mkWord16 ( UInt w16 )
{
  return tuple1 ( TagWord16, w16 & 0xFFFF );
}

Cell mkWord32 ( UInt w32 )
{
  return tuple1 ( TagWord32, w32 );
}

Cell mkWord64 ( ULong w64 )
{
  UInt hi = (UInt)(w64 >> 32);
  UInt lo = (UInt)(w64 & 0x00000000FFFFFFFFLL);
  return tuple2 ( TagWord64, hi, lo );
}

UInt getWord8 ( Cell c )
{
  assert(getTag(c) == TagWord8 );
  return sel11(c);
}

UInt getWord16 ( Cell c )
{
  assert(getTag(c) == TagWord16 );
  return sel11(c);
}

UInt getWord32 ( Cell c )
{
  assert(getTag(c) == TagWord32 );
  return sel11(c);
}

ULong getWord64 ( Cell c )
{
  UInt hi, lo;
  assert(getTag(c) == TagWord64 );
  hi = (UInt)sel21(c);
  lo = (UInt)sel22(c);
  return (((ULong)hi) << 32) | ((ULong)lo);
}