3
\$\begingroup\$

I found a post I made here an year ago (Compiler for a minimal LISP dialect to run on the Java Virtual Machine) and got interested on this subject again. This time I decided to implement the instruction level myself instead of relying on the Java virtual machine like last time. An obstacle is that since I'm implementing the instruction level, if I decide to port a Lisp variant to this VM, I should also handle the compilation from the high level Lisp constructs to the low level instructions. As this is a fairly complicated task, it is not yet done.

The functions ending with _ correspond to the instructions that the VM should handle. The main function is there to show how a certain Lisp construct would be compiled down to a sequence of instructions.

The garbage collector is a simple copying collector. There are two heaps, and when the current heap in use is full, the referenced objects are copied to the other heap, and so on.

And it seems the original garbage collector was broken. I edited with the hopefully working patch.

#include <stdio.h>
#include <stdlib.h>
#include <stdbool.h>
#include <inttypes.h>

#define WORD uint32_t
#define WORD_FORMAT PRIu32
#define STACK_SIZE 0x100000
#define HEAP_SIZE 0x1000000
#define NIL ((WORD)0)
#define LIN ((WORD)-1)

enum {INTEGER_TYPE, BOOLEAN_TYPE, CHARACTER_TYPE, LIST_TYPE};

static WORD stack[STACK_SIZE];
static WORD *stackPointer = stack;
static WORD heap[2][HEAP_SIZE];
static int heapIndex;
static WORD *heapPointer = *heap + 1;

static void check(bool isOK, const char *message) {
    if (!isOK) {
        fprintf(stderr, "error: %s\n", message);
        exit(EXIT_FAILURE);
    }
}

static void push_(WORD type, WORD value) {
    check(stackPointer <= stack + STACK_SIZE - 2, "stack overflow");
    *stackPointer++ = type;
    *stackPointer++ = value;
}

static void pop_(void) {
    stackPointer -= 2;
}

static void nil_(void) {
    push_(LIST_TYPE, NIL);
}

static WORD allocate(WORD type, WORD head, WORD tail) {
    if (heapPointer > heap[heapIndex] + HEAP_SIZE - 3) {
        heapPointer = heap[!heapIndex] + 1;
        for (WORD *p = stack; p < stackPointer; p += 2) {
            if (*p == LIST_TYPE) {
                WORD *p2 = p + 1;
                while (*p2) {
                    if (heap[heapIndex][*p2 + 2] == LIN) {
                        break;
                    }
                    check(heapPointer <= heap[!heapIndex] + HEAP_SIZE - 3, "heap overflow");
                    *heapPointer++ = heap[heapIndex][*p2];
                    *heapPointer++ = heap[heapIndex][*p2 + 1];
                    *heapPointer++ = heap[heapIndex][*p2 + 2];
                    heap[heapIndex][*p2 + 2] = LIN;
                    *p2 = heapPointer - heap[!heapIndex] - 3;
                    p2 = heapPointer - 1;
                }
            }
        }
        heapIndex = !heapIndex;
    }
    *heapPointer++ = type;
    *heapPointer++ = head;
    *heapPointer++ = tail;
    return heapPointer - heap[heapIndex] - 3;
}

/* This one is broken.
static WORD allocate(WORD type, WORD head, WORD tail) {
    if (heapPointer > heap[heapIndex] + HEAP_SIZE - 3) {
        heapPointer = heap[!heapIndex] + 1;
        for (WORD *p = stack; p < stackPointer; p += 2) {
            if (*p == LIST_TYPE) {
                WORD list = p[1];
                while (list) {
                    if (heap[heapIndex][list + 2] == LIN) {
                        break;
                    }
                    check(heapPointer <= heap[!heapIndex] + HEAP_SIZE - 3, "heap overflow");
                    *heapPointer++ = heap[heapIndex][list];
                    *heapPointer++ = heap[heapIndex][list + 1];
                    list = *heapPointer++ = heap[heapIndex][list + 2];
                    heap[heapIndex][list + 2] = LIN;
                }
            }
        }
        heapIndex = !heapIndex;
    }
    *heapPointer++ = type;
    *heapPointer++ = head;
    *heapPointer++ = tail;
    return heapPointer - heap[heapIndex] - 3;
}
*/

static void link_(void) {
    WORD list = allocate(stackPointer[-2], stackPointer[-1], stackPointer[-3]);
    pop_();
    pop_();
    push_(LIST_TYPE, list);
}

static void print(WORD type, WORD value) {
    switch (type) {
    case INTEGER_TYPE:
        printf("%" WORD_FORMAT, value);
        break;
    case BOOLEAN_TYPE:
        if (!value) {
            fputs("false", stdout);
        } else {
            fputs("true", stdout);
        }
        break;
    case CHARACTER_TYPE:
        putchar(value);
        break;
    default:
        putchar('(');
        while (value) {
            print(heap[heapIndex][value], heap[heapIndex][value + 1]);
            if (value = heap[heapIndex][value + 2]) {
                putchar(' ');
            }
        }
        putchar(')');
    }
}

static void print_(void) {
    print(stackPointer[-2], stackPointer[-1]);
    pop_();
}

int main(void) {
    // print (1 (1 (2)) ((true) false))
    nil_();
    nil_();
    push_(BOOLEAN_TYPE, false);
    link_();
    nil_();
    push_(BOOLEAN_TYPE, true);
    link_();
    link_();
    link_();
    nil_();
    nil_();
    push_(INTEGER_TYPE, 2);
    link_();
    link_();
    push_(INTEGER_TYPE, 1);
    link_();
    link_();
    push_(INTEGER_TYPE, 1);
    link_();
    print_();
    push_(CHARACTER_TYPE, '\n');
    print_();
}
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.