Below, the rewritten runtime in one chunk. The thing is pretty much untested. I had a logical error and changed the representation a bit. A primitive constant now is a series of bits with a size header, a zero constant, a type tag integer, and a value. On 64 bit intel, it means a whopping 256 bits for most primitives, but that's not too bad for something which is meant to be close to a scripting language I guess.
I post it as one chunk since that is how it is meant to be used. I.e., it should be included with the compiled program such that the C optimizer can inline as much as possible.
This chunk doesn't include combinators and primitive calls to the runtime. I am at 2-3 kLoC, expect to end at 3-4 kLoC.
I like the representation, it's good enough for me. Can't say I like the collector much. Two optimizations could be done, a nursery for newly allocated objects and a separate region for constants. The first would be good, the second I don't think is necessary if most constants are static data anyway. Good about the collector is its interface, i.e., it should be easy to drop in new collectors with similar calls.
//** start of file: assert/assert.h
/**
* COPYRIGHT 2010, M.C.A. Devillers
*
* THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY
* EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK.
*
* Two macros which handle debugging.
*/
#ifndef ASSERT_H
#define ASSERT_H
#include <stdlib.h>
#include <stdio.h>
#ifndef TRACE
#define TRACE \
{fprintf(stdout, \
"file %s: line %d: trace\n", \
__FILE__, \
__LINE__); \
fflush(stdout);}
#endif
#ifndef ASSERT
#define ASSERT(b) \
{if (!(b)) { \
fprintf(stderr, \
"file %s: line %d: assertion failed (%s)\n", \
__FILE__, \
__LINE__, \
#b); \
exit(1); \
} \
};
#endif
#ifndef DEBUG
#define DEBUG(b) b
#endif
#endif // ASSERT_H
//** end of file: assert/assert.h
//** start of file: types/types.h
/**
* COPYRIGHT 2008, M.C.A. Devillers
*
* THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY
* EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK.
*
* Internally used types and conversions from them to native C types.
*
* A number of these routines are added at the moment pure for
* debugging purposes. It is expected the compiler compiles static
* values to C static values.
*
* A Hi value is either a constant, a record, or a thunk. They are
* tagged with record and type tags.
*
* A constant is a size bounded, type tagged, series of bits.
*
* c[0] size of the constant (number of hi_ints)
* c[1] 0
* c[2] type tag
* c[3..] bits which make up the constant (with unused extra bits)
*
* A record is a size bounded, record and type tagged, series of
* pointers.
*
* r[0] size of the record (number of hi_ints)
* r[1] 1
* r[2] record record field pointer
* r[3] record type field pointer
* r[4..] pointers which make up the record
*
* This encoding is pretty portable but uses a lot of bits.
* For example, any simple integer value is encoded with 4 * 64 is
* 256 bits on an Intel 64 bit system.
*
* Bit packing, and using a seperate info record for rtti is for
* later.
*
* Assuming that most tags are shared, some of that burden is
* aleviated.
*
* Tested on:
* Intel x86-64
*/
#ifndef TYPES_H
#define TYPES_H
#include <stdlib.h>
#include <stdint.h>
#include "ffi.h"
#define HI_SIZE(t) \
((sizeof(t) + sizeof(hi_int) - 1)/(sizeof(hi_int)))
typedef void hi_void;
#if SCHAR_MAX == 127
typedef unsigned char hi_uint8;
typedef signed char hi_sint8;
#else
#error "int8 size not supported"
#endif
#if SHRT_MAX == 32767
typedef unsigned short hi_uint16;
typedef signed short hi_sint16;
#elif INT_MAX == 32767
typedef unsigned int hi_uint16;
typedef signed int hi_sint16;
#else
#error "int16 size not supported"
#endif
#if INT_MAX == 2147483647
typedef unsigned int hi_uint32;
typedef signed int hi_sint32;
#elif SHRT_MAX == 2147483647
typedef unsigned short hi_uint32;
typedef signed short hi_sint32;
#elif LONG_MAX == 2147483647
typedef unsigned long hi_uint32;
typedef signed long hi_sint32;
#else
#error "int32 size not supported"
#endif
#if INT_MAX == 9223372036854775807
typedef unsigned int hi_uint64;
typedef signed int hi_sint64;
#elif LONG_MAX == 9223372036854775807
typedef unsigned long hi_uint64;
typedef signed long hi_sint64;
#else
#error "int64 size not supported"
#endif
typedef hi_uint64 hi_int;
typedef char hi_char;
typedef float hi_float;
typedef double hi_double;
typedef long double hi_ldouble;
typedef void* hi_pointer;
typedef char* hi_string;
static const hi_int void_tag;
static const hi_int int_tag;
static const hi_int char_tag;
static const hi_int float_tag;
static const hi_int double_tag;
static const hi_int ldouble_tag;
static const hi_int pointer_tag;
static const hi_int string_tag;
static const hi_int array_tag;
static const hi_int uint8_tag;
static const hi_int sint8_tag;
static const hi_int uint16_tag;
static const hi_int sint16_tag;
static const hi_int uint32_tag;
static const hi_int sint32_tag;
static const hi_int uint64_tag;
static const hi_int sint64_tag;
int is_int(hi_int* v);
int is_char(hi_int* v);
int is_float(hi_int* v);
int is_double(hi_int* v);
int is_ldouble(hi_int* v);
int is_pointer(hi_int* v);
int is_string(hi_int* v);
int is_array(hi_int* v);
hi_int* convert_from_int(int v);
hi_int* convert_from_char(hi_char v);
hi_int* convert_from_float(hi_float v);
hi_int* convert_from_double(hi_double v);
hi_int* convert_from_ldouble(hi_ldouble v);
hi_int* convert_from_pointer(hi_pointer v);
hi_int* convert_from_string(char* v);
hi_int* convert_from_uint8(hi_uint8 v);
hi_int* convert_from_sint8(hi_sint8 v);
hi_int* convert_from_uint16(hi_uint16 v);
hi_int* convert_from_sint16(hi_sint16 v);
hi_int* convert_from_uint32(hi_uint32 v);
hi_int* convert_from_sint32(hi_sint32 v);
hi_int* convert_from_uint64(hi_uint64 v);
hi_int* convert_from_sint64(hi_sint64 v);
int* get_int(hi_int* v);
hi_char* get_char(hi_int* v);
hi_float* get_float(hi_int* v);
hi_double* get_double(hi_int* v);
hi_ldouble* get_ldouble(hi_int* v);
hi_pointer* get_pointer(hi_int* v);
char* get_string(hi_int* v);
hi_uint8* get_uint8(hi_int* v);
hi_sint8* get_sint8(hi_int* v);
hi_uint16* get_uint16(hi_int* v);
hi_sint16* get_sint16(hi_int* v);
hi_uint32* get_uint32(hi_int* v);
hi_sint32* get_sint32(hi_int* v);
hi_uint64* get_uint64(hi_int* v);
hi_sint64* get_sint64(hi_int* v);
int convert_to_int(hi_int* v);
hi_char convert_to_char(hi_int* v);
hi_float convert_to_float(hi_int* v);
hi_double convert_to_double(hi_int* v);
hi_ldouble convert_to_ldouble(hi_int* v);
hi_pointer convert_to_pointer(hi_int* v);
char* convert_to_string(hi_int* v);
hi_uint8 convert_to_uint8(hi_int* v);
hi_sint8 convert_to_sint8(hi_int* v);
hi_uint16 convert_to_uint16(hi_int* v);
hi_sint16 convert_to_sint16(hi_int* v);
hi_uint32 convert_to_uint32(hi_int* v);
hi_sint32 convert_to_sint32(hi_int* v);
hi_uint64 convert_to_uint64(hi_int* v);
hi_sint64 convert_to_sint64(hi_int* v);
static hi_int* system_unit_tag;
static hi_int* system_nop_tag;
static hi_int* system_bool_tag;
static hi_int* system_true_tag;
static hi_int* system_false_tag;
static hi_int* system_unit_nop;
static hi_int* system_bool_true;
static hi_int* system_bool_false;
hi_int convert_to_constant_tag(char* v);
char* convert_from_constant_tag(hi_int v);
hi_int* convert_to_record_tag(char* v);
char* convert_from_record_tag(hi_int* v);
hi_int* get_record_tag(hi_int* v);
hi_int* get_type_tag(hi_int* v);
int is_nop(hi_int* v);
int is_true(hi_int* v);
int is_false(hi_int* v);
void print_hi_value(FILE* f, hi_int* v);
#endif // TYPES_H
//** end of file: types/types.h
//** start of file: types/types.c
/**
* COPYRIGHT 2008, M.C.A. Devillers
*
* THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY
* EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK.
*
*/
#include <stdlib.h>
#include <stdio.h>
#include <stdint.h>
#include <string.h>
#include "ffi.h"
//////////////////////////////////////////////////////////////////////
#ifndef ONE_LARGE_FILE
#include "types.h"
#include "../assert/assert.h"
#endif
//////////////////////////////////////////////////////////////////////
#define ENCODEx86_64(c0,c1,c2,c3,c4,c5,c6,c7) \
( (((hi_uint64) c0) << 0) | \
(((hi_uint64) c1) << 8) | \
(((hi_uint64) c2) << 16) | \
(((hi_uint64) c3) << 24) | \
(((hi_uint64) c4) << 32) | \
(((hi_uint64) c5) << 40) | \
(((hi_uint64) c6) << 48) | \
(((hi_uint64) c7) << 56) )
#define ENCODE8(c0,c1,c2,c3,c4,c5,c6,c7) \
ENCODEx86_64(c0,c1,c2,c3,c4,c5,c6,c7)
#define ENCODE16(c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,cA,cB,cC,cD,cE,cF) \
ENCODE8(c0,c1,c2,c3,c4,c5,c6,c7), \
ENCODE8(c8,c9,cA,cB,cC,cD,cE,cF)
//////////////////////////////////////////////////////////////////////
static const hi_int void_tag =
ENCODE8('v','o','i','d', 0, 0, 0, 0);
static const hi_int int_tag =
ENCODE8('i','n','t', 0, 0, 0, 0, 0);
static const hi_int char_tag =
ENCODE8('c','h','a','r', 0, 0, 0, 0);
static const hi_int float_tag =
ENCODE8('f','l','o','a','t', 0, 0, 0);
static const hi_int double_tag =
ENCODE8('d','o','u','b','l','e', 0, 0);
static const hi_int ldouble_tag =
ENCODE8('l','d','o','u','b','l','e', 0);
static const hi_int pointer_tag =
ENCODE8('p','o','i','n','t','e','r', 0);
static const hi_int string_tag =
ENCODE8('s','t','r','i','n','g', 0, 0);
static const hi_int array_tag =
ENCODE8('a','r','r','a','y', 0, 0, 0);
static const hi_int uint8_tag =
ENCODE8('u','i','n','t','8', 0, 0, 0);
static const hi_int sint8_tag =
ENCODE8('s','i','n','t','8', 0, 0, 0);
static const hi_int uint16_tag =
ENCODE8('u','i','n','t','1','6', 0, 0);
static const hi_int sint16_tag =
ENCODE8('s','i','n','t','1','6', 0, 0);
static const hi_int uint32_tag =
ENCODE8('u','i','n','t','3','2', 0, 0);
static const hi_int sint32_tag =
ENCODE8('s','i','n','t','3','2', 0, 0);
static const hi_int uint64_tag =
ENCODE8('u','i','n','t','6','4', 0, 0);
static const hi_int sint64_tag =
ENCODE8('s','i','n','t','6','4', 0, 0);
//////////////////////////////////////////////////////////////////////
int is_int(hi_int* v) {
return (v[1] == 0) && (v[2] == int_tag);
}
int is_char(hi_int* v) {
return (v[1] == 0) && (v[2] == char_tag);
}
int is_float(hi_int* v) {
return (v[1] == 0) && (v[2] == float_tag);
}
int is_double(hi_int* v) {
return (v[1] == 0) && (v[2] == double_tag);
}
int is_ldouble(hi_int* v) {
return (v[1] == 0) && (v[2] == ldouble_tag);
}
int is_pointer(hi_int* v) {
return (v[1] == 0) && (v[2] == pointer_tag);
}
int is_string(hi_int* v) {
return (v[1] == 0) && (v[2] == string_tag);
}
int is_array(hi_int* v) {
return (v[1] == 0) && (v[2] == array_tag);
}
//////////////////////////////////////////////////////////////////////
hi_int* convert_from_int(int v) {
int sz = 3 + HI_SIZE(int);
hi_int* n = (hi_int*) malloc(sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = int_tag;
n[3] = 0;
int* p = (int*) &(n[3]);
*p = v;
return n;
}
hi_int* convert_from_char(hi_char v) {
int sz = 3 + HI_SIZE(int);
hi_int* n = (hi_int*) malloc(sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = char_tag;
n[3] = 0;
char* p = (char*) &(n[3]);
*p = v;
return n;
}
hi_int* convert_from_float(hi_float v) {
int sz = 3 + HI_SIZE(hi_float);
hi_int* n = (hi_int*) malloc(sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = float_tag;
hi_float* p = (hi_float*) &(n[3]);
*p = v;
return n;
}
hi_int* convert_from_double(hi_double v) {
int sz = 3 + HI_SIZE(hi_double);
hi_int* n = (hi_int*) malloc(sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = double_tag;
hi_double* p = (hi_double*) &(n[3]);
*p = v;
return n;
}
hi_int* convert_from_ldouble(hi_ldouble v) {
int sz = 3 + HI_SIZE(hi_ldouble);
hi_int* n = (hi_int*) malloc(sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = ldouble_tag;
hi_ldouble* p = (hi_ldouble*) &(n[3]);
*p = v;
return n;
}
hi_int* convert_from_pointer(hi_pointer v) {
int sz = 3 + HI_SIZE(hi_pointer);
hi_int* n = (hi_int*) malloc(sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = pointer_tag;
hi_pointer* p = (hi_pointer*) &(n[3]);
*p = v;
return n;
}
hi_int* convert_from_string(char* v) {
int v_len = strnlen(v, 2048);
//v[v_len] = (char) 0;
int sz = 3 + (v_len + sizeof(hi_int))/sizeof(hi_int);
hi_int* n = (hi_int*) malloc(sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = string_tag;
char* p = (char*) &(n[3]);
strcpy(p, v);
return n;
}
hi_int* convert_from_uint8(hi_uint8 v) {
int sz = 3 + HI_SIZE(hi_uint8);
hi_int* n = (hi_int*) malloc(sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = uint8_tag;
hi_uint8* p = (hi_uint8*) &(n[3]);
*p = v;
return n;
}
hi_int* convert_from_sint8(hi_sint8 v) {
int sz = 3 + HI_SIZE(hi_sint8);
hi_int* n = (hi_int*) malloc(sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = sint8_tag;
hi_sint8* p = (hi_sint8*) &(n[3]);
*p = v;
return n;
}
hi_int* convert_from_uint16(hi_uint16 v) {
int sz = 3 + HI_SIZE(hi_uint16);
hi_int* n = (hi_int*) malloc(sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = uint16_tag;
hi_uint16* p = (hi_uint16*) &(n[3]);
*p = v;
return n;
}
hi_int* convert_from_sint16(hi_sint16 v) {
int sz = 3 + HI_SIZE(hi_sint16);
hi_int* n = (hi_int*) malloc(sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = sint16_tag;
hi_sint16* p = (hi_sint16*) &(n[3]);
*p = v;
return n;
}
hi_int* convert_from_uint32(hi_uint32 v) {
int sz = 3 + HI_SIZE(hi_uint32);
hi_int* n = (hi_int*) malloc(sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = uint32_tag;
hi_uint32* p = (hi_uint32*) &(n[3]);
*p = v;
return n;
}
hi_int* convert_from_sint32(hi_sint32 v) {
int sz = 3 + HI_SIZE(hi_sint32);
hi_int* n = (hi_int*) malloc(sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = sint32_tag;
hi_sint32* p = (hi_sint32*) &(n[3]);
*p = v;
return n;
}
hi_int* convert_from_uint64(hi_uint64 v) {
int sz = 3 + HI_SIZE(hi_uint64);
hi_int* n = (hi_int*) malloc(sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = uint64_tag;
hi_uint64* p = (hi_uint64*) &(n[3]);
*p = v;
return n;
}
hi_int* convert_from_sint64(hi_sint64 v) {
int sz = 3 + HI_SIZE(hi_sint64);
hi_int* n = (hi_int*) malloc(sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = sint64_tag;
hi_sint64* p = (hi_sint64*) &(n[3]);
*p = v;
return n;
}
//////////////////////////////////////////////////////////////////////
int* get_int(hi_int* v) {
return (int*) (&(v[3]));
}
hi_char* get_char(hi_int* v) {
return (hi_char*) (&(v[3]));
}
hi_float* get_float(hi_int* v) {
return (hi_float*) (&(v[3]));
}
hi_double* get_double(hi_int* v) {
return (hi_double*) (&(v[3]));
}
hi_ldouble* get_ldouble(hi_int* v) {
return (hi_ldouble*) (&(v[3]));
}
hi_pointer* get_pointer(hi_int* v) {
return (hi_pointer*) (&(v[3]));
}
char* get_string(hi_int* v) {
return (char*) (&(v[3]));
}
hi_uint8* get_uint8(hi_int* v) {
return (hi_uint8*) (&(v[3]));
}
hi_sint8* get_sint8(hi_int* v) {
return (hi_sint8*) (&(v[3]));
}
hi_uint16* get_uint16(hi_int* v) {
return (hi_uint16*) (&(v[3]));
}
hi_sint16* get_sint16(hi_int* v) {
return (hi_sint16*) (&(v[3]));
}
hi_uint32* get_uint32(hi_int* v) {
return (hi_uint32*) (&(v[3]));
}
hi_sint32* get_sint32(hi_int* v) {
return (hi_sint32*) (&(v[3]));
}
hi_uint64* get_uint64(hi_int* v) {
return (hi_uint64*) (&(v[3]));
}
hi_sint64* get_sint64(hi_int* v) {
return (hi_sint64*) (&(v[3]));
}
//////////////////////////////////////////////////////////////////////
int convert_to_int(hi_int* v) {
return *(get_int(v));
}
hi_char convert_to_char(hi_int* v) {
return *(get_char(v));
}
hi_float convert_to_float(hi_int* v) {
return *(get_float(v));
}
hi_double convert_to_double(hi_int* v) {
return *(get_double(v));
}
hi_ldouble convert_to_ldouble(hi_int* v) {
return *(get_ldouble(v));
}
hi_pointer convert_to_pointer(hi_int* v) {
return *(get_pointer(v));
}
char* convert_to_string(hi_int* v) {
return (get_string(v));
}
hi_uint8 convert_to_uint8(hi_int* v) {
return *(get_uint8(v));
}
hi_sint8 convert_to_sint8(hi_int* v) {
return *(get_sint8(v));
}
hi_uint16 convert_to_uint16(hi_int* v) {
return *(get_uint16(v));
}
hi_sint16 convert_to_sint16(hi_int* v) {
return *(get_sint16(v));
}
hi_uint32 convert_to_uint32(hi_int* v) {
return *(get_uint32(v));
}
hi_sint32 convert_to_sint32(hi_int* v) {
return *(get_sint32(v));
}
hi_uint64 convert_to_uint64(hi_int* v) {
return *(get_uint64(v));
}
hi_sint64 convert_to_sint64(hi_int* v) {
return *(get_sint64(v));
}
//////////////////////////////////////////////////////////////////////
static hi_int system_unit[5] = {
5,
0,
ENCODE8('s','t','r','i','n','g', 0, 0),
ENCODE16('s','y','s','t','e','m','.','u','n','i','t',0,0,0,0,0)
};
static hi_int* system_unit_tag = system_unit;
static hi_int system_nop[5] = {
5,
0,
ENCODE8('s','t','r','i','n','g', 0, 0),
ENCODE16('s','y','s','t','e','m','.','n','o','p',0,0,0,0,0,0)
};
static hi_int* system_nop_tag = system_nop;
static hi_int system_bool[5] = {
5,
0,
ENCODE8('s','t','r','i','n','g', 0, 0),
ENCODE16('s','y','s','t','e','m','.','b','o','o','l',0,0,0,0,0)
};
static hi_int* system_bool_tag = system_bool;
static hi_int system_true[5] = {
5,
0,
ENCODE8('s','t','r','i','n','g', 0, 0),
ENCODE16('s','y','s','t','e','m','.','t','r','u','e',0,0,0,0,0)
};
static hi_int* system_true_tag = system_true;
static hi_int system_false[5] = {
5,
0,
ENCODE8('s','t','r','i','n','g', 0, 0),
ENCODE16('s','y','s','t','e','m','.','f','a','l','s','e',0,0,0,0)
};
static hi_int* system_false_tag = system_false;
//////////////////////////////////////////////////////////////////////
hi_int convert_to_constant_tag(char* v) {
return *((hi_int*) v);
}
char* convert_from_constant_tag(hi_int* v) {
return (char*) &(v[2]);
}
hi_int* convert_to_record_tag(char* v) {
return convert_from_string(v);
}
char* convert_from_record_tag(hi_int* v) {
return convert_to_string(v);
}
//////////////////////////////////////////////////////////////////////
static hi_int system_unit_nop_record[4] = {
4,
1,
(hi_int) system_unit,
(hi_int) system_nop,
};
static hi_int* system_unit_nop = system_unit_nop_record;
static hi_int system_bool_false_record[4] = {
4,
1,
(hi_int) system_bool,
(hi_int) system_false,
};
static hi_int* system_bool_false = system_bool_false_record;
static hi_int system_bool_true_record[4] = {
4,
1,
(hi_int) system_bool,
(hi_int) system_true,
};
static hi_int* system_true_false = system_bool_true_record;
//////////////////////////////////////////////////////////////////////
hi_int* get_type_tag(hi_int* v) {
return ((hi_int*) v[2]);
}
hi_int* get_record_tag(hi_int* v) {
return ((hi_int*) v[3]);
}
//////////////////////////////////////////////////////////////////////
int is_nop(hi_int* v) {
return (v[1] == 1) &&
(strncmp(convert_from_record_tag((hi_int*) v[3]), "system.nop", 32) == 0);
}
int is_true(hi_int* v) {
return (v[1] == 1) &&
(strncmp(convert_from_record_tag((hi_int*) v[3]), "system.true", 32) == 0);
}
int is_false(hi_int* v) {
return (v[1] == 1) &&
(strncmp(convert_from_record_tag((hi_int*) v[3]), "system.false", 32) == 0);
}
//////////////////////////////////////////////////////////////////////
void print_hi(FILE* f, hi_int* v) {
if (v == 0) {
fprintf(f, "(null)");
} else if ( (v[0] > 2048) || (v[0] < 0) ) {
fprintf(f, "(garbled)");
} else if (is_nop(v)) {
fprintf(f, "nop");
} else if (is_true(v)) {
fprintf(f, "true");
} else if (is_false(v)) {
fprintf(f, "false");
} else if (is_char(v)) {
fprintf(f, "'%c'", convert_to_uint8(v));
} else if (is_int(v)) {
fprintf(f, "%d", convert_to_uint64(v));
} else if (is_float(v)) {
fprintf(f, "%f", convert_to_float(v));
} else if (is_double(v)) {
fprintf(f, "%f", convert_to_double(v));
} else if (is_string(v)) {
fprintf(f, "%s", convert_to_string(v));
} else if (is_pointer(v)) {
fprintf(f, "%x", convert_to_pointer(v));
} else if ( v[1] == 0 ) {
fprintf(f, "('%s' ", &(v[2]));
int i;
for (i = 3; i < v[0]; i++) {
fprintf(f, " %d", v[i]);
}
fprintf(f, ")");
} else if ( v[1] == 1 ) {
fprintf(f, "(");
print_hi(f, (hi_int*) v[2]);
fprintf(f, " ");
print_hi(f, (hi_int*) v[3]);
int i;
for (i = 4; i < v[0]; i++) {
fprintf(f, " ");
print_hi(f, (hi_int*) v[i]);
}
fprintf(f, ")");
} else {
fprintf(f, "[");
int i;
for (i = 1; i < v[0]; i++) {
fprintf(f, "%p ", (hi_int*) v[i]);
}
fprintf(f, "]");
}
}
//////////////////////////////////////////////////////////////////////
//** end of file: types/types.c
//** start of file: heap/heap.h
/**
* COPYRIGHT 2010, M.C.A. Devillers
*
* THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY
* EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK.
*
* A simple library for a Cheney style heap.
*
* 1. Every value is either a pointer or an integer of pointer size.
*
* 2. The heap holds nodes. Every node starts of with a two integer
* header. The first integer describes the size of the whole node,
* the second integer is either 0, in which case all values in
* that node are integers, or not, in which case all values in
* that node are pointers to other nodes possibly in that heap.
*
* Note: the Hi language runtime elaborates on the meaning of the
* second integer in the following manner:
* 0 - a constant, 1 - a record, otherwise - a thunk.
*
* 3. At the moment, the collector is semi-exact. Pointers which do
* not point into the heap are not chased. This makes it possible
* to use pointers to static data, and it makes it possible to
* use small integers as if they would be integers.
*
* It implies serialization of static data is handled
* different, it serializes everything and can only handle non-
* cyclic structures which is a severe drawback.
*
* 4. A heap may be GCed, in which case _a whole new heap is
* allocated_ and the heap is copied to the new heap. This is to
* facilitate multi-core processing of several coarse-grained
* threads without the need to keep unused to spaces around for
* all heaps used.
* Ordinary 'malloc' is used to allocate new heaps.
*
* 5. The heap size may be grown at will for special operations.
* There are no facilities, as of yet, to shrink the heap size.
*
* 6. A heap may be serialized to a region in memory, in which case
* only the first root node is copied. Unserialization inserts a
* root node from a region in memory to a given heap.
*
* A design which is neither very compact nor very fast, but minimal
* and robust.
*/
#ifndef HEAP_H
#define HEAP_H
#include <stdio.h>
#include <stdint.h>
#ifndef ONE_LARGE_FILE
#include "../types/types.h"
#endif
#define ROOTS 1024
typedef struct {
hi_int size;
hi_int* low;
hi_int* high;
hi_int* free;
hi_int* trigger_gc;
hi_int* trigger_grow;
hi_int root_free;
hi_int* root[ROOTS];
hi_int* memory;
} heap_t;
heap_t* heap_create(hi_int sz);
void* heap_destroy(heap_t* hp);
hi_int heap_root_count(heap_t* hp);
hi_int heap_root_new(heap_t* hp);
void heap_root_set(heap_t* hp, hi_int n, hi_int* r);
hi_int* heap_root_get(heap_t* hp, hi_int n);
hi_int* heap_allocate(heap_t* hp, hi_int sz);
heap_t* heap_collect(heap_t* hp);
heap_t* heap_try_collect(heap_t* hp);
heap_t* heap_reserve(heap_t* hp, hi_int sz);
hi_int heap_serialize(heap_t* hp, void* p, hi_int sz);
hi_int* heap_unserialize(heap_t* hp, void* p, hi_int sz);
hi_int heap_size(heap_t* hp);
hi_int heap_used(heap_t* hp);
hi_int heap_free(heap_t* hp);
void heap_info(FILE* f, heap_t* hp);
void heap_debug(FILE* f, heap_t* hp);
hi_int* heap_int(heap_t* hp, int v);
hi_int* heap_char(heap_t* hp, hi_char v);
hi_int* heap_float(heap_t* hp, hi_float v);
hi_int* heap_double(heap_t* hp, hi_double v);
hi_int* heap_ldouble(heap_t* hp, hi_ldouble v);
hi_int* heap_pointer(heap_t* hp, hi_pointer v);
hi_int* heap_string(heap_t* hp, char* v);
hi_int* heap_uint8(heap_t* hp, hi_uint8 v);
hi_int* heap_sint8(heap_t* hp, hi_sint8 v);
hi_int* heap_uint16(heap_t* hp, hi_uint16 v);
hi_int* heap_sint16(heap_t* hp, hi_sint16 v);
hi_int* heap_uint32(heap_t* hp, hi_uint32 v);
hi_int* heap_sint32(heap_t* hp, hi_sint32 v);
hi_int* heap_uint64(heap_t* hp, hi_uint64 v);
hi_int* heap_sint64(heap_t* hp, hi_sint64 v);
#endif // HEAP_H
//** end of file: heap/heap.h
//** start of file: heap/heap.c
/**
* COPYRIGHT 2008, M.C.A. Devillers
*
* THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY
* EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK.
*/
#include <stdlib.h>
#include <string.h>
#include <dlfcn.h>
#ifndef ONE_LARGE_FILE
#include "../assert/assert.h"
#include "heap.h"
#endif
#define BITS_SET(b0,b1) ((b0) | (b1))
#define BITS_UNSET(b0,b1) ((b0) & (~(b1)))
#define BITS_TEST(b0,b1) (((b0) & (b1)) != 0)
#define BITS_FLIP(b0,b1) ((b0) (b1))
#define BIT_SET(n,b) BITS_SET(n, 1<<b)
#define BIT_UNSET(n,b) BITS_UNSET(n, 1<<b)
#define BIT_TEST(n,b) BITS_TEST(n, 1<<b)
#define BIT_FLIP(n,b) BITS_FLIP(n, 1<<b)
#define BELOW(p,q) (((void*) p) < ((void*) q))
#define BELOWEQ(p,q) ((void*) p <= (void*) q)
#define IN_HEAP(p, l, h) \
( ((void*) p >= (void*) l) && ((void*) p < (void*) h) )
#define DIFFERENCE(p,q) ((hi_int)((void*)p - (void*) q))
#define INCREMENT(p,n) ((hi_int*)((void*)p + (int) n))
#define DECREMENT(p,n) ((hi_int*)((void*)p - (int) n))
#define ADVANCE(p,n) &(((hi_int*)p)[(int)n])
#define RETREAT(p,n) &(((hi_int*)p)[0-(int)n])
#define HEAP_ALLIGNMENT 512
#define HEAP_MINIMAL_GROW 2048
#define HEAP_MINIMAL_FREE 1024
#define HEAP_MINIMAL_SIZE 4096
#define SMALL_INTEGER 64*1024
#define IS_SMALL_INTEGER(p) BELOW(p, (SMALL_INTEGER))
/** Allocate alligned memory.
*
* /param m the size to be allocared
* /param n the alignement (some power of two, preferably cache-size)
* /return a chunk of memory
*/
void* malloc_alligned(size_t m, int n) {
TRACE;
void* p = 0;
if (posix_memalign(&p, n, m) == 0) {
ASSERT(!IS_SMALL_INTEGER(p));
return p;
} else {
return 0;
}
}
/** Create a heap.
*
* The heap size is _not_ the number of bytes allocated, but the
* total number of bytes _including_ the header size.
*
* Exits if a new heap cannot be allocated.
*
* /param sz the heap size
* /return a heap
*/
heap_t* heap_create(hi_int sz) {
TRACE;
ASSERT(sz >= HEAP_MINIMAL_SIZE);
heap_t* r = (heap_t*) malloc_alligned(sz, HEAP_ALLIGNMENT);
if (r == 0) {
fprintf(stderr,
"HEAP_PANIC[0]: failed to allocate a heap of size %u\n",
(unsigned int) sz);
exit(1);
}
r->size = sz;
r->low = (hi_int*) &(r->memory);
r->high = INCREMENT(r, sz);
r->free = r->low;
r->root_free = 0;
DEBUG(hi_int i;)
DEBUG(for (i = 0; i < ROOTS; i++) r->root[i] = 0;)
r->trigger_gc = DECREMENT(r->high, HEAP_MINIMAL_FREE);
r->trigger_grow = DECREMENT(r->high, HEAP_MINIMAL_GROW);
DEBUG(hi_int* p;)
DEBUG(for (p = r->low; p < r->high; p++) *p = 0;)
return r;
}
/** Destroy a heap.
*
* /param hp a heap
*/
void* heap_destroy(heap_t* hp) {
TRACE;
free(hp);
return 0;
}
/** Give the number of roots in the heap.
*
* /param hp a heap
* /return the number of roots
*/
hi_int heap_root_count(heap_t* hp) {
TRACE;
return hp->root_free;
}
/** Allocate a new root slot in the heap.
*
* The number of roots is a fixed number, see ROOTS.
*
* Exits if there are no more roots available.
*
* /param hp a heap
* /return a new root slot
*/
hi_int heap_root_new(heap_t* r) {
TRACE;
hi_int free = r->root_free;
r->root_free++;
if (r->root_free > ROOTS) {
fprintf(stderr,
"HEAP_PANIC[1]: out of roots %d\n",
ROOTS);
exit(1);
}
return free;
}
/** Set a root node to a pointer (in the heap).
*
* /param hp a heap
* /param n a root slot
* /param r a pointer to a structure
*/
void heap_root_set(heap_t* hp, hi_int n, hi_int* r) {
TRACE;
ASSERT(n < ROOTS);
hp->root[n] = r;
}
/** Get a root node to a pointer (in the heap).
*
* /param hp a heap
* /param n a root slot
* /return a pointer to a structure
*/
hi_int* heap_root_get(heap_t* hp, hi_int n) {
TRACE;
ASSERT(n < ROOTS);
return hp->root[n];
}
/** Allocate a node in the heap of given size.
*
* Nodes may, but should not assumed, to be blanked.
* Nodes may, but should not be assumed, to have an initialized
* header field.
*
* /param hp a heap
* /param sz the size requested
* /return a pointer to a new node
*/
hi_int* heap_allocate(heap_t* hp, hi_int sz) {
TRACE;
hi_int* p = hp->free;
hp->free = ADVANCE(hp->free, sz);
DEBUG(p[0] = sz;)
DEBUG(int i;)
DEBUG(for (i = 1; i < sz; i++) p[i] = 0;)
return p;
}
/** Copy nodes from one heap to another heap.
*
* All nodes refered to by root nodes in the from heap are
* copied to the to heap.
*
* Unsafe, the caller should make sure the to space holds
* enough room.
*
* /param from the source heap
* /param to the destination heap
* /retrun the destination heap
*/
heap_t* heap_copy(heap_t* from, heap_t* to) {
TRACE;
hi_int* copy_low;
hi_int* copy_high;
hi_int i,j;
hi_int* p0;
hi_int* p1;
copy_low = to->free;
copy_high = to->free;
// copy the roots to the to-space
for (i = 0; i < from->root_free; i++) {
p0 = from->root[i];
if (IN_HEAP(p0, from->low, from->high)) {
p1 = (hi_int*) p0[0];
if (IN_HEAP(p1, to->low, to->high)) {
to->root[to->root_free + i] = p1;
} else {
for (j = 0; j < p0[0]; j++) {
copy_high[j] = p0[j];
}
p0[0] = (hi_int) copy_high;
to->root[to->root_free + i] = copy_high;
copy_high = ADVANCE(copy_high, copy_high[0]);
}
}
}
to->root_free += from->root_free;
// copy all references to the to-space
while (copy_low != copy_high) {
if (copy_low[1] != 0) {
for (i = 2; i < copy_low[0]; i++) {
p0 = (hi_int*) copy_low[i];
if (IN_HEAP(p0, from->low, from->high)) {
p1 = (hi_int*) p0[0];
if (IN_HEAP(p1, to->low, to->high)) {
copy_low[i] = (hi_int) p1;
} else {
for (j = 0; j < p0[0]; j++) copy_high[j] = p0[j];
copy_low[i] = (hi_int) copy_high;
p0[0] = (hi_int) copy_high;
copy_high= ADVANCE(copy_high, copy_high[0]);
}
}
}
}
copy_low = ADVANCE(copy_low, copy_low[0]);
}
to->free = copy_low;
return to;
}
/** Resize a given heap to a given size by a copy.
*
* /param hp a heap
* /param sz the requested size
* /return a copy of the heap of given size
*/
heap_t* heap_resize(heap_t* hp, hi_int sz) {
TRACE;
heap_t* to;
to = heap_create(sz);
to = heap_copy(hp, to);
heap_destroy(hp);
return to;
}
/** Collect (copy) a heap.
*
* /param hp a heap
* /return a garbage collected copy of the heap
*/
heap_t* heap_collect(heap_t* r) {
TRACE;
heap_t* s;
s = r;
s = heap_resize(s, s->size);
if (BELOW(s->trigger_grow, s->free)) {
s = heap_resize(s, s->size + s->size);
}
return s;
}
/** Collect (copy) a heap if it runs out of space.
*
* /param hp a heap
* /return a collected heap, or the original
*/
heap_t* heap_try_collect(heap_t* r) {
TRACE;
heap_t* s;
s = r;
if (BELOW(s->trigger_gc, s->free)) {
fprintf(stdout, "HEAP!\n"); // XXX
s = heap_collect(s);
}
return s;
}
/** Reserve space in a heap.
*
* /param hp a heap
* /param sz the requested size
* /return a heap with at least sz free bytes
*/
heap_t* heap_reserve(heap_t* r, hi_int sz) {
TRACE;
heap_t* s;
s = r;
if ((void*)heap_free(s) <= (void*)sz) {
s = heap_collect(s);
}
while ((void*)heap_free(s) <= (void*)sz) {
s = heap_resize(s, s->size + s->size);
}
return s;
}
/** Copy everything reachable (also outside the heap) to another
* heap.
*
* Note: Doesn't handle cyclic structures.
*
* /param from a source heap
* /param to a destination heap
* /return the destination heap
*/
heap_t* heap_copy_deep(heap_t* from, heap_t* to) {
TRACE;
hi_int* copy_low;
hi_int* copy_high;
hi_int i,j;
hi_int* p0;
hi_int* p1;
copy_low = to->low;
copy_high = to->low;
ASSERT(from->root_free == 1);
to->root_free = from->root_free;
// copy the root to the to-space
p0 = from->root[0];
for (j = 0; j < p0[0]; j++) {
copy_high[j] = p0[j];
}
to->root[0] = copy_high;
copy_high = ADVANCE(copy_high, copy_high[0]);
// copy all references to the to-space
while (copy_low != copy_high) {
if (copy_low[1] != 0) {
for (i = 2; i < copy_low[0]; i++) {
p0 = (hi_int*) copy_low[i];
if (!IS_SMALL_INTEGER(p0)) {
for (j = 0; j < p0[0]; j++) copy_high[j] = p0[j];
copy_low[i] = (hi_int) copy_high;
copy_high= ADVANCE(copy_high, copy_high[0]);
}
}
}
copy_low = ADVANCE(copy_low, copy_low[0]);
}
to->free = copy_low;
return to;
}
/** Serialize a heap to memory.
*
* /param hp a heap
* /param p a piece of memory
* /param sz the size of the memory in bytes
* /return the number of bytes used
*/
hi_int heap_serialize(heap_t* t, void* p, hi_int sz) {
TRACE;
// coerce p to a heap
heap_t* r = (heap_t*) p;
r->size = sz;
r->low = (hi_int*) &(r->memory);
r->high = INCREMENT(r, sz);
r->free = r->low;
r->root_free = 0;
r->trigger_gc = DECREMENT(r->high, HEAP_MINIMAL_FREE);
r->trigger_grow = DECREMENT(r->high, HEAP_MINIMAL_GROW);
// copy the first root to p
hi_int tmp;
tmp = t->root_free;
t->root_free = 1;
heap_copy_deep(t, r);
t->root_free = tmp;
// return the size of the copied region
return (hi_int) (DIFFERENCE(r->free, r));
}
/** Unserialize memory to a heap.
*
* /param hp a heap
* /param p a piece of memory
* /param sz the size of the memory in bytes
* /return the root of the structure copied
*/
hi_int* heap_unserialize(heap_t* t, void* p, hi_int sz) {
TRACE;
hi_int i;
heap_t* r = (heap_t*) p;
// get the pointer offset...
hi_int offset = DIFFERENCE((&(r->memory)), r->root[0]);
// alligning code
r->low = INCREMENT(r->low, offset);
r->high = INCREMENT(r->high, offset);
r->free = INCREMENT(r->free, offset);
for (i = 0; i < ROOTS; i++) {
r->root[i] = INCREMENT(r->root[i], offset);
}
hi_int* low = r->low;
hi_int* high = r->free;
while (low != high) {
if (low[1] != 0) {
for (i = 2; i < low[0]; i++) {
if (!IS_SMALL_INTEGER(low[i])) {
low[i] = (hi_int)
INCREMENT((hi_int*)low[i], offset);
}
}
}
low = ADVANCE(low, low[0]);
}
// copying code
heap_copy(r, t);
t->root_free--;
return t->root[t->root_free];
}
/** The size, total number of integers/pointers, of a heap.
*
* /param hp a heap
* /return the size of the heap
*/
hi_int heap_size(heap_t* hp) {
return (hi_int)
(((void*) hp->high - (void*) hp->low)/sizeof(hi_int));
}
/** The free space, total number of unallocated integers/pointers, of a heap.
*
* /param hp a heap
* /return the size of the free space of the heap
*/
hi_int heap_free(heap_t* hp) {
return (hi_int)
(((void*) hp->high - (void*) hp->free)/sizeof(hi_int));
}
/** The used space, total number of allocated integers/pointers, of a heap.
*
* /param hp a heap
* /return the size of the used space of the heap
*/
hi_int heap_used(heap_t* hp) {
return (hi_int)
(((void*) hp->free - (void*) hp->low)/sizeof(hi_int));
}
/** Print some information to a file pointer.
*
* /param f a file pointer
* /param hp a heap
*/
void heap_info(FILE* f, heap_t* hp) {
fprintf(f, "**********************************************************************\n");
fprintf(f, "GARBAGE COLLECTION INFORMATION\n");
fprintf(f, "0-heap size : %ld\n", hp->size);
fprintf(f, "0-heap low : %p\n", hp->low);
fprintf(f, "0-heap high : %p\n", hp->high);
fprintf(f, "0-heap free : %p\n", hp->free);
fprintf(f, "0-heap roots : %d\n", hp->root_free);
fprintf(f, "0-heap gc trigger : %p\n", hp->trigger_gc);
fprintf(f, "0-heap grow trigger : %p\n\n", hp->trigger_grow);
fprintf(f, "1-heap size : %ld\n", heap_size(hp));
fprintf(f, "1-heap used : %ld\n", heap_used(hp));
fprintf(f, "1-heap free : %ld\n\n", heap_free(hp));
fprintf(f, "2-heap minimal free : %d\n", HEAP_MINIMAL_FREE);
fprintf(f, "2-heap grow : %d\n\n", HEAP_MINIMAL_GROW);
fprintf(f, "**********************************************************************\n");
}
// just for debugging purposes, loops on cyclic structures
void heap_print_node(FILE* f, hi_int* n) {
unsigned int i;
fprintf(f, "------------------------------------\n");
fprintf(f, "node[%p].size : %d\n", (void*) n, (unsigned int) n[0]);
fprintf(f, "node[%p].tag : %d\n", (void*) n, (unsigned int) n[1]);
if (n[1] == 0) {
for (i = 2; i < n[0]; i++) {
fprintf(f, "node[%p].[%d] : %d\n", (void*) n, i, (unsigned int) n[i]);
}
} else {
for (i = 2; i < n[0]; i++) {
fprintf(f, "node[%p].[%d] : %p\n", (void*) n, i, (void*) n[i]);
}
for (i = 2; i < n[0]; i++) {
heap_print_node(f, (hi_int*) n[i]);
}
}
}
// just for debugging purposes
void heap_debug(FILE* f, heap_t* hp) {
hi_int i;
heap_info(f, hp);
for (i = 0; i < hp->root_free; i++) {
fprintf(f, "ROOT %d:\n", i);
heap_print_node(f, hp->root[i]);
fprintf(f, "**********************************************************************\n");
}
}
//////////////////////////////////////////////////////////////////////
// wasn't sure where to put this code, doesn't really fit here too.
hi_int* heap_int(heap_t* hp, int v) {
int sz = 3 + HI_SIZE(int);
hi_int* n = (hi_int*) heap_allocate(hp, sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = int_tag;
n[3] = 0;
int* p = (int*) &(n[3]);
*p = v;
return n;
}
hi_int* heap_char(heap_t* hp, hi_char v) {
int sz = 3 + HI_SIZE(int);
hi_int* n = (hi_int*) heap_allocate(hp, sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = char_tag;
n[3] = 0;
char* p = (char*) &(n[3]);
*p = v;
return n;
}
hi_int* heap_float(heap_t* hp, hi_float v) {
int sz = 3 + HI_SIZE(hi_float);
hi_int* n = (hi_int*) heap_allocate(hp, sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = float_tag;
hi_float* p = (hi_float*) &(n[3]);
*p = v;
return n;
}
hi_int* heap_double(heap_t* hp, hi_double v) {
int sz = 3 + HI_SIZE(hi_double);
hi_int* n = (hi_int*) heap_allocate(hp, sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = double_tag;
hi_double* p = (hi_double*) &(n[3]);
*p = v;
return n;
}
hi_int* heap_ldouble(heap_t* hp, hi_ldouble v) {
int sz = 3 + HI_SIZE(hi_ldouble);
hi_int* n = (hi_int*) heap_allocate(hp, sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = ldouble_tag;
hi_ldouble* p = (hi_ldouble*) &(n[3]);
*p = v;
return n;
}
hi_int* heap_pointer(heap_t* hp, hi_pointer v) {
int sz = 3 + HI_SIZE(hi_pointer);
hi_int* n = (hi_int*) heap_allocate(hp, sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = pointer_tag;
hi_pointer* p = (hi_pointer*) &(n[3]);
*p = v;
return n;
}
hi_int* heap_string(heap_t* hp, char* v) {
int v_len = strnlen(v, 2048);
//v[v_len] = (char) 0;
int sz = 3 + (v_len + sizeof(hi_int))/sizeof(hi_int);
hi_int* n = (hi_int*) heap_allocate(hp, sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = string_tag;
char* p = (char*) &(n[3]);
strcpy(p, v);
return n;
}
hi_int* heap_uint8(heap_t* hp, hi_uint8 v) {
int sz = 3 + HI_SIZE(hi_uint8);
hi_int* n = (hi_int*) heap_allocate(hp, sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = uint8_tag;
hi_uint8* p = (hi_uint8*) &(n[3]);
*p = v;
return n;
}
hi_int* heap_sint8(heap_t* hp, hi_sint8 v) {
int sz = 3 + HI_SIZE(hi_sint8);
hi_int* n = (hi_int*) heap_allocate(hp, sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = sint8_tag;
hi_sint8* p = (hi_sint8*) &(n[3]);
*p = v;
return n;
}
hi_int* heap_uint16(heap_t* hp, hi_uint16 v) {
int sz = 3 + HI_SIZE(hi_uint16);
hi_int* n = (hi_int*) heap_allocate(hp, sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = uint16_tag;
hi_uint16* p = (hi_uint16*) &(n[3]);
*p = v;
return n;
}
hi_int* heap_sint16(heap_t* hp, hi_sint16 v) {
int sz = 3 + HI_SIZE(hi_sint16);
hi_int* n = (hi_int*) heap_allocate(hp, sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = sint16_tag;
hi_sint16* p = (hi_sint16*) &(n[3]);
*p = v;
return n;
}
hi_int* heap_uint32(heap_t* hp, hi_uint32 v) {
int sz = 3 + HI_SIZE(hi_uint32);
hi_int* n = (hi_int*) heap_allocate(hp, sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = uint32_tag;
hi_uint32* p = (hi_uint32*) &(n[3]);
*p = v;
return n;
}
hi_int* heap_sint32(heap_t* hp, hi_sint32 v) {
int sz = 3 + HI_SIZE(hi_sint32);
hi_int* n = (hi_int*) heap_allocate(hp, sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = sint32_tag;
hi_sint32* p = (hi_sint32*) &(n[3]);
*p = v;
return n;
}
hi_int* heap_uint64(heap_t* hp, hi_uint64 v) {
int sz = 3 + HI_SIZE(hi_uint64);
hi_int* n = (hi_int*) heap_allocate(hp, sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = uint64_tag;
hi_uint64* p = (hi_uint64*) &(n[3]);
*p = v;
return n;
}
hi_int* heap_sint64(heap_t* hp, hi_sint64 v) {
int sz = 3 + HI_SIZE(hi_sint64);
hi_int* n = (hi_int*) heap_allocate(hp, sz * sizeof(hi_int));
n[0] = sz;
n[1] = 0;
n[2] = sint64_tag;
hi_sint64* p = (hi_sint64*) &(n[3]);
*p = v;
return n;
}
//** end of file: heap/heap.c
//** start of file: fast/fast.h
/** Runtime for the Hi Language (stage2).
*
* COPYRIGHT 2008, M.C.A. Devillers
*
* THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY
* EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK.
*
* A fast allocator for intermediates.
*
* Typical usage is coercing a part of stack allocated space to
* a fast region.
*/
#ifndef FAST_H
#define FAST_H
#ifndef ONE_LARGE_FILE
#include "../types/types.h"
#endif
typedef struct {
hi_uint8* low;
hi_uint8* free;
hi_uint8* high;
hi_uint8* memory;
} fast_t;
#define fast_size(f) \
((void*) f->high - (void*) f->low)
#define fast_used(f) \
((void*) f->free - (void*) f->low)
#define fast_free(f) \
((void*) f->high - (void*) f->free)
fast_t* fast_create(size_t sz);
void fast_destroy(fast_t* f);
fast_t* fast_coerce(void* p, int sz);
void fast_reset(fast_t* f);
hi_uint8* fast_alloc(fast_t* f, size_t sz);
hi_uint8* fast_alloc_alligned(fast_t* f, size_t sz);
void fast_debug(FILE* fp, fast_t* f);
#endif // FAST_H
//** end of file: fast/fast.h
//** start of file: fast/fast.c
#include <stdlib.h>
#include <stdio.h>
#include <stdarg.h>
#include <stdint.h>
#include <string.h>
#ifndef ONE_LARGE_FILE
#include "../assert/assert.h"
#include "fast.h"
#endif
#define BITS_SET(b0,b1) ((b0) | (b1))
#define BITS_UNSET(b0,b1) ((b0) & (~(b1)))
#define BITS_TEST(b0,b1) (((b0) & (b1)) != 0)
#define BITS_FLIP(b0,b1) ((b0) (b1))
#define BIT_SET(n,b) BITS_SET(n, 1<<b)
#define BIT_UNSET(n,b) BITS_UNSET(n, 1<<b)
#define BIT_TEST(n,b) BITS_TEST(n, 1<<b)
#define BIT_FLIP(n,b) BITS_FLIP(n, 1<<b)
/** Create a memory region for fast allocation of a given size.
*
* Note, there is more memory allocated than only needed for the
* fast region.
*
* /param n the requested size
* /return the allocated heap, exits if unsuccessfull.
*/
fast_t* fast_create(size_t sz) {
TRACE;
fast_t* f = (fast_t*) malloc(sz);
if (f == 0) {
fprintf(stderr,
"FAST_PANIC[0]: failed to allocate a fast region of size %u\n",
(unsigned int) sz);
exit(1);
}
f->low = (hi_uint8*) &(f->memory);
f->free = f->low;
f->high = ((hi_uint8*) f)+sz;
return f;
}
/** Destroy the fast memory region.
*
* /param n the requested size
*/
void fast_destroy(fast_t* f) {
TRACE;
free(f);
}
/** Coerce memory to a fast region.
*
* /param p a pointer to memory
* /param n the size of that memory
* /return a fast region
*/
fast_t* fast_coerce(void* p, int sz) {
TRACE;
fast_t* f = (fast_t*) p;
f->low = (hi_uint8*) &(f->memory);
f->free = f->low;
f->high = ((hi_uint8*) f)+sz;
return f;
}
/** Print the fast memory region.
*
* /param f the fast region
*/
void fast_print(fast_t* f) {
hi_uint8 *p;
for (p = f->low; p < f->high; p++) {
fprintf(stdout, "fast[%ld] [%p]: ", p - f->low, p);
fprintf(stdout, "%u\n", (unsigned int) p[0]);
}
}
/** Reset the fast memory region (put the free ptr to the low).
*
* /param f the fast region
*/
void fast_reset(fast_t* f) {
f->free = f->low;
}
/** Allocate memory in the fast region.
*
* /param f the fast region
* /param sz the requested size
* /return the memory allocated, exits if unsuccessfull.
*/
hi_uint8* fast_alloc(fast_t* f, size_t sz) {
TRACE;
hi_uint8* tmp = f->free;
f->free += sz;
return tmp;
}
/** Allocate pointer alligned memory in the fast region.
*
* /param f the fast region
* /param sz the requested size
* /return the memory allocated, exits if unsuccessfull.
*/
hi_uint8* fast_alloc_alligned(fast_t* f, size_t sz) {
TRACE;
const int pointer_size = sizeof(void*);
f->free = (hi_uint8*) BITS_UNSET(
((unsigned long) f->free)+pointer_size-1,
((unsigned long) pointer_size)-1);
return fast_alloc(f, sz);
}
/** Print debugging information about the fast region.
*
* /param fp the file pointer printed to
* /param f the fast region
*/
void fast_debug(FILE* fp, fast_t* f) {
fprintf(fp, "**********************************************************************\n");
fprintf(fp, "FAST REGION INFORMATION\n");
fprintf(fp, "0-fast low : %p\n", f->low);
fprintf(fp, "0-fast free : %p\n", f->free);
fprintf(fp, "0-fast high : %p\n", f->high);
fprintf(fp, "0-fast size : %ld\n", (void*) f->high - (void*) f->low);
fprintf(fp, "**********************************************************************\n");
}
//** end of file: fast/fast.c
//** start of file: dynamic/dynamic.h
#ifndef DYNAMIC_H
#define DYNAMIC_H
#ifndef ONE_LARGE_FILE
#include "../types/types.h"
#endif
// type dl.dl = [ dl.dl string string pointer ]
void* dynamic_symbol (hi_int* dl);
#endif // DYNAMIC_H
//** end of file: dynamic/dynamic.h
//** start of file: dynamic/dynamic.c
#include <stdlib.h>
#include <stdio.h>
#include <stdarg.h>
#include <stdint.h>
#include <string.h>
#include <dlfcn.h>
#ifndef ONE_LARGE_FILE
#include "dynamic.h"
#include "../assert/assert.h"
#endif
#define SYMBOL_LENGTH 128
void* sym_posix (char* libname, char* symname) {
void* handle;
void* fptr;
char libnameso[256] = "lib\0";
strncat(libnameso, libname, SYMBOL_LENGTH);
strncat(libnameso, ".so", SYMBOL_LENGTH);
int mode = RTLD_LAZY;
handle = dlopen (libnameso, mode);
if (handle == NULL)
{
fprintf (stderr, "%s: dynamic failure: `%s'\n", libname, dlerror ());
exit (1);
};
fptr = dlsym (handle, symname);
if (fptr == NULL) {
fprintf (stderr, "%s: dlsym: `%s'\n", symname, dlerror ());
exit (1);
};
DEBUG(fprintf(stderr, "dlsym[%s, %s] = %p\n", libname, symname, fptr));
return fptr;
}
void* dynamic_symbol(hi_int* n) {
void* fptr;
if (n[1] != 1) return (void*) n[1];
DEBUG(hi_int* tt = get_type_tag(n));
DEBUG(ASSERT( strncmp(convert_from_record_tag(tt), "dl.dl", 64) == 0 ));
DEBUG(hi_int* tr = get_type_tag(n));
DEBUG(ASSERT( strncmp(convert_from_record_tag(tr), "dl.dl", 64) == 0 ));
hi_int* lib_tag = (hi_int*) n[4];
hi_int* sym_tag = (hi_int*) n[5];
char* lib = convert_to_string(lib_tag);
char* sym = convert_to_string(sym_tag);
fptr = sym_posix(lib, sym);
// n[1] = (hi_int) fptr;
return fptr;
}
//** end of file: dynamic/dynamic.c
//** start of file: ffi/hffi.h
/**
* COPYRIGHT 2010, M.C.A. Devillers
*
* THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY
* EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK.
*
* Calling dynamic C libraries by using libffi.
*
* On the Hi size, a combinator is set up which gets an FFI
* descriptor and a number of arguments.
*
* The FFI descriptor describes a symbol in a dynamic library
* and its C type. The symbol is resolved first.
*
* The FFI part is a bit of a patch work. The Hi descriptor is
* translated to a CIF of libffi, which is then used as the sole
* reference for translating values from Hi towards C values, and the
* inverse.
*
* The only relevant exported function is ffi_call, which takes a
* thunk, resolves the symbol, makes the call, and places the
* result in the heap.
*/
#ifndef HI_FFI_H
#define HI_FFI_H
#include <stdlib.h>
#include <stdio.h>
#include <stdarg.h>
#include <stdint.h>
#include <string.h>
#include "ffi.h"
#ifndef ONE_LARGE_FILE
#include "../types/types.h"
#include "../heap/heap.h"
#include "../fast/fast.h"
#endif
ffi_type* ffi_type_hi_to_ffi(fast_t* f, hi_int *n);
void* ffi_value_hi_to_ffi(fast_t* f, ffi_type* ft, hi_int *n);
hi_int* ffi_value_ffi_to_hi(heap_t* hp, ffi_type* ft, void* val);
hi_int* ffi_hi_call(heap_t* hp, hi_int* dl, hi_int* ffi, hi_int argc, hi_int* argv);
void ffi_type_print(FILE* f, ffi_type* tm_type);
size_t ffi_type_size(ffi_type* ft);
#endif // HI_FFI_H
//** end of file: ffi/hffi.h
//** start of file: ffi/hffi.c
/**
* COPYRIGHT 2010, M.C.A. Devillers
*
* THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY
* EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK.
*/
#include <stdlib.h>
#include <stdio.h>
#include <stdarg.h>
#include <stdint.h>
#include <string.h>
#include <dlfcn.h>
#include "hffi.h"
#ifndef ONE_LARGE_FILE
#include "../assert/assert.h"
#include "../dynamic/dynamic.h"
#endif
// type ffi =
// [ void | char | short | int | long | float | double | pointer |
// struct1 ffi | struct2 ffi ffi | struct3 ffi ffi ffi | .. ]
/** Build an ffi_type in the fast region from a C type.
*
* /param f the fast region
* /param n an ffi descriptor
* /return the ffi_type reconstructed from the value
*/
ffi_type* ffi_type_hi_to_ffi(fast_t* f, hi_int *n) {
DEBUG(fprintf(stderr, "converting from: "));
DEBUG(print_hi(stderr, n));
DEBUG(fprintf(stderr, "\n"));
DEBUG(ASSERT(n[1] == 1));
DEBUG(hi_int* tt = get_type_tag(n));
DEBUG(ASSERT(strncmp(convert_from_record_tag(tt), "ffi.ffi", 64) == 0));
hi_int* rt = get_record_tag(n);
char* s = convert_from_record_tag(rt);
if (strncmp(s, "ffi.void", 64) == 0) {
return &ffi_type_void;
} else if (strncmp(s, "ffi.pointer", 64) == 0) {
return &ffi_type_pointer;
} else if (strncmp(s, "ffi.char", 64) == 0) {
return &ffi_type_uchar;
} else if (strncmp(s, "ffi.int", 64) == 0) {
return &ffi_type_sint;
} else if (strncmp(s, "ffi.short", 64) == 0) {
return &ffi_type_sshort;
} else if (strncmp(s, "ffi.long", 64) == 0) {
return &ffi_type_slong;
} else if (strncmp(s, "ffi.float", 64) == 0) {
return &ffi_type_float;
} else if (strncmp(s, "ffi.double", 64) == 0) {
return &ffi_type_double;
} else if (strncmp(s, "ffi.struct", 64) == 0) {
hi_int sz = n[0];
hi_int c = sz - 4;
ffi_type* ft = (ffi_type*)
fast_alloc_alligned(f, sizeof(ffi_type));
ffi_type** ft_elements = (ffi_type**)
fast_alloc_alligned(f, (sz+1) * sizeof(ffi_type*));
ft->type = FFI_TYPE_STRUCT;
ft->size = 0;
ft->alignment = 0;
ft->elements = ft_elements;
int i;
for (i = 0; i < c; i++) {
hi_int* t = (hi_int*) n[4+i];
ft_elements[i] = ffi_type_hi_to_ffi(f, t);
}
ft_elements[c] = NULL;
return ft;
}
}
/** Construct the ffi values in the fast region of a native value.
*
* /param f the fast region
* /param ft an ffi_type description
* /param n the const/record/thunk being converted
* /return a pointer to the ffi value
*/
void* ffi_value_hi_to_ffi(fast_t* f, ffi_type* ft, hi_int *n) {
if (ft->type == FFI_TYPE_VOID) {
return (void*) 0;
} else if (ft->type == FFI_TYPE_POINTER) {
return (void*) get_pointer(n);
} else if (ft->type == FFI_TYPE_UINT64) {
return (void*) get_uint64(n);
} else if (ft->type == FFI_TYPE_SINT64) {
return (void*) get_sint64(n);
} else if (ft->type == FFI_TYPE_UINT32) {
return (void*) get_uint32(n);
} else if (ft->type == FFI_TYPE_SINT32) {
return (void*) get_sint32(n);
} else if (ft->type == FFI_TYPE_UINT16) {
return (void*) get_uint16(n);
} else if (ft->type == FFI_TYPE_SINT16) {
return (void*) get_sint16(n);
} else if (ft->type == FFI_TYPE_UINT8) {
return (void*) get_uint8(n);
} else if (ft->type == FFI_TYPE_SINT8) {
return (void*) get_sint8(n);
} else if (ft->type == FFI_TYPE_FLOAT) {
return (void*) get_float(n);
} else if (ft->type == FFI_TYPE_DOUBLE) {
return (void*) get_double(n);
} else if (ft->type == FFI_TYPE_STRUCT) {
// UNTESTED
size_t sz = ffi_type_size(ft);
void* p = fast_alloc_alligned(f, sz);
char* q = (char*) p;
int i = 0;
for (i = 0; ft->elements[i] != 0; i++) {
sz = ffi_type_size(ft->elements[i]);
char* r = (char*)
ffi_value_hi_to_ffi(f, ft->elements[i],
(hi_int*) n[4+i]);
int j;
for (j = 0; j < sz; j++) {
q[0] = r[0];
q++;r++;
}
}
return p;
} else {
fprintf(stderr, "FFI_PANIC[4]: cannot create ffi value.\n");
exit(1);
return 0;
}
}
/** Copy the ffi values to the heap.
*
* /param hp the heap
* /param ft an ffi_type description
* /param val the value
* /return the corresponding value in the heap
*/
hi_int* ffi_value_ffi_to_hi(heap_t* hp, ffi_type* ft, void* p) {
if (ft->type == FFI_TYPE_VOID) {
return 0;
} else if (ft->type == FFI_TYPE_POINTER) {
return heap_pointer(hp, *((hi_pointer*) p));
} else if (ft->type == FFI_TYPE_UINT64) {
return heap_int(hp, *((hi_uint64*) p));
} else if (ft->type == FFI_TYPE_SINT64) {
return heap_int(hp, *((hi_sint64*) p));
} else if (ft->type == FFI_TYPE_UINT32) {
return heap_int(hp, *((hi_uint32*) p));
} else if (ft->type == FFI_TYPE_SINT32) {
return heap_int(hp, *((hi_sint32*) p));
} else if (ft->type == FFI_TYPE_UINT16) {
return heap_int(hp, *((hi_uint16*) p));
} else if (ft->type == FFI_TYPE_SINT16) {
return heap_int(hp, *((hi_sint16*) p));
} else if (ft->type == FFI_TYPE_UINT8) {
return heap_char(hp, *((hi_uint8*) p));
} else if (ft->type == FFI_TYPE_SINT8) {
return heap_char(hp, *((hi_sint8*) p));
} else if (ft->type == FFI_TYPE_FLOAT) {
return heap_float(hp, *((hi_float*) p));
} else if (ft->type == FFI_TYPE_DOUBLE) {
return heap_double(hp, *((hi_double*) p));
#ifdef FFI_TYPE_LONGDOUBLE
} else if (ft->type == FFI_TYPE_LONGDOUBLE) {
return heap_ldouble(hp, *((hi_ldouble*) p));
#endif
} else {
fprintf(stderr, "FFI_PANIC[4]: cannot create return value.\n");
exit(1);
return 0;
}
}
/** Make a call through the ffi interface.
*
* Note: could/should store ffi information in the embedding thunk in
* the future.
*
* The caller is responsible for making sure that enough arguments
* are present.
*
* /param hp the heap
* /param dl the dl record
* /param ffi the ffi record
* /param argc the number of arguments
* /param argv the arguments
*/
hi_int* ffi_hi_call(heap_t* hp, hi_int* dl, hi_int* ffi, hi_int argc, hi_int* argv) {
// set up the fast scratch region
hi_uint8 fmem[512];
fast_t* f = fast_coerce((void*) fmem, 512);
void* fn = dynamic_symbol(dl);
print_hi(stderr, ffi);
hi_int ffi_record_argc = (hi_int) ffi[0] - 5;
hi_int* ffi_record_argv = (hi_int*) &(ffi[5]);
hi_int* ffi_record_return = (hi_int*) (ffi[4]);
fprintf(stderr, "0: ");
print_hi(stderr, (hi_int*) ffi_record_argv[0]);
fprintf(stderr, "1: ");
print_hi(stderr, (hi_int*) ffi_record_argv[1]);
fprintf(stderr, "-1: ");
print_hi(stderr, (hi_int*) ffi_record_argv[-1]);
fprintf(stderr, "ret: ");
print_hi(stderr, ffi_record_return);
if (ffi_record_argc == 0) {
fprintf(stderr,
"FFI_PANIC[5]: not implemented yet\n");
exit(1);
}
ASSERT(argc == ffi_record_argc);
if (argc == 0) goto ffi_constant;
// build the cif NOTE:one extra arg, ends with 0!
ffi_cif cif;
ffi_type** ffi_type_args = (ffi_type**)
fast_alloc(f, (ffi_record_argc+1) * sizeof(ffi_type*));
int i;
for (i = 0; i < ffi_record_argc; i++) {
ffi_type_args[i] = ffi_type_hi_to_ffi(f, (hi_int*) ffi_record_argv[i]);
}
ffi_type_args[i] = 0;
ffi_type* ret = ffi_type_hi_to_ffi(f, ffi_record_return);
// prepare the values
void** arg_values = (void**)
fast_alloc(f, (ffi_record_argc+1) * sizeof(void*));
for (i = 0; i < ffi_record_argc; i++) {
arg_values[i] =
ffi_value_hi_to_ffi(f, ffi_type_args[i],
(hi_int*) argv[i]);
}
arg_values[i] = 0;
// void hack: FFI doesnt allow void as type/arg. XXX should be fixed
if (ffi_type_args[0]->type == FFI_TYPE_VOID) {
ffi_record_argc--;
ffi_type_args[0] = 0;
arg_values[0] = 0;
}
// prepare the cif
if (ffi_prep_cif(&cif, FFI_DEFAULT_ABI,
ffi_record_argc, ret, ffi_type_args) != FFI_OK) {
fprintf(stderr,
"FFI_PANIC[6]: could not create a call interface\n");
exit(1);
}
void* ret_value = fast_alloc_alligned(f, 128);
ffi_call(&cif, fn, ret_value, arg_values);
// return the conversion
hi_int* hi_ret = ffi_value_ffi_to_hi(hp, ret, ret_value);
return hi_ret;
ffi_constant:
// XXX: NO IDEA IF THIS WORKS :~/
ret = ffi_type_hi_to_ffi(f, ffi_record_return);
hi_ret = ffi_value_ffi_to_hi(hp, ret, fn);
return hi_ret;
}
/** Retrieve the size of an ffi_type.
*
* /param ft an ffi_type description
* /return the size of a corresponding value
*/
size_t ffi_type_size(ffi_type* ft) {
if (ft->type == FFI_TYPE_STRUCT) {
// XXX: all fields are alligned on their sizes
size_t size = 0;
ffi_type** ft_elements = ft->elements;
int i;
while (ft_elements[i] != 0) {
size += ffi_type_size(ft_elements[i]);
i++;
}
return size;
} else {
return ft->size;
}
}
typedef struct {
int ffi_type;
char* name;
} ffi_print_conversion;
/** Print an ffi_type to a file. Exit on failure.
*
* /param f a file pointer.
* /param tm_type an ffi_type
*/
void ffi_type_print(FILE* f, ffi_type* tm_type) {
static ffi_print_conversion ffi_print_table[16] =
{
{FFI_TYPE_VOID, "void"},
{FFI_TYPE_INT, "int"},
{FFI_TYPE_FLOAT, "float"},
{FFI_TYPE_DOUBLE, "double"},
{FFI_TYPE_LONGDOUBLE, "longdouble"},
{FFI_TYPE_UINT8, "uint8"} ,
{FFI_TYPE_SINT8, "sint8"},
{FFI_TYPE_UINT16, "uint16"},
{FFI_TYPE_SINT16, "sint16"},
{FFI_TYPE_UINT32, "uint32"},
{FFI_TYPE_SINT32, "sint32"},
{FFI_TYPE_UINT64, "uint64"},
{FFI_TYPE_SINT64, "sint64"},
{FFI_TYPE_POINTER, "pointer"},
{FFI_TYPE_STRUCT, "struct"},
{-1,0}
};
int i = 0;
int ct = tm_type->type;
for (i = 0; ffi_print_table[i].ffi_type != -1; i++) {
if (ffi_print_table[i].ffi_type == ct) {
fprintf(f, "%s", ffi_print_table[i].name);
if (ct == FFI_TYPE_STRUCT) {
fprintf(f, "{");
ffi_type** tm_type_elements = tm_type->elements;
int j;
for (j = 0; tm_type_elements[j] != 0; j++) {
ffi_type_print(f, tm_type_elements[j]);
fprintf(f, " ");
}
fprintf(f, "}");
}
return;
}
}
fprintf(stderr, "FFI_PANIC[0]: garbled ffi type.\n");
exit(1);
}
//** end of file: ffi/hffi.c
No comments:
Post a Comment