/* -*- C++ -*-

// -------------------------------------------------------------------

// MiniExp - Library for handling lisp expressions

// Copyright (c) 2005  Leon Bottou

//

// This software is subject to, and may be distributed under, the

// GNU General Public License, either version 2 of the license

// or (at your option) any later version. The license should have

// accompanied the software or you may obtain a copy of the license

// from the Free Software Foundation at http://www.fsf.org .

//

// This program 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 General Public License for more details.

// -------------------------------------------------------------------

*/

#ifdef HAVE_CONFIG_H

# include "config.h"

#endif

#if NEED_GNUG_PRAGMAS

# pragma implementation "miniexp.h"

#endif

#include <stddef.h>

#include <stdlib.h>

#include <stdio.h>

#include <ctype.h>

#include <errno.h>

#include <string.h>

#include <time.h>

#include <stdarg.h>

#define MINIEXP_IMPLEMENTATION

#include "miniexp.h"

#ifdef HAVE_NAMESPACES

# define BEGIN_ANONYMOUS_NAMESPACE namespace {

# define END_ANONYMOUS_NAMESPACE }

#else

# define BEGIN_ANONYMOUS_NAMESPACE 

# define END_ANONYMOUS_NAMESPACE

#endif

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

/* ASSERT                                            */

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

#if defined(__GNUC__)

static void 

assertfail(const char *fn, int ln) 

  __attribute__((noreturn));

#endif

static void

assertfail(const char *fn, int ln)

{

  fprintf(stderr,"Assertion failed: %s:%d\n",fn,ln);

  abort();

}

#define ASSERT(x) \

  do { if (!(x)) assertfail(__FILE__,__LINE__); } while(0)

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

/* GLOBAL MUTEX                                       */

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

#ifndef WITHOUT_THREADS

# ifdef _WIN32

#  include <windows.h>

#  define USE_WINTHREADS 1

# elif defined(HAVE_PTHREAD)

#  include <pthread.h>

#  define USE_PTHREADS 1 

# endif

#endif

#if defined(USE_WINTHREADS)

// Windows critical section

# define CSLOCK(name) CSLocker name

BEGIN_ANONYMOUS_NAMESPACE

struct CS { 

  CRITICAL_SECTION cs; 

  CS() { InitializeCriticalSection(&cs); }

  ~CS() { DeleteCriticalSection(&cs); } };

static CS globalCS;

struct CSLocker {

  CSLocker() { EnterCriticalSection(&globalCS.cs); }

  ~CSLocker() { LeaveCriticalSection(&globalCS.cs); } };

END_ANONYMOUS_NAMESPACE

#elif defined (USE_PTHREADS)

// Pthread critical section

# define CSLOCK(name) CSLocker name

BEGIN_ANONYMOUS_NAMESPACE

static pthread_mutex_t globalCS = PTHREAD_MUTEX_INITIALIZER;

struct CSLocker {

  CSLocker() { pthread_mutex_lock(&globalCS); }

  ~CSLocker() { pthread_mutex_unlock(&globalCS); } };

END_ANONYMOUS_NAMESPACE

#else

// No critical sections

# define CSLOCK(name) /**/

#endif

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

/* SYMBOLS                                            */

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

static unsigned int 

hashcode(const char *s)

{

  long h = 0x1013;

  while (*s)

    {

      h = (h<<6) | ((h&0xfc000000)>>26);

      h ^= (*s);

      s++;

    }

  return h;

}

BEGIN_ANONYMOUS_NAMESPACE

class symtable_t 

{

public:

  int nelems;

  int nbuckets;

  struct sym { unsigned int h; struct sym *l; char *n; };

  struct sym **buckets;

  symtable_t();

  ~symtable_t();

  struct sym *lookup(const char *n, bool create=false);

  void resize(int); 

private:

  symtable_t(const symtable_t&);

  symtable_t& operator=(const symtable_t&);

};

symtable_t::symtable_t()

  : nelems(0), nbuckets(0), buckets(0)

{

  resize(7);

}

symtable_t::~symtable_t()

{

  int i=0;

  for (; i

    while (buckets[i])

      {

        struct sym *r = buckets[i];

        buckets[i] = r->l;

        delete [] r->n;

        delete r;

      }

  delete [] buckets;

}

void

symtable_t::resize(int nb)

{

  struct sym **b = new sym*[nb];

  memset(b, 0, nb*sizeof(sym*));

  int i=0;

  for (; i

    while (buckets[i])

      {

        struct sym *s = buckets[i];

        int j = s->h % nb;

        buckets[i] = s->l;

        s->l = b[j];

        b[j] = s;

      }

  delete [] buckets;

  buckets = b;

  nbuckets = nb;

}

struct symtable_t::sym *

symtable_t::lookup(const char *n, bool create)

{

  unsigned int h = hashcode(n);

  int i = h % nbuckets;

  struct sym *r = buckets[i];

  while (r && strcmp(n,r->n))

    r = r->l;

  if (!r && create)

    {

      CSLOCK(lock);

      nelems += 1;

      r = new sym;

      r->h = h;

      r->l = buckets[i];

      r->n = new char [1+strlen(n)];

      strcpy(r->n, n);

      buckets[i] = r;

      if ( 2 * nelems > 3 * nbuckets)

        resize(2*nbuckets-1);

    }

  return r;

}

END_ANONYMOUS_NAMESPACE

static symtable_t *symbols;

const char *

miniexp_to_name(miniexp_t p)

{

  if (miniexp_symbolp(p))

    {

      struct symtable_t::sym *r;

      r = ((symtable_t::sym*)(((size_t)p)&~((size_t)3)));

      return (r) ? r->n : "##(dummy)";

    }

  return 0;

}

miniexp_t 

miniexp_symbol(const char *name)

{

  struct symtable_t::sym *r;

  if (! symbols)

    {

      CSLOCK(lock);

      if (! symbols)

        symbols = new symtable_t;

    }

  r = symbols->lookup(name, true);

  return (miniexp_t)(((size_t)r)|((size_t)2));

}

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

/* MEMORY AND GARBAGE COLLECTION                      */

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

// A simple mark-and-sweep garbage collector.

//

// Memory is managed in chunks of nptrs_chunk pointers.

// The first two pointers are used to hold mark bytes for the rest.

// Chunks are carved from blocks of nptrs_block pointers.

//

// Dirty hack: The sixteen most recently created pairs are 

// not destroyed by automatic garbage collection, in order

// to preserve transient objects created in the course 

// of evaluating complicated expressions.

#define nptrs_chunk  (4*sizeof(void*))

#define sizeof_chunk (nptrs_chunk*sizeof(void*))

#define nptrs_block  (16384-8)

#define recentlog    (4)

#define recentsize   (1<

BEGIN_ANONYMOUS_NAMESPACE

struct gctls_t {

  gctls_t  *next;

  gctls_t **pprev;

  void    **recent[recentsize];

  int       recentindex;

  gctls_t();

  ~gctls_t();

};

struct block_t 

{

  block_t *next;

  void **lo;

  void **hi;

  void *ptrs[nptrs_block];

};

static struct {

  int lock;

  int request;

  int debug;

  int      pairs_total;

  int      pairs_free;

  void   **pairs_freelist;

  block_t *pairs_blocks;

  int      objs_total;

  int      objs_free;

  void   **objs_freelist;

  block_t *objs_blocks;

  gctls_t *tls;

} gc;

gctls_t::gctls_t()

{

  // CSLOCK(locker); [already locked]

  recentindex = 0;

  for (int i=0; i

    recent[i] = 0;

  if ((next = gc.tls))

    next->pprev = &next;

  pprev = &gc.tls;

  gc.tls = this;

  //fprintf(stderr,"Created gctls %p\n", this);

}

gctls_t::~gctls_t()

{

  //CSLOCK(locker); [already locked]

  //fprintf(stderr,"Deleting gctls %p\n", this);

  if  ((*pprev = next))

    next->pprev = pprev;

}

END_ANONYMOUS_NAMESPACE

#if USE_PTHREADS

// Manage thread specific data with pthreads

static pthread_key_t gctls_key;

static pthread_once_t gctls_once;

static void gctls_destroy(void* arg) {

  CSLOCK(locker); delete (gctls_t*)arg;

}

static void gctls_key_alloc() {

  pthread_key_create(&gctls_key, gctls_destroy);

}

# if HAVE_GCCTLS

static __thread gctls_t *gctls_tv = 0;

static void gctls_alloc() {

  pthread_once(&gctls_once, gctls_key_alloc);

  gctls_tv = new gctls_t();

  pthread_setspecific(gctls_key, (void*)gctls_tv);

}

static gctls_t *gctls() {

  if (! gctls_tv) gctls_alloc();

  return gctls_tv;

}

# else

static  gctls_t *gctls_alloc() {

  gctls_t *res = new gctls_t();

  pthread_setspecific(gctls_key, (void*)res);

  return res;

}

static gctls_t *gctls() {

  pthread_once(&gctls_once, gctls_key_alloc);

  void *arg = pthread_getspecific(gctls_key);

  return (arg) ? (gctls_t*)(arg) : gctls_alloc();

}

# endif

#elif USE_WINTHREADS 

// Manage thread specific data with win32

#if defined(_MSC_VER) && defined(USE_MSVC_TLS)

// -- Pre-vista os sometimes crashes on this.

static __declspec(thread) gctls_t *gctls_tv = 0;

static gctls_t *gctls() {

  if (! gctls_tv)  gctls_tv = new gctls_t();

  return gctls_tv;

}

static void NTAPI gctls_cb(PVOID, DWORD dwReason, PVOID) {

  if (dwReason == DLL_THREAD_DETACH && gctls_tv) 

    { CSLOCK(locker); delete gctls_tv; gctls_tv=0; } }

# else

// -- Using Tls{Alloc,SetValue,GetValue,Free} instead.

static DWORD tlsIndex = TLS_OUT_OF_INDEXES;

static gctls_t *gctls() {

  if (tlsIndex == TLS_OUT_OF_INDEXES) tlsIndex = TlsAlloc();

  ASSERT(tlsIndex != TLS_OUT_OF_INDEXES);

  gctls_t *addr = (gctls_t*)TlsGetValue(tlsIndex);

  if (! addr) TlsSetValue(tlsIndex, (LPVOID)(addr = new gctls_t()));

  ASSERT(addr != 0);

  return addr;

}

static void NTAPI gctls_cb(PVOID, DWORD dwReason, PVOID) {

  if (dwReason == DLL_THREAD_DETACH && tlsIndex != TLS_OUT_OF_INDEXES)

    {CSLOCK(r);delete(gctls_t*)TlsGetValue(tlsIndex);TlsSetValue(tlsIndex,0);}

  if (dwReason == DLL_PROCESS_DETACH && tlsIndex != TLS_OUT_OF_INDEXES)

    {CSLOCK(r);TlsFree(tlsIndex);tlsIndex=TLS_OUT_OF_INDEXES;}

}

# endif

// -- Very black magic to clean tls variables.

# ifdef _M_IX86

#  pragma comment (linker, "/INCLUDE:_tlscb")

# else

#  pragma comment (linker, "/INCLUDE:tlscb")

# endif

# pragma const_seg(".CRT$XLB")

extern "C" PIMAGE_TLS_CALLBACK tlscb = gctls_cb;

# pragma const_seg()

#else

// No threads

static gctls_t *gctls() {

  static gctls_t g;

  return &g;

}

#endif

static inline char *

markbase(void **p)

{

  return (char*)(((size_t)p) & ~(sizeof_chunk-1));

}

static inline char *

markbyte(void **p)

{

  char *base = markbase(p);

  return base + ((p - (void**)base)>>1);

}

static block_t *

new_block(void)

{

  block_t *b = new block_t;

  memset(b, 0, sizeof(block_t));

  b->lo = (void**)markbase(b->ptrs+nptrs_chunk-1);

  b->hi = (void**)markbase(b->ptrs+nptrs_block);

  return b;

}

static void

clear_marks(block_t *b)

{

  for (void** m=b->lo; m<b->hi; m+=nptrs_chunk)

    m[0] = m[1] = 0;

}

static void

collect_free(block_t *b, void **&freelist, int &count, bool destroy)

{

  for (void **m=b->lo; m<b->hi; m+=nptrs_chunk)

    {

      char *c = (char*)m;

      for (unsigned int i=1; i

        if (! c[i])

          {

            miniobj_t *obj = (miniobj_t*)m[i+i];

            if (destroy && obj && m[i+i]==m[i+i+1]) 

              obj->destroy();

            m[i+i] = (void*)freelist;

            m[i+i+1] = 0;

            freelist = &m[i+i];

            count += 1;

          }

    }

}

static void

new_pair_block(void)

{

  int count = 0;

  block_t *b = new_block();

  b->next = gc.pairs_blocks;

  gc.pairs_blocks = b;

  clear_marks(b);

  collect_free(b, gc.pairs_freelist, count, false);

  gc.pairs_total += count;

  gc.pairs_free += count;

}

static void

new_obj_block(void)

{

  int count = 0;

  block_t *b = new_block();

  b->next = gc.objs_blocks;

  gc.objs_blocks = b;

  clear_marks(b);

  collect_free(b, gc.objs_freelist, count, false);

  gc.objs_total += count;

  gc.objs_free += count;

}

#if defined(__GNUC__) && (__GNUC__ >= 3)

static void gc_mark_object(void **v) __attribute__((noinline));

#else

static void gc_mark_object(void **v);

#endif

static bool

gc_mark_check(void *p)

{

  if (((size_t)p) & 2)

    return false;

  void **v = (void**)(((size_t)p) & ~(size_t)3); 

  if (! v)

    return false;

  char *m = markbyte(v);

  if (*m)

    return false;

  *m = 1;

  if (! (((size_t)p) & 1))

    return true;

  gc_mark_object((void**)v);

  return false;

}

static void

gc_mark_pair(void **v)

{

  // This is a simple recursive code.

  // Despite the tail recursion for the cdrs,

  // it consume a stack space that grows like

  // the longest chain of cars.

  for(;;)

    {

      if (gc_mark_check(v[0]))

        gc_mark_pair((void**)v[0]);

      if (! gc_mark_check(v[1]))

        break;

      v = (void**)v[1];

    }

}

static void

gc_mark(miniexp_t *pp)

{

  void **v = (void**)*pp;

  if (gc_mark_check((void**)*pp))

    gc_mark_pair(v);

}

static void

gc_mark_object(void **v)

{

  ASSERT(v[0] == v[1]);

  miniobj_t *obj = (miniobj_t*)v[0];

  if (obj) 

    obj->mark(gc_mark);

}

static void

gc_run(void)

{

  gc.request++;

  if (gc.lock == 0)

    {

      block_t *b;

      gc.request = 0;

      // clear marks

      for (b=gc.objs_blocks; b; b=b->next)

        clear_marks(b);

      for (b=gc.pairs_blocks; b; b=b->next)

        clear_marks(b);

      // mark recents

      for (gctls_t *tls = gc.tls; tls; tls=tls->next)

        for (int i=0; i

          gc_mark((miniexp_t*)(char*)&(tls->recent[i]));

      // mark roots

      minivar_t::mark(gc_mark);

      // sweep

      gc.objs_free = gc.pairs_free = 0;

      gc.objs_freelist = gc.pairs_freelist = 0;

      for (b=gc.objs_blocks; b; b=b->next)

        collect_free(b, gc.objs_freelist, gc.objs_free, true);

      for (b=gc.pairs_blocks; b; b=b->next)

        collect_free(b, gc.pairs_freelist, gc.pairs_free, false);

      // alloc 33% extra space

      while (gc.objs_free*4 < gc.objs_total)

        new_obj_block();

      while (gc.pairs_free*4 < gc.pairs_total)

        new_pair_block();

    }

}

static void **

gc_alloc_pair(void *a, void *d)

{

  if (!gc.pairs_freelist)

    {

      gc_run();

      if (!gc.pairs_freelist)

        new_pair_block();

    }

  else if (gc.debug)

    gc_run();

  void **p = gc.pairs_freelist;

  gc.pairs_freelist = (void**)p[0];

  gc.pairs_free -= 1;

  p[0] = a;

  p[1] = d;

  return p;

}

static void **

gc_alloc_object(void *obj)

{

  if (!gc.objs_freelist)

    {

      gc_run();

      if (!gc.objs_freelist)

        new_obj_block();

    }

  else if (gc.debug)

    gc_run();

  void **p = gc.objs_freelist;

  gc.objs_freelist = (void**)p[0];

  gc.objs_free -= 1;

  p[0] = p[1] = obj;

  return p;

}

/* ---- USER FUNCTIONS --- */

miniexp_t

minilisp_acquire_gc_lock(miniexp_t x)

{

  CSLOCK(locker);

  gc.lock++;

  return x;

}

miniexp_t

minilisp_release_gc_lock(miniexp_t x)

{

  minivar_t v = x;

  {

    CSLOCK(locker);

    if (gc.lock > 0)

      if (--gc.lock == 0)

        if (gc.request > 0)

          gc_run();

  }

  return x;

}

void 

minilisp_gc(void)

{

  CSLOCK(locker);

  for (gctls_t *tls = gc.tls; tls; tls=tls->next)

    for (int i=0; i

      tls->recent[i] = 0;

  gc_run();

}

void 

minilisp_debug(int debug)

{

  gc.debug = debug;

}

void 

minilisp_info(void)

{

  CSLOCK(locker);

  time_t tim = time(0);

  const char *dat = ctime(&tim);

  printf("--- begin info -- %s", dat);

  printf("symbols: %d symbols in %d buckets\n", 

         symbols->nelems, symbols->nbuckets);

  if (gc.debug)

    printf("gc.debug: true\n");

  if (gc.lock)

    printf("gc.locked: true, %d requests\n", gc.request);

  printf("gc.pairs: %d free, %d total\n", gc.pairs_free, gc.pairs_total);

  printf("gc.objects: %d free, %d total\n", gc.objs_free, gc.objs_total);

  printf("--- end info -- %s", dat);

}

miniexp_t

miniexp_mutate(miniexp_t, miniexp_t *var, miniexp_t val)

{

  CSLOCK(locker);

  *var = val;

  return val;

}

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

/* MINIVARS                                           */

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

minivar_t::minivar_t()

  : data(0)

{

  CSLOCK(locker);

  if ((next = vars))

    next->pprev = &next;

  pprev = &vars;

  vars = this;

}

minivar_t::minivar_t(miniexp_t p)

  : data(p)

{

  CSLOCK(locker);

  if ((next = vars))

    next->pprev = &next;

  pprev = &vars;

  vars = this;

}

minivar_t::minivar_t(const minivar_t &v)

  : data(v.data)

{

  CSLOCK(locker);

  if ((next = vars))

    next->pprev = &next;

  pprev = &vars;

  vars = this;

}

minivar_t::~minivar_t()

{ 

  CSLOCK(locker);

  if ((*pprev = next)) 

    next->pprev = pprev; 

}

minivar_t *minivar_t::vars = 0;

void

minivar_t::mark(minilisp_mark_t *f)

{

  for (minivar_t *v = vars; v; v=v->next)

    (*f)(&v->data);

}

minivar_t *

minivar_alloc(void)

{

  return new minivar_t;

}

void 

minivar_free(minivar_t *v)

{

  delete v;

}

miniexp_t *

minivar_pointer(minivar_t *v)

{

  return &(*v);

}

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

/* LISTS                                              */

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

static inline miniexp_t &

car(miniexp_t p) {

  return ((miniexp_t*)p)[0];

}

static inline miniexp_t &

cdr(miniexp_t p) {

  return ((miniexp_t*)p)[1];

}

int 

miniexp_length(miniexp_t p)

{

  int n = 0;

  bool toggle = false;

  miniexp_t q = p;

  while (miniexp_consp(p))

    {

      p = cdr(p);

      if (p == q)

        return -1;

      if ((toggle = !toggle))

        q = cdr(q);

      n += 1;

    }

  return n;

}

miniexp_t 

miniexp_caar(miniexp_t p)

{

  return miniexp_car(miniexp_car(p)); 

}

miniexp_t 

miniexp_cadr(miniexp_t p)

{

  return miniexp_car(miniexp_cdr(p)); 

}

miniexp_t 

miniexp_cdar(miniexp_t p)

{

  return miniexp_cdr(miniexp_car(p)); 

}

miniexp_t 

miniexp_cddr(miniexp_t p)

{

  return miniexp_cdr(miniexp_cdr(p)); 

}

miniexp_t 

miniexp_caddr(miniexp_t p)

{

  return miniexp_car(miniexp_cdr(miniexp_cdr(p)));

}

miniexp_t 

miniexp_cdddr(miniexp_t p)

{

  return miniexp_cdr(miniexp_cdr(miniexp_cdr(p)));

}

miniexp_t 

miniexp_nth(int n, miniexp_t l)

{

  while (--n>=0 && miniexp_consp(l)) 

    l = cdr(l);

  return miniexp_car(l);

}

miniexp_t 

miniexp_cons(miniexp_t a, miniexp_t d)

{

  CSLOCK(locker);

  miniexp_t r = (miniexp_t)gc_alloc_pair((void*)a, (void*)d); 

  gctls_t *tls = gctls();

  tls->recent[(++(tls->recentindex)) & (recentsize-1)] = (void**)r;

  return r;

}

miniexp_t 

miniexp_rplaca(miniexp_t pair, miniexp_t newcar)

{

  if (miniexp_consp(pair))

    return miniexp_mutate(pair, &car(pair), newcar);

  return 0;

}

miniexp_t 

miniexp_rplacd(miniexp_t pair, miniexp_t newcdr)

{

  if (miniexp_consp(pair))

    return miniexp_mutate(pair, &cdr(pair), newcdr);

  return 0;

}

miniexp_t 

miniexp_reverse(miniexp_t p)

{

  miniexp_t l = 0;

  while (miniexp_consp(p))

    {

      miniexp_t q = cdr(p);

      miniexp_mutate(p, &cdr(p), l);

      l = p;

      p = q;

    }

  return l;

}

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

/* MINIOBJ                                            */

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

miniobj_t::~miniobj_t()

{

}

const miniexp_t miniobj_t::classname = 0;

bool

miniobj_t::isa(miniexp_t) const

{

  return false;

}