377 lines
9.0 KiB
C
377 lines
9.0 KiB
C
|
|
|
|
#include "ikarus.h"
|
|
#include <stdio.h>
|
|
#include <stdlib.h>
|
|
#include <sys/types.h>
|
|
#include <sys/stat.h>
|
|
#include <fcntl.h>
|
|
#include <string.h>
|
|
#include <errno.h>
|
|
#include <unistd.h>
|
|
#include <assert.h>
|
|
#include <sys/mman.h>
|
|
#include <dlfcn.h>
|
|
|
|
|
|
typedef struct {
|
|
char* memp;
|
|
char* memq;
|
|
ikp* marks;
|
|
int marks_size;
|
|
} fasl_port;
|
|
|
|
static ikp ik_fasl_read(ikpcb* pcb, fasl_port* p);
|
|
|
|
void ik_fasl_load(ikpcb* pcb, char* fasl_file){
|
|
int fd = open(fasl_file, O_RDONLY);
|
|
if(fd == -1){
|
|
fprintf(stderr, "failed to open %s: %s\n", fasl_file, strerror(errno));
|
|
exit(-1);
|
|
}
|
|
|
|
int filesize;
|
|
{
|
|
struct stat buf;
|
|
int err = fstat(fd, &buf);
|
|
if(err != 0){
|
|
fprintf(stderr, "failed to stat %s: %s\n", fasl_file, strerror(errno));
|
|
exit(-1);
|
|
}
|
|
filesize = buf.st_size;
|
|
}
|
|
int mapsize = ((filesize + pagesize - 1) / pagesize) * pagesize;
|
|
|
|
char* mem = mmap(
|
|
0,
|
|
mapsize,
|
|
PROT_READ,
|
|
MAP_PRIVATE,
|
|
fd,
|
|
0);
|
|
|
|
if(mem == MAP_FAILED){
|
|
fprintf(stderr, "Mapping failed for %s: %s\n", fasl_file, strerror(errno));
|
|
exit(-1);
|
|
}
|
|
|
|
fasl_port p;
|
|
p.memp = mem;
|
|
p.memq = mem + filesize;
|
|
p.marks = NULL;
|
|
p.marks_size = 0;
|
|
|
|
|
|
while(p.memp < p.memq){
|
|
ikp v = ik_fasl_read(pcb, &p);
|
|
if(p.marks){
|
|
bzero(p.marks, p.marks_size);
|
|
}
|
|
ikp val = ik_exec_code(pcb, v);
|
|
if(val != void_object){
|
|
ik_print(val);
|
|
}
|
|
}
|
|
|
|
if(p.memp != p.memq){
|
|
fprintf(stderr, "fasl-read did not reach eof!\n");
|
|
exit(-10);
|
|
}
|
|
if(p.marks){
|
|
ik_munmap(p.marks, pagesize);
|
|
}
|
|
{
|
|
int err = munmap(mem, mapsize);
|
|
if(err != 0){
|
|
fprintf(stderr, "Failed to unmap fasl file: %s\n", strerror(errno));
|
|
exit(-1);
|
|
}
|
|
}
|
|
close(fd);
|
|
}
|
|
|
|
|
|
static void
|
|
ik_link_dl(ikdl* x, ikdl* target){
|
|
ikdl* next = target->next;
|
|
x->next = next;
|
|
x->prev = target;
|
|
target->next = x;
|
|
next->prev = x;
|
|
}
|
|
|
|
static ikp
|
|
ik_allocate_code(int size, ikpcb* pcb){
|
|
int memreq = align_to_next_page(size + sizeof(ikcode_preheader));
|
|
ikp mem = ik_mmap(memreq);
|
|
ikcodes* p = ik_malloc(sizeof(ikcodes));
|
|
p->code_object = mem + sizeof(ikcode_preheader);
|
|
p->attr = ikcode_live;
|
|
p->base = mem;
|
|
p->size = memreq;
|
|
ik_link_dl(&(p->dl), &pcb->codes);
|
|
ref(mem, 0) = (ikp) p;
|
|
return mem + sizeof(ikcode_preheader);
|
|
}
|
|
|
|
static ikp
|
|
ik_make_code(int code_size, int reloc_size, ikp closure_size, ikpcb* pcb){
|
|
int required_memory =
|
|
align(code_size + reloc_size + disp_code_data);
|
|
|
|
ikp mem = ik_allocate_code(required_memory, pcb);
|
|
REF(mem, 0) = IK_CODE_SEC_TAG;
|
|
REF(mem, IK_DISP_CODE_CODE_SIZE) = (ikp) code_size;
|
|
REF(mem, IK_DISP_CODE_RELOC_SIZE) = (ikp) reloc_size;
|
|
REF(mem, IK_DISP_CODE_CLOSURE_SIZE) = closure_size;
|
|
return (ikp)(mem+IK_CODE_PRI_TAG);
|
|
}
|
|
|
|
static char fasl_read_byte(fasl_port* p){
|
|
if(p->memp < p->memq){
|
|
char c = *(p->memp);
|
|
p->memp++;
|
|
return c;
|
|
} else {
|
|
fprintf(stderr, "fasl_read_byte: read beyond eof\n");
|
|
exit(-1);
|
|
}
|
|
}
|
|
|
|
static void fasl_read_buf(fasl_port* p, void* buf, int n){
|
|
if((p->memp+n) <= p->memq){
|
|
memcpy(buf, p->memp, n);
|
|
p->memp += n;
|
|
} else {
|
|
fprintf(stderr, "fasl_read_buf: read beyond eof\n");
|
|
exit(-1);
|
|
}
|
|
}
|
|
|
|
static void
|
|
ik_set_car(ikp x, ikp v){
|
|
REF(x, IK_OFF_CAR) = v;
|
|
}
|
|
|
|
static void
|
|
ik_set_cdr(ikp x, ikp v){
|
|
REF(x, IK_OFF_CDR) = v;
|
|
}
|
|
|
|
|
|
|
|
typedef struct{
|
|
int code_size;
|
|
int reloc_size;
|
|
ikp closure_size;
|
|
} code_header;
|
|
|
|
#define wordsize 4
|
|
|
|
static ikp do_read(ikpcb* pcb, fasl_port* p){
|
|
char c = fasl_read_byte(p);
|
|
int put_mark_index = 0;
|
|
if(c == '>'){
|
|
int idx = 0;
|
|
fasl_read_buf(p, &idx, sizeof(int));
|
|
put_mark_index = idx;
|
|
c = fasl_read_byte(p);
|
|
if(idx <= 0){
|
|
fprintf(stderr, "fasl_read: invalid index %d\n", idx);
|
|
exit(-1);
|
|
}
|
|
if(idx >= 1024){
|
|
fprintf(stderr, "BUG: mark too big: %d\n", idx);
|
|
exit(-1);
|
|
}
|
|
if(idx < p->marks_size){
|
|
if(p->marks[idx] != 0){
|
|
fprintf(stderr, "mark %d already set\n", idx);
|
|
exit(-1);
|
|
}
|
|
}
|
|
else {
|
|
/* allocate marks */
|
|
if(p->marks){
|
|
fprintf(stderr, "BUG: extension to marks not implemented\n");
|
|
exit(-1);
|
|
}
|
|
else {
|
|
p->marks = ik_mmap(pagesize);
|
|
bzero(p->marks, pagesize);
|
|
p->marks_size = 1024;
|
|
}
|
|
}
|
|
}
|
|
if(c == 'X'){
|
|
code_header ch;
|
|
fasl_read_buf(p, &ch, sizeof(ch));
|
|
ikp code = ik_make_code(ch.code_size, ch.reloc_size, ch.closure_size, pcb);
|
|
if(put_mark_index){
|
|
p->marks[put_mark_index] = code;
|
|
}
|
|
ikp code_data = code + IK_OFF_CODE_DATA;
|
|
fasl_read_buf(p, code_data, ch.code_size);
|
|
ikp reloc_table = code_data + ch.code_size;
|
|
int i = 0;
|
|
while(i < ch.reloc_size){
|
|
char t = fasl_read_byte(p);
|
|
if(t == 'O'){
|
|
int offset;
|
|
fasl_read_buf(p, &offset, sizeof(int));
|
|
ikp object = do_read(pcb, p);
|
|
REF(code_data,offset) = object;
|
|
REF(reloc_table, i) = (ikp)(offset << 2);
|
|
i += wordsize;
|
|
}
|
|
else if(t == 'F'){ /* foreign call */
|
|
int offset;
|
|
fasl_read_buf(p, &offset, sizeof(int));
|
|
ikp str = do_read(pcb, p);
|
|
char* name = string_data(str);
|
|
void* sym = dlsym(NULL, name);
|
|
char* err = dlerror();
|
|
if(err){
|
|
fprintf(stderr, "failed to find foreign name %s: %s\n", name, err);
|
|
exit(-1);
|
|
}
|
|
ref(code_data,offset) = sym;
|
|
ref(reloc_table, i) = (ikp)((offset << 2) | 3);
|
|
ref(reloc_table, i+wordsize) = str;
|
|
i += 2*wordsize;
|
|
}
|
|
else if(t == 'D'){ /* displaced reloc */
|
|
int code_offset;
|
|
int object_offset;
|
|
fasl_read_buf(p, &code_offset, sizeof(int));
|
|
fasl_read_buf(p, &object_offset, sizeof(int));
|
|
ikp object = do_read(pcb, p);
|
|
REF(reloc_table, i) = (ikp)((code_offset << 2) | 1);
|
|
REF(reloc_table, i+wordsize) = (ikp)object_offset;
|
|
REF(code_data, code_offset) = object + object_offset;
|
|
i += (2*wordsize);
|
|
}
|
|
else if(t == 'J'){ /* jump reloc */
|
|
int code_offset;
|
|
int object_offset;
|
|
fasl_read_buf(p, &code_offset, sizeof(int));
|
|
fasl_read_buf(p, &object_offset, sizeof(int));
|
|
ikp object = do_read(pcb, p);
|
|
REF(reloc_table, i) = (ikp)((code_offset << 2) | 2);
|
|
REF(reloc_table, i+wordsize) = (ikp)object_offset;
|
|
ikp next_word = code_data + code_offset + wordsize;
|
|
ikp displaced_object = object + object_offset;
|
|
REF(next_word, -wordsize) = displaced_object - (int) next_word;
|
|
i += (2*wordsize);
|
|
}
|
|
else {
|
|
fprintf(stderr, "invalid reloc type '%c'\n", t);
|
|
exit(-1);
|
|
}
|
|
}
|
|
assert(i==ch.reloc_size);
|
|
return code;
|
|
}
|
|
else if(c == 'P'){
|
|
ikp pair = ik_alloc(pcb, pair_size) + pair_tag;
|
|
if(put_mark_index){
|
|
p->marks[put_mark_index] = pair;
|
|
}
|
|
ik_set_car(pair, do_read(pcb, p));
|
|
ik_set_cdr(pair, do_read(pcb, p));
|
|
return pair;
|
|
}
|
|
else if(c == 'M'){
|
|
/* symbol */
|
|
ikp str = do_read(pcb, p);
|
|
ikp sym = ik_intern_string(str, pcb);
|
|
if(put_mark_index){
|
|
p->marks[put_mark_index] = sym;
|
|
}
|
|
return sym;
|
|
}
|
|
else if(c == 'S'){
|
|
/* string */
|
|
int len;
|
|
fasl_read_buf(p, &len, sizeof(int));
|
|
int size = align(len + disp_string_data + 1);
|
|
ikp str = ik_alloc(pcb, size) + string_tag;
|
|
ref(str, off_string_length) = fix(len);
|
|
fasl_read_buf(p, str+off_string_data, len);
|
|
str[off_string_data+len] = 0;
|
|
if(put_mark_index){
|
|
p->marks[put_mark_index] = str;
|
|
}
|
|
return str;
|
|
}
|
|
else if(c == 'V'){
|
|
int len;
|
|
fasl_read_buf(p, &len, sizeof(int));
|
|
int size = align(len * wordsize + disp_vector_data);
|
|
ikp vec = ik_alloc(pcb, size) + vector_tag;
|
|
if(put_mark_index){
|
|
p->marks[put_mark_index] = vec;
|
|
}
|
|
ref(vec, off_vector_length) = fix(len);
|
|
int i;
|
|
for(i=0; i<len; i++){
|
|
ref(vec, off_vector_data + i*wordsize) = do_read(pcb, p);
|
|
}
|
|
return vec;
|
|
}
|
|
else if(c == 'I'){
|
|
ikp fixn;
|
|
fasl_read_buf(p, &fixn, sizeof(int));
|
|
return fixn;
|
|
}
|
|
else if(c == 'F'){
|
|
return false_object;
|
|
}
|
|
else if(c == 'T'){
|
|
return true_object;
|
|
}
|
|
else if(c == 'N'){
|
|
return IK_NULL_OBJECT;
|
|
}
|
|
else if(c == 'C'){
|
|
char x = fasl_read_byte(p);
|
|
return byte_to_scheme_char(x);
|
|
}
|
|
else if(c == '<'){
|
|
int idx;
|
|
fasl_read_buf(p, &idx, sizeof(int));
|
|
if(idx <= 0){
|
|
fprintf(stderr, "invalid index for ref %d\n", idx);
|
|
exit(-1);
|
|
}
|
|
if(idx >= p->marks_size){
|
|
fprintf(stderr, "invalid index for ref %d\n", idx);
|
|
exit(-1);
|
|
}
|
|
ikp obj = p->marks[idx];
|
|
if(obj){
|
|
return obj;
|
|
} else {
|
|
fprintf(stderr, "reference to uninitialized mark %d\n", idx);
|
|
exit(-1);
|
|
}
|
|
}
|
|
else {
|
|
fprintf(stderr, "invalid type '%c' found in fasl file\n", c);
|
|
exit(-1);
|
|
}
|
|
}
|
|
|
|
|
|
static ikp ik_fasl_read(ikpcb* pcb, fasl_port* p){
|
|
/* first check the header */
|
|
char buf[IK_FASL_HEADER_LEN];
|
|
fasl_read_buf(p, buf, IK_FASL_HEADER_LEN);
|
|
if(strncmp(buf, IK_FASL_HEADER, IK_FASL_HEADER_LEN) != 0){
|
|
fprintf(stderr, "invalid fasl header\n");
|
|
exit(-1);
|
|
}
|
|
return do_read(pcb, p);
|
|
}
|
|
|