memory.llm

;**********************************************************************
; memory.llm
;
; Memory-handling routines.
;
; Copyright 2009-2010 by Dustin Laurence.  Distributed under the terms of
; the LGPLv3.
;
;**********************************************************************

#include "nil.llh"
#include "memory.llh"
#include "exp.llh"

;**********************************************************************
; Private declarations
;
;**********************************************************************

    ; If we want to expose this to the rest of the world, it should
    ; have a wrapper that starts the recursive function at the head of
    ; the list so we aren't exposing that implementation-dependent
    ; argument on the world
    declare NILCC %c_char* @FindStringR(%Exp %list, 
                                        %c_char* %searchString)

;**********************************************************************
; Aligned
;
; Checks to see that the given pointer is aligned on the boundary we
; require to hold the tag field (currently 8 bytes, which GNU malloc()
; seems to enforce).
;
; Actually the same as TagClear, but takes a void pointer.
;
;**********************************************************************

define NILCC i1
@Aligned(i8* %ptr)
{
    ; A sufficiently aligned pointer is one whose tag field is zero.
    %exp = ptrtoint i8* %ptr to %Exp
    %isZero = call NILCC i1 @TagIsClear(%Exp %exp)

    ret i1 %isZero
}

;**********************************************************************
; NewMemory
;
; Returns a newly allocated chunk of raw memory guaranteed not to be null
; and properly aligned.
;
;**********************************************************************

define NILCC i8*
@NewMemory(%c_size_t %size)
{
    %newMem = call ccc i8* @malloc(%c_size_t %size)
    #ifndef NDEBUG
    ; Check that we have memory
    %gotMem = icmp ne i8* %newMem, null
    assert(%gotMem)
    ; Check that it is aligned
    %aligned = call NILCC i1 @Aligned(i8* %newMem)
    assert(%aligned)
    #endif

    ret i8* %newMem
}

;**********************************************************************
; String uniqueifying
;
; A simple little module that ensures that every string *value* is
; stored in a single unique location, vital for Lisp to work with any
; kind of efficiency at all (among other things, this means we can
; test for symbol equality with a simple pointer compare everywhere
; but here).
;
; I suppose an industrial-strength implementation would use trees or
; hash tables, but a simple linked list is more than sufficient for
; now.
;
; Note that as far as this module is concerned "" is a perfectly valid
; symbol. :-)
;
;**********************************************************************

    ; Implemented with a Lisp list from Exp
    @pStringList = internal global %Exp NIL_VALUE

;**********************************************************************
; Strings
;
; Return all defined (unique) strings.
;
;**********************************************************************

define NILCC %Exp
@Strings()
{
    %stringList = load %Exp* @pStringList
    ret %Exp %stringList
}

;**********************************************************************
; UniqueString
;
; Returns a pointer to a unique string with the same contents as the
; given string, allocating if necessary.  Note that the caller can't
; free() the string as we maintain an internal pointer to it.  That's
; what garbage collection is for.
;
;**********************************************************************

; Message for monitoring the interpreter behavior

#undef DEBUG_NEW

#ifdef DEBUG_NEW
#define NEW_LEN 4
@newArray = internal constant [NEW_LEN x %c_char] c"(+)\00"
#endif


define NILCC %c_char*
@UniqueString(%c_char* %string)
{
    ; Is there already such a string in the list?
    %existingString = call NILCC %c_char* @FindString(%c_char* %string)

    #ifndef NDEBUG
    ; For paranoia's sake, in debugging mode we'll do the same search
    ; all over again with the recursive implementation and assert that
    ; precisely the same pointer is obtained.
    %listHead = load %Exp* @pStringList
    %alternateString = call NILCC %c_char* @FindStringR(%Exp %listHead,
                                                        %c_char* %string)
    %equal = icmp eq %c_char* %existingString, %alternateString
    assert(%equal)
    #endif

    %exists = icmp ne %c_char* %existingString, null
    br i1 %exists, label %ReturnOldString, label %GetNewString

ReturnOldString:
    ; If so, return it.
    ret %c_char* %existingString

GetNewString:
#ifdef DEBUG_NEW
%newStr = getelementptr [NEW_LEN x %c_char]* @newArray, i64 0, i64 0
call ccc %c_int @putstring(%c_char* %newStr)
#endif
    ; If not, allocate a new string with that value...
    %newString = call ccc %c_char* @strdup(%c_char* %string)
    #ifndef NDEBUG
    ; Did we get it?
    %gotString = icmp ne %c_char* %newString, null
    assert(%gotString)
    ; Check alignment.  Cons will actually do this again with str2Exp,
    ; but it seems better to have it here as nothing *forces* all calls
    ; to NewCell() to go through Cons().
    ; This assumes c_char == i8.  Bite me.
    %aligned = call NILCC i1 @Aligned(%c_char* %newString)
    assert(%aligned)
    #endif

    ; ...add it to the list...
    call NILCC void @PushString(%c_char* %newString)

    ; ...and return it.
    ret %c_char* %newString
}

;**********************************************************************
; PushString
;
; Adds the given string to the head of the list without checking to
; see if it is already present.
;
;**********************************************************************

define NILCC void
@PushString(%c_char* %string)
{
    %car = call NILCC %Exp @str2Exp(%c_char* %string)

    %cdr = load %Exp* @pStringList

    %newHead = call NILCC %Exp @Cons(%Exp %car, %Exp %cdr)

    ; Make it the new head
    store %Exp %newHead, %Exp* @pStringList

    ret void
}

;**********************************************************************
; FindString
;
; Returns a pointer to the unique string in the list with the same
; contents as the given string, if it exists.  Otherwise, return null.
;
; Written in imperative style--this is LLVM, not lisp.  However, it
; might be educational to see it in recursive style, and LLVM claims
; to be able to optimize tail calls.
;
;**********************************************************************

define NILCC %c_char*
@FindString(%c_char* %searchString)
{
        ; Paranoia--disallow calls with null (empty strings are fine)
        #ifndef NDEBUG
        %haveInput = icmp ne %c_char* %searchString, null
        assert(%haveInput)
        #endif

    ; Local variable
    %pThisCell = alloca %Exp

    ; pThisCell = &ListHead
    %listHead = load %Exp* @pStringList
    store %Exp %listHead, %Exp* %pThisCell
    br label %Loop

Loop:
    ; while (thisCell != nil)
    %thisCell = load %Exp* %pThisCell
    %notNil = call NILCC i1 @NotNil(%Exp %thisCell)
    br i1 %notNil, label %BeginLoop, label %EndLoop

    BeginLoop:
        ; if ( car(thisCell) == searchString)
        ; FIXME: should use the LLVM 2.6 inbounds keyword
        %car = call NILCC %Exp @Car(%Exp %thisCell)

        ; Do the compare--note that we *can't* do this with anything like
        ; eq, because we already need uniqueness to make the
        ; pointer compare in eq work
        %thisString = call NILCC %c_char* @Exp2str(%Exp %car)
        %cmp = call ccc %c_int @strcmp(%c_char* %thisString,
                                       %c_char* %searchString)
        %equal = icmp eq %c_int %cmp, 0
        br i1 %equal, label %BeginIf, label %EndIf

        BeginIf:

            ; return this string
            ret %c_char* %thisString

        EndIf:
        ; thisCell = cdr(thisCell)
        %cdr = call NILCC %Exp @Cdr(%Exp %thisCell)
        store %Exp %cdr, %Exp* %pThisCell
        br label %Loop

EndLoop:
    ; We didn't find it, return null
    ret %c_char* null
}

;**********************************************************************
; FindStringR
;
; Precisely the same semantics as FindString, but written in recursive
; style for comparison purposes.  We've helped LLVM compile it to an
; iterative process by explicitly specifying a tail call.
;
;**********************************************************************

define NILCC %c_char*
@FindStringR(%Exp %list, %c_char* %searchString)
{
        ; Paranoia--disallow calls with null (empty strings are fine)
        #ifndef NDEBUG
        %haveInput = icmp ne %c_char* %searchString, null
        assert(%haveInput)
        #endif

    %notNil = call NILCC i1 @NotNil(%Exp %list)
    br i1 %notNil, label %NotNil, label %IsNil

IsNil:
    ; We didn't find it, return null
    ret %c_char* null

NotNil:
    ; if ( car(list) == searchString)
    ; FIXME: should use the LLVM 2.6 inbounds keyword
    %car = call NILCC %Exp @Car(%Exp %list)

    ; Do the compare--note that we *can't* do this with anything like
    ; eq, because this is the direct string compare that makes the
    ; pointer compare in eq work
    %thisString = call NILCC %c_char* @Exp2str(%Exp %car)
    %cmp = call ccc %c_int @strcmp(%c_char* %thisString,
                                   %c_char* %searchString)
    %equal = icmp eq %c_int %cmp, 0
    br i1 %equal, label %StringsEqual, label %StringsNotEqual

StringsEqual:

    ; return this string
    ret %c_char* %thisString

StringsNotEqual:
    ; FindString( cdr(list) )
    %cdr = call NILCC %Exp @Cdr(%Exp %list)
    %answer = tail call NILCC %c_char* @FindStringR(%Exp %cdr,
                                                    %c_char* %searchString)
    ret %c_char* %answer
}