idris-lang/Idris2
1
1
Fork 0
mirror of https://github.com/idris-lang/Idris2.git synced 2024-11-13 05:48:39 +03:00
Code Issues Projects Releases Wiki Activity

Initial merge of reference counting C back end

Browse Source 
Written by Volkmar Frinken (@vfrinken). This is intended as a
lightweight (i.e. minimal dependencies) code generator that can be
ported to multiple platforms, especially those with memory constraints.

It shouldn't be expected to be anywhere near as fast as the Scheme back
end, for lots of reasons. The main goal is portability.
This commit is contained in:
Edwin Brady 2020-10-11 15:05:00 +01:00
parent ef730c7eb1
commit a76a1322eb
25 changed files with 3545 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Makefile
View File

@ -87,9 +87,11 @@ test:
support:
@${MAKE} -C support/c
@${MAKE} -C support/refc
support-clean:
@${MAKE} -C support/c clean
@${MAKE} -C support/refc clean
clean-libs:
${MAKE} -C libs/prelude clean
@ -129,6 +131,7 @@ install-support:
install support/gambit/* ${PREFIX}/idris2-${IDRIS2_VERSION}/support/gambit
install support/js/* ${PREFIX}/idris2-${IDRIS2_VERSION}/support/js
@${MAKE} -C support/c install
@${MAKE} -C support/refc install
install-libs:
${MAKE} -C libs/prelude install IDRIS2=../../${TARGET} IDRIS2_PATH=${IDRIS2_BOOT_PATH}

2
Release/mkdist.sh
View File

@ -17,7 +17,7 @@ git checkout tags/v$1
rm -rf .git
rm -rf .github
rm .git*
rm .travis*
rm -f .travis*
rm -rf Release
find . -type f -name '.gitignore' -exec rm -f {} \;

2
idris2api.ipkg
View File

@ -21,6 +21,8 @@ modules =
Compiler.ES.RemoveUnused,
Compiler.ES.TailRec,
Compiler.RefC.RefC,
Compiler.Scheme.Chez,
Compiler.Scheme.Racket,
Compiler.Scheme.Gambit,

1110
src/Compiler/RefC/RefC.idr Normal file
View File

File diff suppressed because it is too large Load Diff

4
src/Core/Options.idr
View File

@ -53,6 +53,7 @@ data CG = Chez
| Gambit
| Node
| Javascript
| RefC
| Other String
export
@ -62,6 +63,7 @@ Eq CG where
Gambit == Gambit = True
Node == Node = True
Javascript == Javascript = True
RefC == RefC = True
Other s == Other t = s == t
_ == _ = False
@ -72,6 +74,7 @@ Show CG where
show Gambit = "gambit"
show Node = "node"
show Javascript = "javascript"
show RefC = "refc"
show (Other s) = s
public export
@ -161,6 +164,7 @@ availableCGs o
("racket", Racket),
("node", Node),
("javascript", Javascript),
("refc", RefC),
("gambit", Gambit)] ++ additionalCGs o
export

2
src/Core/TTC.idr
View File

@ -748,6 +748,7 @@ TTC CG where
toBuf b (Other s) = do tag 4; toBuf b s
toBuf b Node = tag 5
toBuf b Javascript = tag 6
toBuf b RefC = tag 7
fromBuf b
= case !getTag of
@ -758,6 +759,7 @@ TTC CG where
pure (Other s)
5 => pure Node
6 => pure Javascript
7 => pure RefC
_ => corrupt "CG"
export

2
src/Idris/REPL.idr
View File

@ -6,6 +6,7 @@ import Compiler.Scheme.Gambit
import Compiler.ES.Node
import Compiler.ES.Javascript
import Compiler.Common
import Compiler.RefC.RefC
import Core.AutoSearch
import Core.CaseTree
@ -189,6 +190,7 @@ findCG
Gambit => pure codegenGambit
Node => pure codegenNode
Javascript => pure codegenJavascript
RefC => pure codegenRefC
Other s => case !(getCodegen s) of
Just cg => pure cg
Nothing => do coreLift $ putStrLn ("No such code generator: " ++ s)

2
support/c/Makefile
View File

@ -52,4 +52,4 @@ cleandep: clean
install: build
mkdir -p ${PREFIX}/idris2-${IDRIS2_VERSION}/lib
install $(LIBTARGET) $(DYLIBTARGET) ${PREFIX}/idris2-${IDRIS2_VERSION}/lib
install $(LIBTARGET) $(DYLIBTARGET) *.h ${PREFIX}/idris2-${IDRIS2_VERSION}/lib

50
support/refc/Makefile Normal file
View File

@ -0,0 +1,50 @@
include ../../config.mk
TARGET = libidris2_refc
LIBTARGET = $(TARGET).a
CFLAGS += -O2
SRCS = $(wildcard *.c)
ifeq ($(OS), windows)
SRCS += windows/win_utils.c windows/win_hack.c
LDFLAGS += -lws2_32
ifeq ($(OLD_WIN), 1)
CFLAGS += -D_OLD_WIN
endif
endif
OBJS = $(SRCS:.c=.o)
DEPS = $(OBJS:.o=.d)
all: build
.PHONY: build
build: $(LIBTARGET)
$(LIBTARGET): $(OBJS)
$(AR) rc $@ $^
$(RANLIB) $@
-include $(DEPS)
%.d: %.c
@$(CPP) $(CFLAGS) $< -MM -MT $(@:.d=.o) >$@
.PHONY: clean
clean:
$(RM) $(OBJS) $(LIBTARGET)
cleandep: clean
$(RM) $(DEPS)
.PHONY: install
install: build
mkdir -p ${PREFIX}/idris2-${IDRIS2_VERSION}/refc
install $(LIBTARGET) *.h ${PREFIX}/idris2-${IDRIS2_VERSION}/refc

17
support/refc/cBackend.h Normal file
View File

@ -0,0 +1,17 @@
#ifndef __C_BACKEND_H__
#define __C_BACKEND_H__
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <pthread.h>
#include "datatypes.h"
#include "memoryManagement.h"
#include "mathFunctions.h"
#include "runtime.h"
#include "stringOps.h"
#include "casts.h"
#include "conCaseHelper.h"
#include "prim.h"
#endif

644
support/refc/casts.c Normal file
View File

@ -0,0 +1,644 @@
#include "casts.h"
#include <inttypes.h>
Value *cast_i32_to_Bits8(Value *input)
{
Value_Int8 *retVal = (Value_Int8 *)newValue();
retVal->header.tag = INT8_TAG;
Value_Int32 *from = (Value_Int32 *)input;
retVal->i8 = (int8_t)from->i32;
return (Value *)retVal;
}
Value *cast_i32_to_Bits16(Value *input)
{
Value_Int16 *retVal = (Value_Int16 *)newValue();
retVal->header.tag = INT16_TAG;
Value_Int32 *from = (Value_Int32 *)input;
retVal->i16 = (int16_t)from->i32;
return (Value *)retVal;
}
Value *cast_i32_to_Bits32(Value *input)
{
return input;
}
Value *cast_i32_to_Bits64(Value *input)
{
return cast_i32_to_i64(input);
}
Value *cast_i32_to_i64(Value *input)
{
Value_Int64 *retVal = (Value_Int64 *)newValue();
retVal->header.tag = INT64_TAG;
Value_Int32 *from = (Value_Int32 *)input;
retVal->i64 = (int64_t)from->i32;
return (Value *)retVal;
}
Value *cast_i32_to_double(Value *input)
{
Value_Double *retVal = (Value_Double *)newValue();
retVal->header.tag = DOUBLE_TAG;
Value_Int32 *from = (Value_Int32 *)input;
retVal->d = (double)from->i32;
return (Value *)retVal;
}
Value *cast_i32_to_char(Value *input)
{
Value_Char *retVal = (Value_Char *)newValue();
retVal->header.tag = CHAR_TAG;
Value_Int32 *from = (Value_Int32 *)input;
retVal->c = (char)from->i32;
return (Value *)retVal;
}
Value *cast_i32_to_string(Value *input)
{
Value_String *retVal = (Value_String *)newValue();
retVal->header.tag = STRING_TAG;
Value_Int32 *from = (Value_Int32 *)input;
int l = snprintf(NULL, 0, "%i", from->i32);
retVal->str = malloc((l + 1) * sizeof(char));
memset(retVal->str, 0, l + 1);
sprintf(retVal->str, "%i", from->i32);
return (Value *)retVal;
}
Value *cast_i64_to_Bits8(Value *input)
{
Value_Int8 *retVal = (Value_Int8 *)newValue();
retVal->header.tag = INT8_TAG;
Value_Int64 *from = (Value_Int64 *)input;
retVal->i8 = (int8_t)from->i64;
return (Value *)retVal;
}
Value *cast_i64_to_Bits16(Value *input)
{
Value_Int16 *retVal = (Value_Int16 *)newValue();
retVal->header.tag = INT16_TAG;
Value_Int64 *from = (Value_Int64 *)input;
retVal->i16 = (int16_t)from->i64;
return (Value *)retVal;
}
Value *cast_i64_to_Bits32(Value *input)
{
return cast_i64_to_i32(input);
}
Value *cast_i64_to_Bits64(Value *input)
{
return input;
}
Value *cast_i64_to_i32(Value *input)
{
Value_Int32 *retVal = (Value_Int32 *)newValue();
retVal->header.tag = INT32_TAG;
Value_Int64 *from = (Value_Int64 *)input;
retVal->i32 = (int32_t)from->i64;
return (Value *)retVal;
}
Value *cast_i64_to_double(Value *input)
{
Value_Double *retVal = (Value_Double *)newValue();
retVal->header.tag = DOUBLE_TAG;
Value_Int64 *from = (Value_Int64 *)input;
retVal->d = (double)from->i64;
return (Value *)retVal;
}
Value *cast_i64_to_char(Value *input)
{
Value_Char *retVal = (Value_Char *)newValue();
retVal->header.tag = CHAR_TAG;
Value_Int64 *from = (Value_Int64 *)input;
retVal->c = (char)from->i64;
return (Value *)retVal;
}
Value *cast_i64_to_string(Value *input)
{
Value_String *retVal = (Value_String *)newValue();
retVal->header.tag = STRING_TAG;
Value_Int64 *from = (Value_Int64 *)input;
int l = snprintf(NULL, 0, "%" PRIu64 "", from->i64);
retVal->str = malloc((l + 1) * sizeof(char));
memset(retVal->str, 0, l + 1);
sprintf(retVal->str, "%" PRIu64 "", from->i64);
return (Value *)retVal;
}
Value *cast_double_to_Bits8(Value *input)
{
Value_Int8 *retVal = (Value_Int8 *)newValue();
retVal->header.tag = INT8_TAG;
Value_Double *from = (Value_Double *)input;
retVal->i8 = (int8_t)from->d;
return (Value *)retVal;
}
Value *cast_double_to_Bits16(Value *input)
{
Value_Int16 *retVal = (Value_Int16 *)newValue();
retVal->header.tag = INT16_TAG;
Value_Double *from = (Value_Double *)input;
retVal->i16 = (int16_t)from->d;
return (Value *)retVal;
}
Value *cast_double_to_Bits32(Value *input)
{
return cast_double_to_i32(input);
}
Value *cast_double_to_Bits64(Value *input)
{
return cast_double_to_i64(input);
}
Value *cast_double_to_i32(Value *input)
{
Value_Int32 *retVal = (Value_Int32 *)newValue();
retVal->header.tag = INT32_TAG;
Value_Double *from = (Value_Double *)input;
retVal->i32 = (int32_t)from->d;
return (Value *)retVal;
}
Value *cast_double_to_i64(Value *input)
{
Value_Int64 *retVal = (Value_Int64 *)newValue();
retVal->header.tag = INT64_TAG;
Value_Double *from = (Value_Double *)input;
retVal->i64 = (int64_t)from->d;
return (Value *)retVal;
}
Value *cast_double_to_char(Value *input)
{
Value_Char *retVal = (Value_Char *)newValue();
retVal->header.tag = CHAR_TAG;
Value_Double *from = (Value_Double *)input;
retVal->c = (char)from->d;
return (Value *)retVal;
}
Value *cast_double_to_string(Value *input)
{
Value_String *retVal = (Value_String *)newValue();
retVal->header.tag = STRING_TAG;
Value_Double *from = (Value_Double *)input;
int l = snprintf(NULL, 0, "%f", from->d);
retVal->str = malloc((l + 1) * sizeof(char));
memset(retVal->str, 0, l + 1);
sprintf(retVal->str, "%f", from->d);
return (Value *)retVal;
}
Value *cast_char_to_Bits8(Value *input)
{
Value_Int8 *retVal = (Value_Int8 *)newValue();
retVal->header.tag = INT8_TAG;
Value_Char *from = (Value_Char *)input;
retVal->i8 = (int8_t)from->c;
return (Value *)retVal;
}
Value *cast_char_to_Bits16(Value *input)
{
Value_Int16 *retVal = (Value_Int16 *)newValue();
retVal->header.tag = INT16_TAG;
Value_Char *from = (Value_Char *)input;
retVal->i16 = (int16_t)from->c;
return (Value *)retVal;
}
Value *cast_char_to_Bits32(Value *input)
{
return cast_char_to_i32(input);
}
Value *cast_char_to_Bits64(Value *input)
{
return cast_char_to_i64(input);
}
Value *cast_char_to_i32(Value *input)
{
Value_Int32 *retVal = (Value_Int32 *)newValue();
retVal->header.tag = INT32_TAG;
Value_Char *from = (Value_Char *)input;
retVal->i32 = (int32_t)from->c;
return (Value *)retVal;
}
Value *cast_char_to_i64(Value *input)
{
Value_Int64 *retVal = (Value_Int64 *)newValue();
retVal->header.tag = INT64_TAG;
Value_Char *from = (Value_Char *)input;
retVal->i64 = (int64_t)from->c;
return (Value *)retVal;
}
Value *cast_char_to_double(Value *input)
{
Value_Double *retVal = (Value_Double *)newValue();
retVal->header.tag = DOUBLE_TAG;
Value_Char *from = (Value_Char *)input;
retVal->d = (double)from->c;
return (Value *)retVal;
}
Value *cast_char_to_string(Value *input)
{
Value_String *retVal = (Value_String *)newValue();
retVal->header.tag = STRING_TAG;
Value_Char *from = (Value_Char *)input;
retVal->str = malloc(2 * sizeof(char));
memset(retVal->str, 0, 2);
retVal->str[0] = from->c;
return (Value *)retVal;
}
Value *cast_string_to_Bits8(Value *input)
{
Value_Int8 *retVal = (Value_Int8 *)newValue();
retVal->header.tag = INT8_TAG;
Value_String *from = (Value_String *)input;
retVal->i8 = (uint8_t)atoi(from->str);
return (Value *)retVal;
}
Value *cast_string_to_Bits16(Value *input)
{
Value_Int16 *retVal = (Value_Int16 *)newValue();
retVal->header.tag = INT16_TAG;
Value_String *from = (Value_String *)input;
retVal->i16 = (uint16_t)atoi(from->str);
return (Value *)retVal;
}
Value *cast_string_to_Bits32(Value *input)
{
return cast_string_to_i32(input);
}
Value *cast_string_to_Bits64(Value *input)
{
return cast_string_to_i64(input);
}
Value *cast_string_to_i32(Value *input)
{
Value_Int32 *retVal = (Value_Int32 *)newValue();
retVal->header.tag = INT32_TAG;
Value_String *from = (Value_String *)input;
retVal->i32 = atoi(from->str);
return (Value *)retVal;
}
Value *cast_string_to_i64(Value *input)
{
Value_Int64 *retVal = (Value_Int64 *)newValue();
retVal->header.tag = INT64_TAG;
Value_String *from = (Value_String *)input;
retVal->i64 = atoi(from->str);
return (Value *)retVal;
}
Value *cast_string_to_double(Value *input)
{
Value_Double *retVal = (Value_Double *)newValue();
retVal->header.tag = DOUBLE_TAG;
Value_String *from = (Value_String *)input;
retVal->d = atof(from->str);
return (Value *)retVal;
}
Value *cast_string_to_char(Value *input)
{
Value_Char *retVal = (Value_Char *)newValue();
retVal->header.tag = CHAR_TAG;
Value_String *from = (Value_String *)input;
retVal->c = from->str[0];
return (Value *)retVal;
}
// Bits cast
// autogenerated using Ruby
/* conversions from Bits8 */
Value *cast_Bits8_to_Bits16(Value *input)
{
Value_Int16 *retVal = (Value_Int16 *)newValue();
retVal->header.tag = INT16_TAG;
Value_Int8 *from = (Value_Int8 *)input;
retVal->i16 = (int16_t)from->i8;
return (Value *)retVal;
}
Value *cast_Bits8_to_Bits32(Value *input)
{
Value_Int32 *retVal = (Value_Int32 *)newValue();
retVal->header.tag = INT32_TAG;
Value_Int8 *from = (Value_Int8 *)input;
retVal->i32 = (int32_t)from->i8;
return (Value *)retVal;
}
Value *cast_Bits8_to_Bits64(Value *input)
{
Value_Int64 *retVal = (Value_Int64 *)newValue();
retVal->header.tag = INT64_TAG;
Value_Int8 *from = (Value_Int8 *)input;
retVal->i64 = (int64_t)from->i8;
return (Value *)retVal;
}
Value *cast_Bits8_to_i32(Value *input)
{
Value_Int32 *retVal = (Value_Int32 *)newValue();
retVal->header.tag = INT32_TAG;
Value_Int8 *from = (Value_Int8 *)input;
retVal->i32 = (int32_t)from->i8;
return (Value *)retVal;
}
Value *cast_Bits8_to_i64(Value *input)
{
Value_Int64 *retVal = (Value_Int64 *)newValue();
retVal->header.tag = INT64_TAG;
Value_Int8 *from = (Value_Int8 *)input;
retVal->i64 = (int64_t)from->i8;
return (Value *)retVal;
}
Value *cast_Bits8_to_double(Value *input)
{
Value_Double *retVal = (Value_Double *)newValue();
retVal->header.tag = DOUBLE_TAG;
Value_Int8 *from = (Value_Int8 *)input;
retVal->d = (double)from->i8;
return (Value *)retVal;
}
Value *cast_Bits8_to_char(Value *input)
{
Value_Char *retVal = (Value_Char *)newValue();
retVal->header.tag = CHAR_TAG;
Value_Int8 *from = (Value_Int8 *)input;
retVal->c = (char)from->i8;
return (Value *)retVal;
}
Value *cast_Bits8_to_string(Value *input)
{
Value_String *retVal = (Value_String *)newValue();
retVal->header.tag = STRING_TAG;
Value_Int8 *from = (Value_Int8 *)input;
int l = snprintf(NULL, 0, "%" PRIu8 "", from->i8);
retVal->str = malloc((l + 1) * sizeof(char));
memset(retVal->str, 0, l + 1);
sprintf(retVal->str, "%" PRIu8 "", from->i8);
return (Value *)retVal;
}
/* conversions from Bits16 */
Value *cast_Bits16_to_Bits8(Value *input)
{
Value_Int8 *retVal = (Value_Int8 *)newValue();
retVal->header.tag = INT8_TAG;
Value_Int16 *from = (Value_Int16 *)input;
retVal->i8 = (int8_t)from->i16;
return (Value *)retVal;
}
Value *cast_Bits16_to_Bits32(Value *input)
{
Value_Int32 *retVal = (Value_Int32 *)newValue();
retVal->header.tag = INT32_TAG;
Value_Int16 *from = (Value_Int16 *)input;
retVal->i32 = (int32_t)from->i16;
return (Value *)retVal;
}
Value *cast_Bits16_to_Bits64(Value *input)
{
Value_Int64 *retVal = (Value_Int64 *)newValue();
retVal->header.tag = INT64_TAG;
Value_Int16 *from = (Value_Int16 *)input;
retVal->i64 = (int64_t)from->i16;
return (Value *)retVal;
}
Value *cast_Bits16_to_i32(Value *input)
{
Value_Int32 *retVal = (Value_Int32 *)newValue();
retVal->header.tag = INT32_TAG;
Value_Int16 *from = (Value_Int16 *)input;
retVal->i32 = (int32_t)from->i16;
return (Value *)retVal;
}
Value *cast_Bits16_to_i64(Value *input)
{
Value_Int64 *retVal = (Value_Int64 *)newValue();
retVal->header.tag = INT64_TAG;
Value_Int16 *from = (Value_Int16 *)input;
retVal->i64 = (int64_t)from->i16;
return (Value *)retVal;
}
Value *cast_Bits16_to_double(Value *input)
{
Value_Double *retVal = (Value_Double *)newValue();
retVal->header.tag = DOUBLE_TAG;
Value_Int16 *from = (Value_Int16 *)input;
retVal->d = (double)from->i16;
return (Value *)retVal;
}
Value *cast_Bits16_to_char(Value *input)
{
Value_Char *retVal = (Value_Char *)newValue();
retVal->header.tag = CHAR_TAG;
Value_Int16 *from = (Value_Int16 *)input;
retVal->c = (char)from->i16;
return (Value *)retVal;
}
Value *cast_Bits16_to_string(Value *input)
{
Value_String *retVal = (Value_String *)newValue();
retVal->header.tag = STRING_TAG;
Value_Int16 *from = (Value_Int16 *)input;
int l = snprintf(NULL, 0, "%" PRIu16 "", from->i16);
retVal->str = malloc((l + 1) * sizeof(char));
memset(retVal->str, 0, l + 1);
sprintf(retVal->str, "%" PRIu16 "", from->i16);
return (Value *)retVal;
}
/* conversions from Bits32 */
Value *cast_Bits32_to_Bits8(Value *input)
{
Value_Int8 *retVal = (Value_Int8 *)newValue();
retVal->header.tag = INT8_TAG;
Value_Int32 *from = (Value_Int32 *)input;
retVal->i8 = (int8_t)from->i32;
return (Value *)retVal;
}
Value *cast_Bits32_to_Bits16(Value *input)
{
Value_Int16 *retVal = (Value_Int16 *)newValue();
retVal->header.tag = INT16_TAG;
Value_Int32 *from = (Value_Int32 *)input;
retVal->i16 = (int16_t)from->i32;
return (Value *)retVal;
}
Value *cast_Bits32_to_Bits64(Value *input)
{
Value_Int64 *retVal = (Value_Int64 *)newValue();
retVal->header.tag = INT64_TAG;
Value_Int32 *from = (Value_Int32 *)input;
retVal->i64 = (int64_t)from->i32;
return (Value *)retVal;
}
Value *cast_Bits32_to_i32(Value *input)
{
return input;
}
Value *cast_Bits32_to_i64(Value *input)
{
Value_Int64 *retVal = (Value_Int64 *)newValue();
retVal->header.tag = INT64_TAG;
Value_Int32 *from = (Value_Int32 *)input;
retVal->i64 = (int64_t)from->i32;
return (Value *)retVal;
}
Value *cast_Bits32_to_double(Value *input)
{
Value_Double *retVal = (Value_Double *)newValue();
retVal->header.tag = DOUBLE_TAG;
Value_Int32 *from = (Value_Int32 *)input;
retVal->d = (double)from->i32;
return (Value *)retVal;
}
Value *cast_Bits32_to_char(Value *input)
{
Value_Char *retVal = (Value_Char *)newValue();
retVal->header.tag = CHAR_TAG;
Value_Int32 *from = (Value_Int32 *)input;
retVal->c = (char)from->i32;
return (Value *)retVal;
}
Value *cast_Bits32_to_string(Value *input)
{
Value_String *retVal = (Value_String *)newValue();
retVal->header.tag = STRING_TAG;
Value_Int32 *from = (Value_Int32 *)input;
int l = snprintf(NULL, 0, "%" PRIu32 "", (uint32_t)from->i32);
retVal->str = malloc((l + 1) * sizeof(char));
memset(retVal->str, 0, l + 1);
sprintf(retVal->str, "%" PRIu32 "", (uint32_t)from->i32);
return (Value *)retVal;
}
/* conversions from Bits64 */
Value *cast_Bits64_to_Bits8(Value *input)
{
Value_Int8 *retVal = (Value_Int8 *)newValue();
retVal->header.tag = INT8_TAG;
Value_Int64 *from = (Value_Int64 *)input;
retVal->i8 = (int8_t)from->i64;
return (Value *)retVal;
}
Value *cast_Bits64_to_Bits16(Value *input)
{
Value_Int16 *retVal = (Value_Int16 *)newValue();
retVal->header.tag = INT16_TAG;
Value_Int64 *from = (Value_Int64 *)input;
retVal->i16 = (int16_t)from->i64;
return (Value *)retVal;
}
Value *cast_Bits64_to_Bits32(Value *input)
{
Value_Int32 *retVal = (Value_Int32 *)newValue();
retVal->header.tag = INT32_TAG;
Value_Int64 *from = (Value_Int64 *)input;
retVal->i32 = (int32_t)from->i64;
return (Value *)retVal;
}
Value *cast_Bits64_to_i32(Value *input)
{
Value_Int32 *retVal = (Value_Int32 *)newValue();
retVal->header.tag = INT32_TAG;
Value_Int64 *from = (Value_Int64 *)input;
retVal->i32 = (int32_t)from->i64;
return (Value *)retVal;
}
Value *cast_Bits64_to_i64(Value *input)
{
return input;
}
Value *cast_Bits64_to_double(Value *input)
{
Value_Double *retVal = (Value_Double *)newValue();
retVal->header.tag = DOUBLE_TAG;
Value_Int64 *from = (Value_Int64 *)input;
retVal->d = (double)from->i64;
return (Value *)retVal;
}
Value *cast_Bits64_to_char(Value *input)
{
Value_Char *retVal = (Value_Char *)newValue();
retVal->header.tag = CHAR_TAG;
Value_Int64 *from = (Value_Int64 *)input;
retVal->c = (char)from->i64;
return (Value *)retVal;
}
Value *cast_Bits64_to_string(Value *input)
{
return cast_i64_to_string(input);
}

85
support/refc/casts.h Normal file
View File

@ -0,0 +1,85 @@
#ifndef __CASTS_H__
#define __CASTS_H__
#include "cBackend.h"
#include <stdio.h>
Value *cast_i32_to_Bits8(Value *);
Value *cast_i32_to_Bits16(Value *);
Value *cast_i32_to_Bits32(Value *);
Value *cast_i32_to_Bits64(Value *);
Value *cast_i32_to_i64(Value *);
Value *cast_i32_to_double(Value *);
Value *cast_i32_to_char(Value *);
Value *cast_i32_to_string(Value *);
Value *cast_i64_to_Bits8(Value *);
Value *cast_i64_to_Bits16(Value *);
Value *cast_i64_to_Bits32(Value *);
Value *cast_i64_to_Bits64(Value *);
Value *cast_i64_to_i32(Value *);
Value *cast_i64_to_double(Value *);
Value *cast_i64_to_char(Value *);
Value *cast_i64_to_string(Value *);
Value *cast_double_to_Bits8(Value *);
Value *cast_double_to_Bits16(Value *);
Value *cast_double_to_Bits32(Value *);
Value *cast_double_to_Bits64(Value *);
Value *cast_double_to_i32(Value *);
Value *cast_double_to_i64(Value *);
Value *cast_double_to_char(Value *);
Value *cast_double_to_string(Value *);
Value *cast_char_to_Bits8(Value *);
Value *cast_char_to_Bits16(Value *);
Value *cast_char_to_Bits32(Value *);
Value *cast_char_to_Bits64(Value *);
Value *cast_char_to_i32(Value *);
Value *cast_char_to_i64(Value *);
Value *cast_char_to_double(Value *);
Value *cast_char_to_string(Value *);
Value *cast_string_to_Bits8(Value *);
Value *cast_string_to_Bits16(Value *);
Value *cast_string_to_Bits32(Value *);
Value *cast_string_to_Bits64(Value *);
Value *cast_string_to_i32(Value *);
Value *cast_string_to_i64(Value *);
Value *cast_string_to_double(Value *);
Value *cast_string_to_char(Value *);
Value *cast_Bits8_to_Bits16(Value *input);
Value *cast_Bits8_to_Bits32(Value *input);
Value *cast_Bits8_to_Bits64(Value *input);
Value *cast_Bits8_to_i32(Value *input);
Value *cast_Bits8_to_i64(Value *input);
Value *cast_Bits8_to_double(Value *input);
Value *cast_Bits8_to_char(Value *input);
Value *cast_Bits8_to_string(Value *input);
Value *cast_Bits16_to_Bits8(Value *input);
Value *cast_Bits16_to_Bits32(Value *input);
Value *cast_Bits16_to_Bits64(Value *input);
Value *cast_Bits16_to_i32(Value *input);
Value *cast_Bits16_to_i64(Value *input);
Value *cast_Bits16_to_double(Value *input);
Value *cast_Bits16_to_char(Value *input);
Value *cast_Bits16_to_string(Value *input);
Value *cast_Bits32_to_Bits8(Value *input);
Value *cast_Bits32_to_Bits16(Value *input);
Value *cast_Bits32_to_Bits64(Value *input);
Value *cast_Bits32_to_i32(Value *input);
Value *cast_Bits32_to_i64(Value *input);
Value *cast_Bits32_to_double(Value *input);
Value *cast_Bits32_to_char(Value *input);
Value *cast_Bits32_to_string(Value *input);
Value *cast_Bits64_to_Bits8(Value *input);
Value *cast_Bits64_to_Bits16(Value *input);
Value *cast_Bits64_to_Bits32(Value *input);
Value *cast_Bits64_to_i32(Value *input);
Value *cast_Bits64_to_i64(Value *input);
Value *cast_Bits64_to_double(Value *input);
Value *cast_Bits64_to_char(Value *input);
Value *cast_Bits64_to_string(Value *input);
#endif

75
support/refc/conCaseHelper.c Normal file
View File

@ -0,0 +1,75 @@
#include "conCaseHelper.h"
AConAlt *newConstructorField(int nr)
{
AConAlt *retVal = (AConAlt *)malloc(nr * sizeof(AConAlt));
for (int i = 0; i < nr; i++)
{
retVal[i].tag = -1;
}
return retVal;
}
void freeConstructorField(AConAlt *cf)
{
free(cf);
}
void constructorFieldFNextEntry(AConAlt *field, char *name, int tag)
{
AConAlt *nextEntry = field;
while (nextEntry->tag == -1)
{
nextEntry++;
}
nextEntry->name = name;
nextEntry->tag = tag;
}
int compareConstructors(Value *sc, AConAlt *field, int nr)
{
Value_Constructor *constr = (Value_Constructor *)sc;
for (int i = 0; i < nr; i++)
{
if (field->name) //decide my name
{
if (!strcmp(field->name, constr->name))
{
return i;
}
}
else // decide by tag
{
if (field->tag == constr->tag)
{
return i;
}
}
field++;
}
return -1;
}
int multiStringCompare(Value *sc, int nrDecicionOptions, char **options)
{
for (int i = 0; i < nrDecicionOptions; i++)
{
if (!strcmp(((Value_String *)sc)->str, options[i]))
{
return i;
}
}
return -1;
}
int multiDoubleCompare(Value *sc, int nrDecicionOptions, double *options)
{
for (int i = 0; i < nrDecicionOptions; i++)
{
if (((Value_Double *)sc)->d == options[i])
{
return i;
}
}
return -1;
}

20
support/refc/conCaseHelper.h Normal file
View File

@ -0,0 +1,20 @@
#ifndef __CON_CASE_HELPER_H__
#define __CON_CASE_HELPER_H__
#include "cBackend.h"
typedef struct
{
char *name;
int tag;
} AConAlt;
AConAlt *newConstructorField(int);
int compareConstructors(Value *, AConAlt *, int);
void constructorFieldFNextEntry(AConAlt *, char *, int);
void freeConstructorField(AConAlt *);
int multiStringCompare(Value *, int, char **);
int multiDoubleCompare(Value *, int, double *);
#endif

172
support/refc/datatypes.h Normal file
View File

@ -0,0 +1,172 @@
#ifndef __DATATYPES_H__
#define __DATATYPES_H__
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <pthread.h>
#include <stdint.h>
#define NO_TAG 0
#define INT8_TAG 1
#define INT16_TAG 2
#define INT32_TAG 3
#define INT64_TAG 4
#define DOUBLE_TAG 5
#define CHAR_TAG 6
#define STRING_TAG 7
#define CLOSURE_TAG 10
#define ARGLIST_TAG 11
#define CONSTRUCTOR_TAG 12
#define IOREF_TAG 20
#define ARRAY_TAG 21
#define POINTER_TAG 22
#define GC_POINTER_TAG 23
#define BUFFER_TAG 24
#define MUTEX_TAG 30
#define CONDITION_TAG 31
#define COMPLETE_CLOSURE_TAG 98 // for trampoline tail recursion handling
#define WORLD_TAG 99
typedef struct
{
int refCounter;
int tag;
} Value_header;
typedef struct
{
Value_header header;
char payload[25];
} Value;
typedef struct
{
Value_header header;
uint8_t i8;
} Value_Int8;
typedef struct
{
Value_header header;
uint16_t i16;
} Value_Int16;
typedef struct
{
Value_header header;
int32_t i32;
} Value_Int32;
typedef struct
{
Value_header header;
int64_t i64;
} Value_Int64;
typedef struct
{
Value_header header;
double d;
} Value_Double;
typedef struct
{
Value_header header;
char c;
} Value_Char;
typedef struct
{
Value_header header;
char *str;
} Value_String;
typedef struct
{
Value_header header;
int32_t total;
int32_t tag;
char *name;
Value **args;
} Value_Constructor;
typedef struct
{
Value_header header;
int32_t total;
int32_t filled;
Value **args;
} Value_Arglist;
typedef Value *(*fun_ptr_t)(Value_Arglist *);
typedef struct
{
Value_header header;
fun_ptr_t f;
Value_Arglist *arglist;
} Value_Closure;
typedef struct
{
Value_header header;
int32_t index;
} Value_IORef;
typedef struct
{
Value_header header;
void *p;
} Value_Pointer;
typedef struct
{
Value_header header;
Value_Pointer *p;
Value_Closure *onCollectFct;
} Value_GCPointer;
typedef struct
{
Value_header header;
int capacity;
Value **arr;
} Value_Array;
typedef struct
{
Value_header header;
size_t len;
char *buffer;
} Value_Buffer;
typedef struct
{
Value_header header;
pthread_mutex_t *mutex;
} Value_Mutex;
typedef struct
{
Value_header header;
pthread_cond_t *cond;
} Value_Condition;
typedef struct
{
Value **refs;
int filled;
int total;
} IORef_Storage;
typedef struct
{
Value_header header;
IORef_Storage *listIORefs;
} Value_World;
#endif

370
support/refc/mathFunctions.c Normal file
View File

@ -0,0 +1,370 @@
#include "mathFunctions.h"
#include "runtime.h"
#include "memoryManagement.h"
double unpackDouble(Value *d)
{
return ((Value_Double *)d)->d;
}
Value *believe_me(Value *a, Value *b, Value *c)
{
return c;
}
/* add */
Value *add_i32(Value *x, Value *y)
{
return (Value *)makeInt32(((Value_Int32 *)x)->i32 + ((Value_Int32 *)y)->i32);
}
Value *add_i64(Value *x, Value *y)
{
return (Value *)makeInt64(((Value_Int64 *)x)->i64 + ((Value_Int64 *)y)->i64);
}
Value *add_double(Value *x, Value *y)
{
return (Value *)makeDouble(((Value_Double *)x)->d + ((Value_Double *)y)->d);
}
/* sub */
Value *sub_i32(Value *x, Value *y)
{
return (Value *)makeInt32(((Value_Int32 *)x)->i32 - ((Value_Int32 *)y)->i32);
}
Value *sub_i64(Value *x, Value *y)
{
return (Value *)makeInt64(((Value_Int64 *)x)->i64 - ((Value_Int64 *)y)->i64);
}
Value *sub_double(Value *x, Value *y)
{
return (Value *)makeDouble(((Value_Double *)x)->d - ((Value_Double *)y)->d);
}
/* mul */
Value *mul_i32(Value *x, Value *y)
{
return (Value *)makeInt32(((Value_Int32 *)x)->i32 * ((Value_Int32 *)y)->i32);
}
Value *mul_i64(Value *x, Value *y)
{
return (Value *)makeInt64(((Value_Int64 *)x)->i64 * ((Value_Int64 *)y)->i64);
}
Value *mul_double(Value *x, Value *y)
{
return (Value *)makeDouble(((Value_Double *)x)->d * ((Value_Double *)y)->d);
}
/* div */
Value *div_i32(Value *x, Value *y)
{
return (Value *)makeInt32(((Value_Int32 *)x)->i32 / ((Value_Int32 *)y)->i32);
}
Value *div_i64(Value *x, Value *y)
{
return (Value *)makeInt64(((Value_Int64 *)x)->i64 / ((Value_Int64 *)y)->i64);
}
Value *div_double(Value *x, Value *y)
{
return (Value *)makeDouble(((Value_Double *)x)->d / ((Value_Double *)y)->d);
}
/* mod */
Value *mod_i32(Value *x, Value *y)
{
return (Value *)makeInt32(((Value_Int32 *)x)->i32 % ((Value_Int32 *)y)->i32);
}
Value *mod_i64(Value *x, Value *y)
{
return (Value *)makeInt64(((Value_Int64 *)x)->i64 % ((Value_Int64 *)y)->i64);
}
/* shiftl */
Value *shiftl_i32(Value *x, Value *y)
{
return (Value *)makeInt32(((Value_Int32 *)x)->i32 << ((Value_Int32 *)y)->i32);
}
Value *shiftl_i64(Value *x, Value *y)
{
return (Value *)makeInt64(((Value_Int64 *)x)->i64 << ((Value_Int64 *)y)->i64);
}
/* shiftr */
Value *shiftr_i32(Value *x, Value *y)
{
return (Value *)makeInt32(((Value_Int32 *)x)->i32 >> ((Value_Int32 *)y)->i32);
}
Value *shiftr_i64(Value *x, Value *y)
{
return (Value *)makeInt64(((Value_Int64 *)x)->i64 >> ((Value_Int64 *)y)->i64);
}
/* and */
Value *and_i32(Value *x, Value *y)
{
return (Value *)makeInt32(((Value_Int32 *)x)->i32 & ((Value_Int32 *)y)->i32);
}
Value *and_i64(Value *x, Value *y)
{
return (Value *)makeInt64(((Value_Int64 *)x)->i64 & ((Value_Int64 *)y)->i64);
}
/* or */
Value *or_i32(Value *x, Value *y)
{
return (Value *)makeInt32(((Value_Int32 *)x)->i32 | ((Value_Int32 *)y)->i32);
}
Value *or_i64(Value *x, Value *y)
{
return (Value *)makeInt64(((Value_Int64 *)x)->i64 | ((Value_Int64 *)y)->i64);
}
/* xor */
Value *xor_i32(Value *x, Value *y)
{
return (Value *)makeInt32(((Value_Int32 *)x)->i32 ^ ((Value_Int32 *)y)->i32);
}
Value *xor_i64(Value *x, Value *y)
{
return (Value *)makeInt64(((Value_Int64 *)x)->i64 ^ ((Value_Int64 *)y)->i64);
}
/* lt */
Value *lt_i32(Value *x, Value *y)
{
if (((Value_Int32 *)x)->i32 < ((Value_Int32 *)y)->i32)
{
return (Value *)makeInt32(1);
}
else
{
return (Value *)makeInt32(0);
}
}
Value *lt_i64(Value *x, Value *y)
{
if (((Value_Int64 *)x)->i64 < ((Value_Int64 *)y)->i64)
{
return (Value *)makeInt32(1);
}
else
{
return (Value *)makeInt32(0);
}
}
Value *lt_double(Value *x, Value *y)
{
if (((Value_Double *)x)->d < ((Value_Double *)y)->d)
{
return (Value *)makeInt32(1);
}
else
{
return (Value *)makeInt32(0);
}
}
Value *lt_char(Value *x, Value *y)
{
if (((Value_Char *)x)->c < ((Value_Char *)y)->c)
{
return (Value *)makeInt32(1);
}
else
{
return (Value *)makeInt32(0);
}
}
/* gt */
Value *gt_i32(Value *x, Value *y)
{
if (((Value_Int32 *)x)->i32 > ((Value_Int32 *)y)->i32)
{
return (Value *)makeInt32(1);
}
else
{
return (Value *)makeInt32(0);
}
}
Value *gt_i64(Value *x, Value *y)
{
if (((Value_Int64 *)x)->i64 > ((Value_Int64 *)y)->i64)
{
return (Value *)makeInt32(1);
}
else
{
return (Value *)makeInt32(0);
}
}
Value *gt_double(Value *x, Value *y)
{
if (((Value_Double *)x)->d > ((Value_Double *)y)->d)
{
return (Value *)makeInt32(1);
}
else
{
return (Value *)makeInt32(0);
}
}
Value *gt_char(Value *x, Value *y)
{
if (((Value_Char *)x)->c > ((Value_Char *)y)->c)
{
return (Value *)makeInt32(1);
}
else
{
return (Value *)makeInt32(0);
}
}
/* eq */
Value *eq_i32(Value *x, Value *y)
{
if (((Value_Int32 *)x)->i32 == ((Value_Int32 *)y)->i32)
{
return (Value *)makeInt32(1);
}
else
{
return (Value *)makeInt32(0);
}
}
Value *eq_i64(Value *x, Value *y)
{
if (((Value_Int64 *)x)->i64 == ((Value_Int64 *)y)->i64)
{
return (Value *)makeInt32(1);
}
else
{
return (Value *)makeInt32(0);
}
}
Value *eq_double(Value *x, Value *y)
{
if (((Value_Double *)x)->d == ((Value_Double *)y)->d)
{
return (Value *)makeInt32(1);
}
else
{
return (Value *)makeInt32(0);
}
}
Value *eq_char(Value *x, Value *y)
{
if (((Value_Char *)x)->c == ((Value_Char *)y)->c)
{
return (Value *)makeInt32(1);
}
else
{
return (Value *)makeInt32(0);
}
}
Value *eq_string(Value *x, Value *y)
{
if (!strcmp(((Value_String *)x)->str, ((Value_String *)y)->str))
{
return (Value *)makeInt32(1);
}
else
{
return (Value *)makeInt32(0);
}
}
/* lte */
Value *lte_i32(Value *x, Value *y)
{
if (((Value_Int32 *)x)->i32 <= ((Value_Int32 *)y)->i32)
{
return (Value *)makeInt32(1);
}
else
{
return (Value *)makeInt32(0);
}
}
Value *lte_i64(Value *x, Value *y)
{
if (((Value_Int64 *)x)->i64 <= ((Value_Int64 *)y)->i64)
{
return (Value *)makeInt32(1);
}
else
{
return (Value *)makeInt32(0);
}
}
Value *lte_double(Value *x, Value *y)
{
if (((Value_Double *)x)->d <= ((Value_Double *)y)->d)
{
return (Value *)makeInt32(1);
}
else
{
return (Value *)makeInt32(0);
}
}
Value *lte_char(Value *x, Value *y)
{
if (((Value_Char *)x)->c <= ((Value_Char *)y)->c)
{
return (Value *)makeInt32(1);
}
else
{
return (Value *)makeInt32(0);
}
}
/* gte */
Value *gte_i32(Value *x, Value *y)
{
if (((Value_Int32 *)x)->i32 >= ((Value_Int32 *)y)->i32)
{
return (Value *)makeInt32(1);
}
else
{
return (Value *)makeInt32(0);
}
}
Value *gte_i64(Value *x, Value *y)
{
if (((Value_Int64 *)x)->i64 >= ((Value_Int64 *)y)->i64)
{
return (Value *)makeInt32(1);
}
else
{
return (Value *)makeInt32(0);
}
}
Value *gte_double(Value *x, Value *y)
{
if (((Value_Double *)x)->d >= ((Value_Double *)y)->d)
{
return (Value *)makeInt32(1);
}
else
{
return (Value *)makeInt32(0);
}
}
Value *gte_char(Value *x, Value *y)
{
if (((Value_Char *)x)->c >= ((Value_Char *)y)->c)
{
return (Value *)makeInt32(1);
}
else
{
return (Value *)makeInt32(0);
}
}

84
support/refc/mathFunctions.h Normal file
View File

@ -0,0 +1,84 @@
#ifndef __MATH_FUNCTIONS_H__
#define __MATH_FUNCTIONS_H__
#include "cBackend.h"
#include <math.h>
double unpackDouble(Value *d);
Value *believe_me(Value *, Value *, Value *);
/* add */
Value *add_i32(Value *x, Value *y);
Value *add_i64(Value *x, Value *y);
Value *add_double(Value *x, Value *y);
/* sub */
Value *sub_i32(Value *x, Value *y);
Value *sub_i64(Value *x, Value *y);
Value *sub_double(Value *x, Value *y);
/* mul */
Value *mul_i32(Value *x, Value *y);
Value *mul_i64(Value *x, Value *y);
Value *mul_double(Value *x, Value *y);
/* div */
Value *div_i32(Value *x, Value *y);
Value *div_i64(Value *x, Value *y);
Value *div_double(Value *x, Value *y);
/* mod */
Value *mod_i32(Value *x, Value *y);
Value *mod_i64(Value *x, Value *y);
/* shiftl */
Value *shiftl_i32(Value *x, Value *y);
Value *shiftl_i64(Value *x, Value *y);
/* shiftr */
Value *shiftr_i32(Value *x, Value *y);
Value *shiftr_i64(Value *x, Value *y);
/* and */
Value *and_i32(Value *x, Value *y);
Value *and_i64(Value *x, Value *y);
/* or */
Value *or_i32(Value *x, Value *y);
Value *or_i64(Value *x, Value *y);
/* xor */
Value *xor_i32(Value *x, Value *y);
Value *xor_i64(Value *x, Value *y);
/* lt */
Value *lt_i32(Value *x, Value *y);
Value *lt_i64(Value *x, Value *y);
Value *lt_double(Value *x, Value *y);
Value *lt_char(Value *x, Value *y);
/* gt */
Value *gt_i32(Value *x, Value *y);
Value *gt_i64(Value *x, Value *y);
Value *gt_double(Value *x, Value *y);
Value *gt_char(Value *x, Value *y);
/* eq */
Value *eq_i32(Value *x, Value *y);
Value *eq_i64(Value *x, Value *y);
Value *eq_double(Value *x, Value *y);
Value *eq_char(Value *x, Value *y);
Value *eq_string(Value *x, Value *y);
/* lte */
Value *lte_i32(Value *x, Value *y);
Value *lte_i64(Value *x, Value *y);
Value *lte_double(Value *x, Value *y);
Value *lte_char(Value *x, Value *y);
/* gte */
Value *gte_i32(Value *x, Value *y);
Value *gte_i64(Value *x, Value *y);
Value *gte_double(Value *x, Value *y);
Value *gte_char(Value *x, Value *y);
#endif

268
support/refc/memoryManagement.c Normal file
View File

@ -0,0 +1,268 @@
#include "runtime.h"
Value *newValue()
{
Value *retVal = (Value *)malloc(sizeof(Value));
retVal->header.refCounter = 1;
retVal->header.tag = NO_TAG;
return retVal;
}
Value_Arglist *newArglist(int missing, int total)
{
Value_Arglist *retVal = (Value_Arglist *)newValue();
retVal->header.tag = ARGLIST_TAG;
retVal->total = total;
retVal->filled = total - missing;
retVal->args = (Value **)malloc(sizeof(Value *) * total);
memset(retVal->args, 0, sizeof(Value *) * total);
return retVal;
}
Value_Constructor *newConstructor(int total, int tag, const char *name)
{
Value_Constructor *retVal = (Value_Constructor *)newValue();
retVal->header.tag = CONSTRUCTOR_TAG;
retVal->total = total;
retVal->tag = tag;
int nameLength = strlen(name);
retVal->name = malloc(nameLength + 1);
memset(retVal->name, 0, nameLength + 1);
memcpy(retVal->name, name, nameLength);
retVal->args = (Value **)malloc(sizeof(Value *) * total);
return retVal;
}
Value_Closure *makeClosureFromArglist(fun_ptr_t f, Value_Arglist *arglist)
{
Value_Closure *retVal = (Value_Closure *)newValue();
retVal->header.tag = CLOSURE_TAG;
retVal->arglist = arglist; // (Value_Arglist *)newReference((Value*)arglist);
retVal->f = f;
if (retVal->arglist->filled >= retVal->arglist->total)
{
retVal->header.tag = COMPLETE_CLOSURE_TAG;
}
return retVal;
}
Value_Double *makeDouble(double d)
{
Value_Double *retVal = (Value_Double *)newValue();
retVal->header.tag = DOUBLE_TAG;
retVal->d = d;
return retVal;
}
Value_Char *makeChar(char c)
{
Value_Char *retVal = (Value_Char *)newValue();
retVal->header.tag = CHAR_TAG;
retVal->c = c;
return retVal;
}
Value_Int8 *makeInt8(int8_t i)
{
Value_Int8 *retVal = (Value_Int8 *)newValue();
retVal->header.tag = INT8_TAG;
retVal->i8 = i;
return retVal;
}
Value_Int16 *makeInt16(int16_t i)
{
Value_Int16 *retVal = (Value_Int16 *)newValue();
retVal->header.tag = INT16_TAG;
retVal->i16 = i;
return retVal;
}
Value_Int32 *makeInt32(int32_t i)
{
Value_Int32 *retVal = (Value_Int32 *)newValue();
retVal->header.tag = INT32_TAG;
retVal->i32 = i;
return retVal;
}
Value_Int64 *makeInt64(int64_t i)
{
Value_Int64 *retVal = (Value_Int64 *)newValue();
retVal->header.tag = INT64_TAG;
retVal->i64 = i;
return retVal;
}
Value_String *makeEmptyString(size_t l)
{
Value_String *retVal = (Value_String *)newValue();
retVal->header.tag = STRING_TAG;
retVal->str = malloc(l);
memset(retVal->str, 0, l);
return retVal;
}
Value_String *makeString(char *s)
{
Value_String *retVal = (Value_String *)newValue();
int l = strlen(s);
retVal->header.tag = STRING_TAG;
retVal->str = malloc(l + 1);
memset(retVal->str, 0, l + 1);
memcpy(retVal->str, s, l);
return retVal;
}
Value_Pointer *makePointer(void *ptr_Raw)
{
Value_Pointer *p = (Value_Pointer *)newValue();
p->header.tag = POINTER_TAG;
p->p = ptr_Raw;
return p;
}
Value_Array *makeArray(int length)
{
Value_Array *a = (Value_Array *)newValue();
a->header.tag = ARRAY_TAG;
a->capacity = length;
a->arr = (Value **)malloc(sizeof(Value *) * length);
memset(a->arr, 0, sizeof(Value *) * length);
return a;
}
Value_World *makeWorld()
{
Value_World *retVal = (Value_World *)newValue();
retVal->header.tag = WORLD_TAG;
retVal->listIORefs = NULL;
return retVal;
}
Value *newReference(Value *source)
{
// note that we explicitly allow NULL as source (for erased arguments)
if (source)
{
source->header.refCounter++;
}
return source;
}
void removeReference(Value *elem)
{
if (!elem)
{
return;
}
// remove reference counter
elem->header.refCounter--;
if (elem->header.refCounter == 0)
// recursively remove all references to all children
{
switch (elem->header.tag)
{
case INT32_TAG:
/* nothing to delete, added for sake of completeness */
break;
case INT64_TAG:
/* nothing to delete, added for sake of completeness */
break;
case DOUBLE_TAG:
/* nothing to delete, added for sake of completeness */
break;
case CHAR_TAG:
/* nothing to delete, added for sake of completeness */
break;
case STRING_TAG:
free(((Value_String *)elem)->str);
break;
case CLOSURE_TAG:
{
Value_Closure *cl = (Value_Closure *)elem;
Value_Arglist *al = cl->arglist;
removeReference((Value *)al);
break;
}
case COMPLETE_CLOSURE_TAG:
{
Value_Closure *cl = (Value_Closure *)elem;
Value_Arglist *al = cl->arglist;
removeReference((Value *)al);
break;
}
case ARGLIST_TAG:
{
Value_Arglist *al = (Value_Arglist *)elem;
for (int i = 0; i < al->filled; i++)
{
removeReference(al->args[i]);
}
free(al->args);
break;
}
case CONSTRUCTOR_TAG:
{
Value_Constructor *constr = (Value_Constructor *)elem;
for (int i = 0; i < constr->total; i++)
{
removeReference(constr->args[i]);
}
if (constr->name)
{
free(constr->name);
}
free(constr->args);
break;
}
case IOREF_TAG:
/* nothing to delete, added for sake of completeness */
break;
case ARRAY_TAG:
{
Value_Array *a = (Value_Array *)elem;
for (int i = 0; i < a->capacity; i++)
{
removeReference(a->arr[i]);
}
free(a->arr);
break;
}
case POINTER_TAG:
/* nothing to delete, added for sake of completeness */
break;
case GC_POINTER_TAG:
{
/* maybe here we need to invoke onCollectAny */
Value_GCPointer *vPtr = (Value_GCPointer *)elem;
Value *closure1 = apply_closure((Value *)vPtr->onCollectFct, (Value *)vPtr->p);
apply_closure(closure1, NULL);
removeReference(closure1);
removeReference((Value *)vPtr->onCollectFct);
removeReference((Value *)vPtr->p);
break;
}
case WORLD_TAG:
{
Value_World *w = (Value_World *)elem;
if (w->listIORefs)
{
for (int i = 0; i < w->listIORefs->filled; i++)
{
removeReference(w->listIORefs->refs[i]);
}
free(w->listIORefs->refs);
free(w->listIORefs);
}
}
default:
break;
}
// finally, free element
free(elem);
}
}

28
support/refc/memoryManagement.h Normal file
View File

@ -0,0 +1,28 @@
#ifndef __MEMORY_MANAGEMENT_H__
#define __MEMORY_MANAGEMENT_H__
#include "cBackend.h"
Value *newValue(void);
Value *newReference(Value *source);
void removeReference(Value *source);
Value_Arglist *newArglist(int missing, int total);
Value_Constructor *newConstructor(int total, int tag, const char *name);
// copies arglist, no pointer bending
Value_Closure *makeClosureFromArglist(fun_ptr_t f, Value_Arglist *);
Value_Double *makeDouble(double d);
Value_Char *makeChar(char d);
Value_Int8 *makeInt8(int8_t i);
Value_Int16 *makeInt16(int16_t i);
Value_Int32 *makeInt32(int32_t i);
Value_Int64 *makeInt64(int64_t i);
Value_String *makeEmptyString(size_t l);
Value_String *makeString(char *);
Value_Pointer *makePointer(void *);
Value_Array *makeArray(int length);
Value_World *makeWorld(void);
#endif

322
support/refc/prim.c Normal file
View File

@ -0,0 +1,322 @@
#include "prim.h"
Value *Prelude_IO_prim__getChar(Value *world)
{
char c = getchar();
return (Value *)makeChar(c);
}
// This is NOT THREAD SAFE in the current implementation
IORef_Storage *newIORef_Storage(int capacity)
{
IORef_Storage *retVal = (IORef_Storage *)malloc(sizeof(IORef_Storage));
retVal->filled = 0;
retVal->total = capacity;
retVal->refs = (Value **)malloc(sizeof(Value *) * retVal->total);
return retVal;
}
void doubleIORef_Storage(IORef_Storage *ior)
{
Value **values = (Value **)malloc(sizeof(Value *) * ior->total * 2);
ior->total *= 2;
for (int i = 0; i < ior->filled; i++)
{
values[i] = ior->refs[i];
}
free(ior->refs);
ior->refs = values;
}
Value *newIORef(Value *erased, Value *input_value, Value *_world)
{
// if no ioRef Storag exist, start with one
Value_World *world = (Value_World *)_world;
if (!world->listIORefs)
{
world->listIORefs = newIORef_Storage(128);
}
// expand size of needed
if (world->listIORefs->filled >= world->listIORefs->total)
{
doubleIORef_Storage(world->listIORefs);
}
// store value
Value_IORef *ioRef = (Value_IORef *)newValue();
ioRef->header.tag = IOREF_TAG;
ioRef->index = world->listIORefs->filled;
world->listIORefs->refs[world->listIORefs->filled] = newReference(input_value);
world->listIORefs->filled++;
return (Value *)ioRef;
}
Value *readIORef(Value *erased, Value *_index, Value *_world)
{
Value_World *world = (Value_World *)_world;
Value_IORef *index = (Value_IORef *)_index;
return newReference(world->listIORefs->refs[index->index]);
}
Value *writeIORef(Value *erased, Value *_index, Value *new_value, Value *_world)
{
Value_World *world = (Value_World *)_world;
Value_IORef *index = (Value_IORef *)_index;
removeReference(world->listIORefs->refs[index->index]);
world->listIORefs->refs[index->index] = newReference(new_value);
return newReference(_index);
}
// -----------------------------------
// System operations
// -----------------------------------
Value *sysOS(void)
{
#ifdef _WIN32
return (Value *)makeString("windows");
#elif _WIN64
return (Value *)makeString("windows");
#elif __APPLE__ || __MACH__
return (Value *)makeString("Mac OSX");
#elif __linux__
return (Value *)makeString("Linux");
#elif __FreeBSD__
return (Value *)makeString("FreeBSD");
#elif __unix || __unix__
return (Value *)makeString("Unix");
#else
return (Value *)makeString("Other");
#endif
}
//
//
//
// // -----------------------------------
// // Array operations
// // -----------------------------------
Value *newArray(Value *erased, Value *_length, Value *v, Value *_word)
{
int length = extractInt(_length);
Value_Array *a = makeArray(length);
for (int i = 0; i < length; i++)
{
a->arr[i] = newReference(v);
}
return (Value *)a;
}
Value *arrayGet(Value *erased, Value *_array, Value *_index, Value *_word)
{
Value_Array *a = (Value_Array *)_array;
return newReference(a->arr[((Value_Int32 *)_index)->i32]);
}
Value *arraySet(Value *erased, Value *_array, Value *_index, Value *v, Value *_word)
{
Value_Array *a = (Value_Array *)_array;
removeReference(a->arr[((Value_Int32 *)_index)->i32]);
a->arr[((Value_Int32 *)_index)->i32] = newReference(v);
return NULL;
}
//
// -----------------------------------
// Pointer operations
// -----------------------------------
Value *PrimIO_prim__nullAnyPtr(Value *ptr)
{
void *p;
switch (ptr->header.tag)
{
case STRING_TAG:
p = ((Value_String *)ptr)->str;
break;
case POINTER_TAG:
p = ((Value_Pointer *)ptr)->p;
break;
default:
p = NULL;
}
if (p)
{
return (Value *)makeInt32(0);
}
else
{
return (Value *)makeInt32(1);
}
}
Value *onCollect(Value *_erased, Value *_anyPtr, Value *_freeingFunction, Value *_world)
{
printf("onCollect called\n");
Value_GCPointer *retVal = (Value_GCPointer *)newValue();
retVal->header.tag = GC_POINTER_TAG;
retVal->p = (Value_Pointer *)newReference(_anyPtr);
retVal->onCollectFct = (Value_Closure *)newReference(_freeingFunction);
return (Value *)retVal;
}
Value *onCollectAny(Value *_erased, Value *_anyPtr, Value *_freeingFunction, Value *_world)
{
printf("onCollectAny called\n");
Value_GCPointer *retVal = (Value_GCPointer *)newValue();
retVal->header.tag = GC_POINTER_TAG;
retVal->p = (Value_Pointer *)_anyPtr;
retVal->onCollectFct = (Value_Closure *)_freeingFunction;
return (Value *)retVal;
}
Value *voidElim(Value *erased1, Value *erased2)
{
return NULL;
}
Value *schemeCall(
Value *v1, Value *_schemeFuncName, Value *_schemArgs, Value *_world)
{
Value_String *schemeFuncName = (Value_String *)_schemeFuncName;
if (!strcmp("blodwen-thread", schemeFuncName->str))
{
fprintf(stderr, "Multithreading not supported\n");
exit(-1);
}
printf("Scheme Call %s not supported\n", schemeFuncName->str);
exit(-1);
}
// Threads
// %foreign "scheme:blodwen-mutex"
// prim__makeMutex : PrimIO Mutex
// using pthread_mutex_init(pthread_mutex_t *mutex, const pthread_mutexattr_t *attr)
Value *System_Concurrency_Raw_prim__makeMutex(Value *_world)
{
Value_Mutex *mut = (Value_Mutex *)newValue();
mut->header.tag = MUTEX_TAG;
mut->mutex = (pthread_mutex_t *)malloc(sizeof(pthread_mutex_t));
if (pthread_mutex_init(mut->mutex, NULL))
{
fprintf(stderr, "Error init Mutex\n");
exit(-1);
}
return (Value *)mut;
}
// %foreign "scheme:blodwen-lock"
// prim__mutexAcquire : Mutex -> PrimIO ()
// using pthread_mutex_lock(pthread_mutex_t *mutex)
Value *System_Concurrency_Raw_prim__mutexAcquire(Value *_mutex, Value *_world)
{
if (pthread_mutex_lock(((Value_Mutex *)_mutex)->mutex))
{
fprintf(stderr, "Error locking mutex\n");
exit(-1);
}
return NULL;
}
// %foreign "scheme:blodwen-unlock"
// prim__mutexRelease : Mutex -> PrimIO ()
//using int pthread_mutex_unlock(pthread_mutex_t *mutex)
Value *System_Concurrency_Raw_prim__mutexRelease(Value *_mutex, Value *_world)
{
if (pthread_mutex_unlock(((Value_Mutex *)_mutex)->mutex))
{
fprintf(stderr, "Error locking mutex\n");
exit(-1);
}
return NULL;
}
// %foreign "scheme:blodwen-condition"
// prim__makeCondition : PrimIO Condition
// using int pthread_cond_init(pthread_cond_t *cond, const pthread_condattr_t *attr)
// with standard initialisation
Value *System_Concurrency_Raw_prim__makeCondition(Value *_world)
{
// typedef struct{
// Value_header header;
// pthread_cond_t *cond;
// }Value_Condition;
Value_Condition *c = (Value_Condition *)newValue();
c->header.tag = CONDITION_TAG;
c->cond = (pthread_cond_t *)malloc(sizeof(pthread_cond_t));
if (pthread_cond_init(c->cond, NULL))
{
fprintf(stderr, "error init condition\n");
exit(-1);
}
return (Value *)c;
}
// %foreign "scheme:blodwen-condition-wait"
// prim__conditionWait : Condition -> Mutex -> PrimIO ()
// using int pthread_cond_wait(pthread_cond_t *, pthread_mutex_t *mutex)
Value *System_Concurrency_Raw_prim__conditionWait(Value *_condition, Value *_mutex, Value *_world)
{
Value_Condition *cond = (Value_Condition *)_condition;
Value_Mutex *mutex = (Value_Mutex *)_mutex;
if (pthread_cond_wait(cond->cond, mutex->mutex))
{
fprintf(stderr, "Error Conditional Wait\n");
exit(-1);
}
return NULL;
}
// %foreign "scheme:blodwen-condition-wait-timeout"
// prim__conditionWaitTimeout : Condition -> Mutex -> Int -> PrimIO ()
// using int pthread_cond_timedwait(pthread_cond_t *cond, pthread_mutex_t *mutex, const struct timespec *abstime)
Value *System_Concurrency_Raw_prim__conditionWaitTimeout(Value *_condition, Value *_mutex, Value *_timeout, Value *_world)
{
Value_Condition *cond = (Value_Condition *)_condition;
Value_Mutex *mutex = (Value_Mutex *)_mutex;
Value_Int32 *timeout = (Value_Int32 *)_timeout;
struct timespec t;
t.tv_sec = timeout->i32 / 1000000;
t.tv_nsec = timeout->i32 % 1000000;
if (pthread_cond_timedwait(cond->cond, mutex->mutex, &t))
{
fprintf(stderr, "Error in pthread_cond_timedwait\n");
exit(-1);
}
return NULL;
}
// %foreign "scheme:blodwen-condition-signal"
// prim__conditionSignal : Condition -> PrimIO ()
// using int pthread_cond_signal(pthread_cond_t *cond)
Value *System_Concurrency_Raw_prim__conditionSignal(Value *_condition, Value *_world)
{
Value_Condition *cond = (Value_Condition *)_condition;
if (pthread_cond_signal(cond->cond))
{
fprintf(stderr, "Error in pthread_cond_signal\n");
exit(-1);
}
return NULL;
}
// %foreign "scheme:blodwen-condition-broadcast"
// prim__conditionBroadcast : Condition -> PrimIO ()
// using int pthread_cond_broadcast(pthread_cond_t *cond)
Value *System_Concurrency_Raw_prim__conditionBroadcast(Value *_condition, Value *_mutex)
{
Value_Condition *cond = (Value_Condition *)_condition;
if (pthread_cond_broadcast(cond->cond))
{
fprintf(stderr, "Error in pthread_cond_broadcast\n");
exit(-1);
}
return NULL;
}

53
support/refc/prim.h Normal file
View File

@ -0,0 +1,53 @@
#ifndef __PRIM_H__
#define __PRIM_H__
#include "cBackend.h"
#include <sys/utsname.h>
// Value * Prelude_IO_prim__putStr(Value *, Value *);
Value *Prelude_IO_prim__getChar(Value *);
// IORef
Value *newIORef(Value *, Value *, Value *);
Value *readIORef(Value *, Value *, Value *);
Value *writeIORef(Value *, Value *, Value *, Value *);
// Sys
Value *sysOS(void);
// Array
Value *newArray(Value *, Value *, Value *, Value *);
Value *arrayGet(Value *, Value *, Value *, Value *);
Value *arraySet(Value *, Value *, Value *, Value *, Value *);
// Pointer
Value *PrimIO_prim__nullAnyPtr(Value *);
Value *onCollect(Value *, Value *, Value *, Value *);
Value *onCollectAny(Value *, Value *, Value *, Value *);
// Scheme Calls intercept
Value *voidElim(Value *, Value *);
Value *schemeCall(Value *, Value *, Value *, Value *);
// Threads
Value *System_Concurrency_Raw_prim__mutexRelease(Value *, Value *);
Value *System_Concurrency_Raw_prim__mutexAcquire(Value *, Value *);
Value *System_Concurrency_Raw_prim__makeMutex(Value *);
Value *System_Concurrency_Raw_prim__makeCondition(Value *);
Value *System_Concurrency_Raw_prim__conditionWait(Value *, Value *, Value *);
Value *System_Concurrency_Raw_prim__conditionWaitTimeout(Value *, Value *, Value *, Value *);
Value *System_Concurrency_Raw_prim__conditionSignal(Value *, Value *);
Value *System_Concurrency_Raw_prim__conditionBroadcast(Value *, Value *);
#endif

114
support/refc/runtime.c Normal file
View File

@ -0,0 +1,114 @@
#include "runtime.h"
void push_Arglist(Value_Arglist *arglist, Value *arg)
{
if (arglist->filled >= arglist->total)
{
fprintf(stderr, "unable to add more arguments to arglist\n");
exit(1);
}
arglist->args[arglist->filled] = newReference(arg);
arglist->filled++;
}
Value *apply_closure(Value *_clos, Value *arg)
{
// create a new arg list
Value_Arglist *oldArgs = ((Value_Closure *)_clos)->arglist;
Value_Arglist *newArgs = newArglist(0, oldArgs->total);
newArgs->filled = oldArgs->filled + 1;
// add argument to new arglist
for (int i = 0; i < oldArgs->filled; i++)
{
newArgs->args[i] = newReference(oldArgs->args[i]);
}
newArgs->args[oldArgs->filled] = newReference(arg);
Value_Closure *clos = (Value_Closure *)_clos;
// check if enough arguments exist
if (newArgs->filled >= newArgs->total)
{
fun_ptr_t f = clos->f;
while (1)
{
Value *retVal = f(newArgs);
removeReference((Value *)newArgs);
if (!retVal || retVal->header.tag != COMPLETE_CLOSURE_TAG)
{
return retVal;
}
f = ((Value_Closure *)retVal)->f;
newArgs = ((Value_Closure *)retVal)->arglist;
newArgs = (Value_Arglist *)newReference((Value *)newArgs);
removeReference(retVal);
}
}
return (Value *)makeClosureFromArglist(clos->f, newArgs);
}
Value *tailcall_apply_closure(Value *_clos, Value *arg)
{
// create a new arg list
Value_Arglist *oldArgs = ((Value_Closure *)_clos)->arglist;
Value_Arglist *newArgs = newArglist(0, oldArgs->total);
newArgs->filled = oldArgs->filled + 1;
// add argument to new arglist
for (int i = 0; i < oldArgs->filled; i++)
{
newArgs->args[i] = newReference(oldArgs->args[i]);
}
newArgs->args[oldArgs->filled] = newReference(arg);
Value_Closure *clos = (Value_Closure *)_clos;
// check if enough arguments exist
if (newArgs->filled >= newArgs->total)
return (Value *)makeClosureFromArglist(clos->f, newArgs);
return (Value *)makeClosureFromArglist(clos->f, newArgs);
}
int extractInt(Value *v)
{
if (v->header.tag == INT64_TAG)
{
return (int)((Value_Int64 *)v)->i64;
}
if (v->header.tag == INT32_TAG)
{
return ((Value_Int32 *)v)->i32;
}
if (v->header.tag == DOUBLE_TAG)
{
return (int)((Value_Double *)v)->d;
}
return -1;
}
Value *trampoline(Value *closure)
{
fun_ptr_t f = ((Value_Closure *)closure)->f;
Value_Arglist *_arglist = ((Value_Closure *)closure)->arglist;
Value_Arglist *arglist = (Value_Arglist *)newReference((Value *)_arglist);
removeReference(closure);
while (1)
{
Value *retVal = f(arglist);
removeReference((Value *)arglist);
if (!retVal || retVal->header.tag != COMPLETE_CLOSURE_TAG)
{
return retVal;
}
f = ((Value_Closure *)retVal)->f;
arglist = ((Value_Closure *)retVal)->arglist;
arglist = (Value_Arglist *)newReference((Value *)arglist);
removeReference(retVal);
}
return NULL;
}

12
support/refc/runtime.h Normal file
View File

@ -0,0 +1,12 @@
#ifndef __RUNTIME_H__
#define __RUNTIME_H__
#include "cBackend.h"
Value *apply_closure(Value *, Value *arg);
void push_Arglist(Value_Arglist *arglist, Value *arg);
int extractInt(Value *);
Value *trampoline(Value *closure);
Value *tailcall_apply_closure(Value *_clos, Value *arg);
#endif

91
support/refc/stringOps.c Normal file
View File

@ -0,0 +1,91 @@
#include "stringOps.h"
Value *stringLength(Value *s)
{
int length = strlen(((Value_String *)s)->str);
return (Value *)makeInt32(length);
}
Value *head(Value *str)
{
Value_Char *c = (Value_Char *)newValue();
c->header.tag = CHAR_TAG;
c->c = ((Value_String *)str)->str[0];
return (Value *)c;
}
Value *tail(Value *str)
{
Value_Char *c = (Value_Char *)newValue();
c->header.tag = CHAR_TAG;
Value_String *s = (Value_String *)str;
int l = strlen(s->str);
c->c = s->str[l - 1];
return (Value *)c;
}
Value *reverse(Value *str)
{
Value_String *retVal = (Value_String *)newValue();
retVal->header.tag = STRING_TAG;
Value_String *input = (Value_String *)str;
int l = strlen(input->str);
retVal->str = malloc(l + 1);
memset(retVal->str, 0, l + 1);
char *p = retVal->str;
char *q = input->str + (l - 1);
for (int i = 1; i < l; i++)
{
*p++ = *q--;
}
return (Value *)retVal;
}
Value *strIndex(Value *str, Value *i)
{
Value_Char *c;
switch (i->header.tag)
{
case INT64_TAG:
c = makeChar(((Value_String *)str)->str[((Value_Int64 *)i)->i64]);
return (Value *)c;
default:
c = makeChar(((Value_String *)str)->str[((Value_Int32 *)i)->i32]);
return (Value *)c;
}
}
Value *strCons(Value *c, Value *str)
{
int l = strlen(((Value_String *)str)->str);
Value_String *retVal = makeEmptyString(l + 2);
retVal->str[0] = ((Value_Char *)c)->c;
memcpy(retVal->str + 1, ((Value_String *)str)->str, l);
return (Value *)retVal;
}
Value *strAppend(Value *a, Value *b)
{
int la = strlen(((Value_String *)a)->str);
int lb = strlen(((Value_String *)b)->str);
Value_String *retVal = makeEmptyString(la + lb + 1);
memcpy(retVal->str, ((Value_String *)a)->str, la);
memcpy(retVal->str + la, ((Value_String *)b)->str, lb);
return (Value *)retVal;
}
Value *strSubstr(Value *s, Value *start, Value *len)
{
Value_String *retVal;
switch (len->header.tag)
{
case INT64_TAG:
retVal = makeEmptyString(((Value_Int64 *)len)->i64 + 1);
memcpy(retVal->str, ((Value_String *)s)->str, ((Value_Int64 *)len)->i64);
return (Value *)retVal;
default:
retVal = makeEmptyString(((Value_Int32 *)len)->i32 + 1);
memcpy(retVal->str, ((Value_String *)s)->str, ((Value_Int32 *)len)->i32);
return (Value *)retVal;
}
}

15
support/refc/stringOps.h Normal file
View File

@ -0,0 +1,15 @@
#ifndef __STRING_OPS_H__
#define __STRING_OPS_H__
#include "cBackend.h"
Value *stringLength(Value *);
Value *head(Value *str);
Value *tail(Value *str);
Value *reverse(Value *str);
Value *strIndex(Value *str, Value *i);
Value *strCons(Value *c, Value *str);
Value *strAppend(Value *a, Value *b);
Value *strSubstr(Value *s, Value *start, Value *len);
#endif