% -*- mode: Noweb; noweb-code-mode: c-mode -*-
% $Id: stdlib.nw,v 1.18 2005-03-08 03:36:22 govereau Exp $
% ---------------------------------------------------------------------------
\section{Tiger Standard Library}
\label{sec:stdlib}
% ---------------------------------------------------------------------------
<<stdlib.h>>=
#include <stdio.h>
#include <stdlib.h>

/* Internal representation of strings */
typedef struct _string {
  unsigned length;
  unsigned char chars[1];
} string;

/* standard library funcitons */
void     tig_print(string *s);
void     tig_printi(int n);
void     tig_flush(void);
string*  tig_getchar(void);
int      tig_ord(string *s);
string*  tig_chr(unsigned i);
unsigned tig_size(string* s);
unsigned tig_sizea(void* array);
string*  tig_substring(string*, unsigned first, unsigned n);
string*  tig_concat(string *a, string *b);
int      tig_not(int i);
void     tig_exit(int status);
@
% ---------------------------------------------------------------------------
\subsection{Standard Library Implementation}
% ---------------------------------------------------------------------------
The standard library is implemented in C and C--. Whenever we cross
over to [[C]] we must save and restore the allocation pointer because
it is held in a [[C--]] global variable which may be a register. Any
library function that needs to allocate memory is written in C-- so
that we can call the [[tig_alloc]] function without crossing over to
[[C]] and back. In addition, during allocation we may need to call the
garbage collector, and we want to ensure that local variables will be
found by the runtime system when walking the stack. Therefore, we do
not want any [[C]] frames on the stack if we can avoid it.
<<stdlib.c>>=
#include <qc--runtime.h>
#include "stdlib.h"
#include "gc.h"
#include <string.h>
#include <assert.h>
<<C functions>>
@ 
<<stdlibcmm.c-->>=
target byteorder little memsize 8 wordsize 32 pointersize 32;
import bits32 tig_alloc;
import bits32 unwinder;
import bits32 printf;
import bits32 exit;
import bits32 getchar;
import bits32 bcopy;

export tig_substring;
export tig_concat;
export tig_chr;
export tig_getchar;
export tig_set_handler;
export tig_raise;
export tig_unwind;
export tig_spawn;

bits32 alloc_ptr;
section "data" { <<C-- data>> }
<<C-- functions>>
@
\paragraph{Library Functions}
To start off, we will define the easy one line C functions.
<<C functions>>=
unsigned tig_sizea(void* array) { return *((int*)array); }
unsigned tig_size(string *s)    { return s->length;      }
int      tig_not(int i)         { return !i;             }
void     tig_exit(int status)   { exit(status);          }
void     tig_flush()            { fflush(stdout);        }
void     tig_printi(int n)      { printf("%d", n);       }
void     tig_print(string *s)   { printf("%s", s->chars);}
@ 
From within the standard library, strings are the only thing that we
need to allocate memory for. This small function calls the allocator
and initializes the memory according to the [[string]] structure
definition.
<<C-- functions>>=
new_string(bits32 size) {
  bits32 str_ptr;
  str_ptr = tig_alloc(size + 4 + 1);
  bits32[str_ptr] = size;
  bits8[str_ptr + 4 + size] = 0 :: bits8;
  return(str_ptr);
}
@
The [[chr]] and [[getchar]] functions both allocate a string of length
1. In Tiger, [[EOF]] is equivalent to the empty string.
<<C-- functions>>=
tig_chr(bits32 ch) {
  bits32 str_ptr;
  str_ptr = new_string(1);
  bits8[str_ptr+4] = %lobits8(ch);
  return(str_ptr);
}
<<C-- functions>>=
tig_getchar() {
  bits32 ch;
  bits32 p;
  p = alloc_ptr;
  ch = foreign "C" getchar();
  alloc_ptr = p;
  p = tig_chr(ch);
  if (ch == 0xFFFFFFFF) {
    bits32[p] = 0;
  }
  return(p);
}
@ 
The bounds check function is called before all array accesses to
provide dynamic array bounds checking.
<<C functions>>=
void tig_bounds_check(void *array, int index, int line) {
  int size = tig_sizea(array);
  if (index < 0 || index >= size) {
    fprintf(stderr, "Runtime Error line(%d): Attempt to access "
            "array index %d for array of size %d\n",
            line, index, size);
    exit(1);
  }
}
@ 
The [[ord]] function can only be called on strings of length one. In
this case, the character is converted to an integer and returned.
<<C functions>>=
int tig_ord(string *s) {
  if (s->length != 1) {
    fprintf(stderr, "Tiger program took ord of string of length %d\n",
            s->length);
    exit(1);
  }
  return s->chars[0];
}
@ 
String comparison should return -1, 0, or 1 if the first string is
less than, equal to, or greater that the second string.
<<C functions>>=
int tig_compare_str(string *s, string *t) {
  int i;
  assert(t);
  assert(s);
  if (s == t) return 0;

  if (s->length == t->length)
    return strncmp(s->chars, t->chars, s->length);

  i = strncmp(s->chars, t->chars,
              (s->length < t->length ? s->length : t->length));

  if (i != 0) return i;
  if (s->length < t->length) return -1;
  return 1;
}
@ 
The implementation of substring must allocate memory to hold the new
string. In addition, this function will have a live heap pointer (the
input string) during the allocation, and we want to be able to locate
this pointer in the case of a garbage collection. Therefore, we
implement this function in [[C--]].
<<C-- data>>=
 substr_msg: bits8[] "substring: index (%d,%d) out of range of (0,%d)\n\000";
<<C-- functions>>=
tig_substring("address" bits32 str_ptr, bits32 first, bits32 length) {
  bits32 new_str_ptr;
  bits32 ap;
  if (first < 0)                        { goto Lerror; }
  if (first + length > bits32[str_ptr]) { goto Lerror; }

  new_str_ptr = new_string(length);
  ap = alloc_ptr;
  foreign "C" bcopy(str_ptr+first+4, new_str_ptr+4, length);
  alloc_ptr = ap;
  return(new_str_ptr);

Lerror:
  foreign "C" printf(substr_msg, first, length, bits32[str_ptr]);
  foreign "C" exit(1) never returns;
  return(0);
}
@ 
String concatenation has a similar constraint as substring, and it is
also implemented in [[C--]].
<<C-- functions>>=
tig_concat("address" bits32 str_a, "address" bits32 str_b) {
  bits32 new_str;
  bits32 ap;
  if (bits32[str_a] == 0) { return(str_b); }
  if (bits32[str_b] == 0) { return(str_a); }

  new_str = new_string(bits32[str_a] + bits32[str_b]);
  ap = alloc_ptr;
  foreign "C" bcopy(str_a+4, new_str+4,               bits32[str_a]);
  foreign "C" bcopy(str_b+4, new_str+4+bits32[str_a], bits32[str_b]);
  alloc_ptr = ap;
  return(new_str);
}
@ 
\paragraph{Exceptions}
There are two implementations of exceptions in the Tiger compiler. The
first implementation maintains the current closest exception handler
dynamically using the [[tig_set_handler]] function. Raising an
exception can then be done with a [[C--]] cut to statement.
<<C-- data>>=
 curr_exn : bits32;
<<C-- functions>>=
tig_set_handler(bits32 exn) {
  bits32 old_exn;
  old_exn = bits32[curr_exn];
  bits32[curr_exn] = exn;
  return(old_exn);
}
tig_raise(bits32 exn_id) {
  cut to bits32[curr_exn](exn_id);
  return;
}
@
The second implementation unwinds the stack using the [[C--]] runtime
interface.
<<C-- functions>>=
tig_unwind(bits32 exn_id) {
  foreign "C" unwinder(k, exn_id) also aborts also cuts to k;
  return;
continuation k():
  return;
}
<<C functions>>=
void unwinder(Cmm_Cont* k, unsigned exn_id) {
  Cmm_Activation a = Cmm_YoungestActivation(k); 
  do {
    if ((unsigned)Cmm_GetDescriptor(&a, 2) == 1) {
      Cmm_Cont* exn = Cmm_MakeUnwindCont(&a, 0, exn_id);
      Cmm_CutTo(exn);
      return;
    }
  } while(Cmm_ChangeActivation(&a));
  assert(0);
}
@
<<C-- data>>=
 spawn_msg : bits8[] "spawning to %X\n\000";
<<C-- functions>>=
tig_spawn(bits32 lbl) {
  foreign "C" printf(spawn_msg, lbl);
  return(0);
}
@